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