1;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. 2;; All rights reserved. 3;; 4;; Redistribution and use in source and binary forms, with or without 5;; modification, are permitted provided that the following conditions are 6;; met: 7;; 8;; - Redistributions of source code must retain the above copyright 9;; notice, this list of conditions and the following disclaimer. 10;; 11;; - Redistributions in binary form must reproduce the above copyright 12;; notice, this list of conditions and the following disclaimer in 13;; the documentation and/or other materials provided with the 14;; distribution. 15;; 16;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the 17;; names of its contributors may be used to endorse or promote products 18;; derived from this software without specific prior written permission. 19;; 20;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS 21;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED 22;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A 23;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER 24;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 25;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 26;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 27;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 28;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 29;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 30;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 32(in-package "BOOT") 33 34;; definition of our stream structure 35(defstruct libstream mode dirname (indextable nil) (indexstream nil)) 36;indextable is a list of entries (key class <location or filename>) 37;filename is of the form filenumber.lsp or filenumber.o 38 39(defun |make_compiler_output_stream|(lib basename) 40 (open (concat (libstream-dirname lib) "/" basename ".lsp") 41 :direction :output :if-exists :supersede)) 42 43(defun |rMkIstream| (file) 44 (let ((stream nil) 45 (fullname (|make_input_filename| file))) 46 (setq stream (|get_input_index_stream| fullname)) 47 (if (null stream) 48 (ERROR (format nil "Library ~s doesn't exist" 49 (|make_filename| file)))) 50 (make-libstream :mode 'input :dirname fullname 51 :indextable (|get_index_table_from_stream| stream) 52 :indexstream stream))) 53 54(defun |rMkOstream| (file) 55 (let ((stream nil) 56 (indextable nil) 57 (fullname (|make_full_namestring| file))) 58 (case (file-kind fullname) 59 (-1 (makedir fullname)) 60 (0 (error (format nil "~s is an existing file, not a library" 61 fullname))) 62 (1 nil) 63 (otherwise (error "Bad value from directory?"))) 64 (multiple-value-setq (stream indextable) 65 (|get_io_index_stream| fullname)) 66 (make-libstream :mode 'output :dirname fullname 67 :indextable indextable 68 :indexstream stream ))) 69 70(defvar |$index_filename| "index.KAF") 71 72;get the index table of the lisplib in dirname 73(defun getindextable (dirname) 74 (let ((index-file (concat dirname "/" |$index_filename|))) 75 (if (probe-file index-file) 76 (with-open-file (stream index-file) 77 (|get_index_table_from_stream| stream)) 78 ;; create empty index file to mark directory as lisplib 79 (with-open-file (stream index-file :direction :output) nil)))) 80 81;get the index stream of the lisplib in dirname 82(defun |get_input_index_stream| (dirname) 83 (let ((index-file (concat dirname "/" |$index_filename|))) 84 (open index-file :direction :input :if-does-not-exist nil))) 85 86(defun |get_index_table_from_stream| (stream) 87 (let ((pos (read stream))) 88 (cond ((numberp pos) 89 (file-position stream pos) 90 (read stream)) 91 (t pos)))) 92 93(defun |get_io_index_stream| (dirname) 94 (let* ((index-file (concat dirname "/" |$index_filename|)) 95 (stream (open index-file :direction :io :if-exists :overwrite 96 :if-does-not-exist :create)) 97 (indextable ()) 98 (pos (read stream nil nil))) 99 (cond ((numberp pos) 100 (file-position stream pos) 101 (setq indextable (read stream)) 102 (file-position stream pos)) 103 (t (file-position stream 0) 104 (princ " " stream) 105 (setq indextable pos))) 106 (values stream indextable))) 107 108;substitute indextable in dirname 109 110(defun |write_indextable| (indextable stream) 111 (let ((pos (file-position stream))) 112 (write indextable :stream stream :level nil :length nil :escape t) 113 #+:GCL (force-output stream) 114 (file-position stream 0) 115 (princ pos stream) 116 #+:GCL (force-output stream))) 117 118(defun putindextable (indextable dirname) 119 (with-open-file 120 (stream (concat dirname "/" |$index_filename|) 121 :direction :io :if-exists :overwrite 122 :if-does-not-exist :create) 123 (file-position stream :end) 124 (|write_indextable| indextable stream))) 125 126(defparameter |$error_mark| (GENSYM)) 127 128;; (RREAD key rstream) 129(defun |rread1| (key rstream sv) 130 (if (equal (libstream-mode rstream) 'output) (error "not input stream")) 131 (let* ((entry 132 (and (stringp key) 133 (assoc key (libstream-indextable rstream) :test #'string=))) 134 (file-or-pos (and entry (caddr entry)))) 135 (cond ((null entry) 136 (cond 137 ((eq sv |$error_mark|) 138 (error (format nil "key ~a not found" key))) 139 (t (return-from |rread1| sv)))) 140 ((null (caddr entry)) (cdddr entry)) ;; for small items 141 ((numberp file-or-pos) 142 (file-position (libstream-indexstream rstream) file-or-pos) 143 (read (libstream-indexstream rstream))) 144 (t 145 (with-open-file 146 (stream (concat (libstream-dirname rstream) "/" file-or-pos)) 147 (read stream))) ))) 148 149;; (RREAD key rstream) 150(defun |rread0| (key rstream) 151 (|rread1| key rstream |$error_mark|)) 152 153;; (RKEYIDS filearg) -- interned version of keys 154(defun RKEYIDS (filearg) 155 (mapcar #'intern (mapcar #'car (getindextable 156 (|make_input_filename| (list filearg)))))) 157 158;; (RWRITE cvec item rstream) 159(defun |rwrite0| (key item rstream) 160 (if (equal (libstream-mode rstream) 'input) (error "not output stream")) 161 (let ((stream (libstream-indexstream rstream)) 162 (pos (if item (cons (file-position (libstream-indexstream rstream)) nil) 163 (cons nil item)))) ;; for small items 164 (|make_entry| (string key) rstream pos) 165 (when (numberp (car pos)) 166 (write item :stream stream :level nil :length nil 167 :circle t :array t :escape t) 168 (terpri stream)))) 169 170(defun |make_entry| (key rstream value-or-pos) 171 (let ((entry (assoc key (libstream-indextable rstream) :test #'equal))) 172 (if (null entry) 173 (push (setq entry (cons key (cons 0 value-or-pos))) 174 (libstream-indextable rstream)) 175 (progn 176 (if (stringp (caddr entry)) (BREAK)) 177 (setf (cddr entry) value-or-pos))) 178 entry)) 179 180 181(defun rshut (rstream) 182 (if (eq (libstream-mode rstream) 'output) 183 (|write_indextable| (libstream-indextable rstream) 184 (libstream-indexstream rstream))) 185 (close (libstream-indexstream rstream))) 186 187;; filespec is id or list of 1, 2 or 3 ids 188;; filearg is filespec or 1, 2 or 3 ids 189;; (RPACKFILE filearg) -- compiles code files and converts to compressed format 190(defun rpackfile (filespec) 191 (setq filespec (|make_filename| filespec)) 192 (if (string= (pathname-type filespec) "NRLIB") 193 (let ((base (pathname-name filespec))) 194 (|compile_lib_file| 195 (concatenate 'string (namestring filespec) "/" base ".lsp"))) 196 (error "RPACKFILE only works on .NRLIB-s")) 197 filespec) 198 199#+:GCL 200(defun spad-fixed-arg (fname ) 201 (and (equal (symbol-package fname) (find-package "BOOT")) 202 (not (get fname 'compiler::spad-var-arg)) 203 (search ";" (symbol-name fname)) 204 (or (get fname 'compiler::fixed-args) 205 (setf (get fname 'compiler::fixed-args) t))) 206 nil) 207 208#+:GCL 209(defun |compile_lib_file|(fn) 210 (unwind-protect 211 (progn 212 (trace (compiler::fast-link-proclaimed-type-p 213 :exitcond nil 214 :entrycond (spad-fixed-arg (car system::arglist)))) 215 (trace (compiler::t1defun :exitcond nil 216 :entrycond (spad-fixed-arg (caar system::arglist)))) 217 (compile-file fn)) 218 (untrace compiler::fast-link-proclaimed-type-p compiler::t1defun))) 219#-:GCL 220(defun |compile_lib_file|(fn) 221 (if FRICAS-LISP::algebra-optimization 222 (proclaim (cons 'optimize FRICAS-LISP::algebra-optimization))) 223 (compile-file fn)) 224 225 226;; (RDROPITEMS filearg keys) don't delete, used in files.spad 227(defun RDROPITEMS (filearg keys &aux (ctable (getindextable filearg))) 228 (mapc #'(lambda(x) 229 (setq ctable (delete x ctable :key #'car :test #'equal)) ) 230 (mapcar #'string keys)) 231 (putindextable ctable filearg)) 232 233;; cms file operations 234(defun |make_filename0|(filearg filetype) 235 (let ((filetype (if (and filetype (symbolp filetype)) 236 (symbol-name filetype) 237 filetype))) 238 (cond 239 ((pathnamep filearg) 240 (cond ((or (null filetype) 241 (pathname-type filearg)) 242 (namestring filearg)) 243 (t (namestring (make-pathname :directory (pathname-directory filearg) 244 :name (pathname-name filearg) 245 :type filetype))))) 246 ((and (stringp filearg) (null filetype)) filearg) 247 ((and (stringp filearg) (stringp filetype) 248 (pathname-type filearg) 249 (string-equal (pathname-type filearg) filetype)) 250 filearg) 251 ((consp filearg) (BREAK)) 252 (t (if (stringp filetype) (setq filetype (intern filetype "BOOT"))) 253 (let ((ft (or (cdr (assoc filetype |$filetype_table|)) filetype))) 254 (if ft 255 (concatenate 'string (string filearg) "." (string ft)) 256 (string filearg))))))) 257 258(defun |make_filename| (filearg) 259 (cond 260 ((consp filearg) 261 (|make_filename0| (car filearg) (cadr filearg))) 262 (t (|make_filename0| filearg nil)))) 263 264(defun |make_full_namestring| (filearg) 265 (namestring (merge-pathnames (|make_filename| filearg)))) 266 267(defun |get_directory_list| (ft &aux (cd (get-current-directory))) 268 (cond ((member ft '("NRLIB" "DAASE" "EXPOSED") :test #'string=) 269 (if (eq |$UserLevel| '|development|) 270 (cons cd $library-directory-list) 271 $library-directory-list)) 272 (t (adjoin cd 273 (adjoin (namestring (user-homedir-pathname)) $directory-list 274 :test #'string=) 275 :test #'string=)))) 276 277(defun |probe_name| (file) 278 (if (|fricas_probe_file| file) (namestring file) nil)) 279 280(defun |make_input_filename0|(filearg filetype) 281 (let* 282 ((filename (|make_filename0| filearg filetype)) 283 (dirname (pathname-directory filename)) 284 (ft (pathname-type filename)) 285 (dirs (|get_directory_list| ft)) 286 (newfn nil)) 287 (if (or (null dirname) (eqcar dirname :relative)) 288 (dolist (dir dirs (|probe_name| filename)) 289 (when 290 (|fricas_probe_file| 291 (setq newfn (concatenate 'string dir "/" filename))) 292 (return newfn))) 293 (|probe_name| filename)))) 294 295(defun |make_input_filename|(filearg) 296 (cond 297 ((consp filearg) 298 (|make_input_filename0| (car filearg) (cadr filearg))) 299 (t (|make_input_filename0| filearg nil)))) 300 301(defun |find_file|(filespec filetypelist) 302 (let ((file-name (if (consp filespec) (car filespec) filespec)) 303 (file-type (if (consp filespec) (cadr filespec) nil))) 304 (if file-type (push file-type filetypelist)) 305 (some #'(lambda (ft) (|make_input_filename0| file-name ft)) 306 filetypelist))) 307 308;; ($ERASE filearg) -> 0 if succeeds else 1 309(defun |erase_lib|(filearg) 310 (setq filearg (|make_full_namestring| filearg)) 311 (if (|fricas_probe_file| filearg) 312 #+:fricas_has_remove_directory 313 (|remove_directory| filearg) 314 #-:fricas_has_remove_directory 315 (delete-directory filearg) 316 1)) 317 318#+:GCL 319(defun delete-directory (dirname) 320 (LISP::system (concat "rm -r " dirname))) 321 322#+:sbcl 323(defun delete-directory (dirname) 324 #-:win32 (sb-ext::run-program "/bin/rm" (list "-r" dirname) :search t) 325 #+:win32 (obey (concat "rmdir /q /s " "\"" dirname "\"")) 326 ) 327 328#+:cmu 329(defun delete-directory (dirname) 330 (ext::run-program "rm" (list "-r" dirname)) 331 ) 332 333#+:openmcl 334(defun delete-directory (dirname) 335 (ccl::run-program "rm" (list "-r" dirname))) 336 337#+:clisp 338(defun delete-directory (dirname) 339 #-:win32 340 (obey (concat "rm -r " dirname)) 341 #+:win32 342 (obey (concat "rmdir /q /s " "\"" dirname "\""))) 343 344#+:ecl 345(defun delete-directory (dirname) 346 (ext:system (concat "rm -r " dirname))) 347 348#+:poplog 349(defun delete-directory (dirname) 350 (POP11:sysobey (concat "rm -r " dirname))) 351 352#+:lispworks 353(defun delete-directory (dirname) 354 (system:call-system (concatenate 'string "rm -r " dirname))) 355 356(defun |replace_lib|(filespec2 filespec1) 357 (|erase_lib| (list (setq filespec1 (|make_full_namestring| filespec1)))) 358 #-(or :clisp :openmcl :ecl) 359 (rename-file (|make_full_namestring| filespec2) filespec1) 360 #+(or :clisp :openmcl :ecl) 361 (obey (concat "mv " (|make_full_namestring| filespec2) " " filespec1)) 362 ) 363 364 365(defun |copy_file|(filespec1 filespec2) 366 (let ((name1 (|make_full_namestring| filespec1)) 367 (name2 (|make_full_namestring| filespec2))) 368 (copy-lib-directory name1 name2) 369)) 370 371 372#+:GCL 373(defun copy-lib-directory (name1 name2) 374 (makedir name2) 375 (LISP::system (concat "sh -c 'cp " name1 "/* " name2 "'"))) 376 377#+:sbcl 378(defun copy-lib-directory (name1 name2) 379 (makedir name2) 380 (sb-ext::run-program "/bin/sh" (list "-c" (concat "cp " name1 "/* " name2))) 381 ) 382 383#+:cmu 384(defun copy-lib-directory (name1 name2) 385 (makedir name2) 386 (ext::run-program "sh" (list "-c" (concat "cp " name1 "/* " name2))) 387 ) 388 389#+:openmcl 390(defun copy-lib-directory (name1 name2) 391 (makedir name2) 392 (ccl::run-program "sh" (list "-c" (concat "cp " name1 "/* " name2)))) 393 394#+(or :clisp :ecl) 395(defun copy-lib-directory (name1 name2) 396 (makedir name2) 397 (OBEY (concat "sh -c 'cp " name1 "/* " name2 "'"))) 398 399#+:poplog 400(defun copy-lib-directory (name1 name2) 401 (makedir name2) 402 (POP11:sysobey (concat "cp " name1 "/* " name2))) 403 404#+:lispworks 405(defun copy-lib-directory (name1 name2) 406 (makedir name2) 407 (system:call-system (concat "cp " (concat name1 "/*") " " name2))) 408 409(defvar |$filetype_table| 410 '( 411 (HELPSPAD . |help|) 412 (INPUT . |input|) 413 (SPAD . |spad|) 414 (BOOT . |boot|) 415 (LISP . |lsp|) 416 (OUTPUT . |splog|) 417 (ERRORLIB . |erlib|) 418 (DATABASE . |DAASE|) 419 ) 420) 421 422;;; moved from fname.lisp 423 424;; 425;; Lisp support for cleaned up FileName domain. 426;; 427;; Created: June 20, 1991 (Stephen Watt) 428;; 429 430 431;; E.g. "/" "/u/smwatt" "../src" 432(defun |DirToString| (d) 433 (cond 434 ((equal d '(:root)) "/") 435 ((null d) "") 436 ('t (string-right-trim "/" (namestring (make-pathname :directory d)))) )) 437 438(defun |StringToDir| (s) 439 (cond 440 ((string= s "/") '(:root)) 441 ((string= s "") nil) 442 ('t 443 (let ((lastc (aref s (- (length s) 1)))) 444 (if (char= lastc #\/) 445 (pathname-directory (concat s "name.type")) 446 (pathname-directory (concat s "/name.type")) ))) )) 447 448(defun |myWritable?| (s) 449 (if (not (stringp s)) (|error| "``myWritable?'' requires a string arg.")) 450 (if (string= s "") (setq s ".")) 451 (if (not (|fnameExists?| s)) (setq s (|fnameDirectory| s))) 452 (if (string= s "") (setq s ".")) 453 (if (> (|writeablep| s) 0) 't nil) ) 454 455(defun |fnameMake| (d n e) 456 (if (string= e "") (setq e nil)) 457 (make-pathname :directory (|StringToDir| d) :name n :type e)) 458 459(defun |fnameDirectory| (f) 460 (|DirToString| (pathname-directory f))) 461 462(defun |fnameName| (f) 463 (let ((s (pathname-name f))) 464 (if s s "") )) 465 466(defun |fnameType| (f) 467 (let ((s (pathname-type f))) 468 (if s s "") )) 469 470(defun |fnameExists?| (f) 471 (if (|fricas_probe_file| (namestring f)) 't nil)) 472 473(defun |fnameReadable?| (f) 474 (let ((s 475 #-:GCL 476 (ignore-errors (open f :direction :input :if-does-not-exist nil)) 477 #+:GCL 478 (open f :direction :input :if-does-not-exist nil) 479 )) 480 (cond (s (close s) 't) ('t nil)) ) 481 ) 482 483(defun |fnameWritable?| (f) 484 (|myWritable?| (namestring f)) ) 485 486(defun |fnameNew| (d n e) 487 (if (not (|myWritable?| d)) 488 nil 489 (do ((fn)) 490 (nil) 491 (setq fn (|fnameMake| d (string (gensym n)) e)) 492 (if (not (|fricas_probe_file| (namestring fn))) 493 (return-from |fnameNew| fn)) ))) 494