aboutsummaryrefslogtreecommitdiff
path: root/src/interp/nlib.lisp
blob: aa3af3bf9217160514e46a20eb4958fe26817c02 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
;; Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
;; All rights reserved.
;; Copyright (C) 2007-2008, Gabriel Dos Reis.
;; All rights reserved.
;;
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;;
;;     - Redistributions of source code must retain the above copyright
;;       notice, this list of conditions and the following disclaimer.
;;
;;     - Redistributions in binary form must reproduce the above copyright
;;       notice, this list of conditions and the following disclaimer in
;;       the documentation and/or other materials provided with the
;;       distribution.
;;
;;     - Neither the name of The Numerical Algorithms Group Ltd. nor the
;;       names of its contributors may be used to endorse or promote products
;;       derived from this software without specific prior written permission.
;;
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.


(IMPORT-MODULE "macros")
(in-package "BOOT")

;; definition of our stream structure
(defstruct libstream  mode dirname (indextable nil)  (indexstream nil))
;indextable is a list of entries (key class <location or filename>)
;filename is of the form filenumber.lsp or filenumber.o

(defvar optionlist nil "alist which controls compiler output")

(defun addoptions (key value) "adds pairs to optionlist"
  (push (cons key value) optionlist)
  (if (equal key 'FILE)
      (push 
       (cons 'COMPILER-OUTPUT-STREAM
                   (open (concat (libstream-dirname value) "/" "code.lsp")
                         :direction :output :if-exists :supersede))
             optionlist)))

;; (RDEFIOSTREAM ((MODE . IO) (FILE fn ft dir))) IO is I,O,INPUT,OUTPUT
(defun rdefiostream (options &optional (missing-file-error-flag t))
  (let ((mode (cdr (assoc 'mode options)))
        (file (assoc 'file options))
        (stream nil)
        (fullname nil)
        (indextable nil))
        (cond ((equal (elt (string mode) 0) #\I)
               ;;(setq fullname (make-input-filename (cdr file) 'LISPLIB))
               (setq fullname (make-input-filename (cdr file) 'NIL))
               (setq stream (|openIndexFileIfPresent| fullname))
               (if (null stream)
                   (if missing-file-error-flag
                       (ERROR (format nil "Library ~s doesn't exist"
                              ;;(make-filename (cdr file) 'LISPLIB))
                              (make-filename (cdr file) 'NIL)))
                     NIL)
               (make-libstream :mode 'input  :dirname fullname
                               :indextable (get-index-table-from-stream stream)
                               :indexstream stream)))
              ((equal (elt (string mode) 0) #\O)
               ;;(setq fullname (make-full-namestring (cdr file) 'LISPLIB))
               (setq fullname (make-full-namestring (cdr file) 'NIL))
               (case (|directoryp| fullname)
                     (-1 (|checkMkdir| fullname))
                     (0 (error (format nil "~s is an existing file, not a library" fullname)))
                     (otherwise))
	       ;; Make sure parent directory exists.
	       #-:GCL (ensure-directories-exist 
		       (|ensureTrailingSlash| fullname))
               (multiple-value-setq (stream indextable) (get-io-index-stream fullname))
               (make-libstream :mode 'output  :dirname fullname
                               :indextable indextable
                               :indexstream stream ))
              ('t  (ERROR "Unknown MODE")))))


(defun get-index-table-from-stream (stream)
  (let ((pos (read  stream)))
    (cond ((numberp pos)
           (file-position stream pos)
           (read stream))
          (t pos))))

(defun get-io-index-stream (dirname)
  (let* ((index-file (concat dirname "/" |$IndexFilename|))
         (stream (open index-file :direction :io :if-exists :overwrite
                       :if-does-not-exist :create))
         (indextable ())
         (pos (read stream nil nil)))
    (cond ((numberp pos)
           (file-position stream pos)
           (setq indextable (read stream))
           (file-position stream pos))
          (t (file-position stream 0)
             (princ "                    " stream)
             (setq indextable pos)))
    (values stream indextable)))

;substitute indextable in dirname

(defun write-indextable (indextable stream)
  (let ((pos (file-position stream)))
    (write indextable :stream stream :level nil :length nil :escape t)
    (finish-output stream)
    (file-position stream 0)
    (princ pos stream)
    (finish-output stream)))

;;#+:ccl
;;(defun putindextable (indextable dirname)
;;  (with-open-file
;;    (stream (concat dirname "/" |$IndexFilename|)
;;             :direction :io :if-does-not-exist :create)
;;    (file-position stream :end)
;;    (write-indextable indextable stream)))
;;#-:ccl
(defun putindextable (indextable dirname)
  (with-open-file
    (stream (concat dirname "/" |$IndexFilename|)
             :direction :io :if-exists :overwrite
             :if-does-not-exist :create)
    (file-position stream :end)
    (write-indextable indextable stream)))

;; (RREAD key rstream)
(defun rread (key rstream &optional (error-val nil error-val-p))
  (if (equal (libstream-mode rstream) 'output) (error "not input stream"))
  (let* ((entry
         (and (stringp key)
              (assoc key (libstream-indextable rstream) :test #'string=)))
         (file-or-pos (and entry (caddr entry))))
    (cond ((null entry)
           (if error-val-p error-val (error (format nil "key ~a not found" key))))
          ((null (caddr entry)) (cdddr entry))  ;; for small items
          ((numberp file-or-pos)
           (file-position (libstream-indexstream rstream) file-or-pos)
           (read (libstream-indexstream rstream)))
          (t
           (with-open-file
            (stream (concat (libstream-dirname rstream) "/" file-or-pos))
            (read  stream))) )))

(defvar *lib-var*)

;; (RKEYIDS filearg) -- interned version of keys
(defun rkeyids (&rest filearg)
  (mapcar #'intern (mapcar #'car (|getIndexTable|
                                  (make-input-filename filearg 'NIL)))))
;;(defun rkeyids (&rest filearg)
;;  (mapcar #'intern (mapcar #'car (|getIndexTable|
;;                                (make-input-filename filearg 'LISPLIB)))))

;; (RWRITE cvec item rstream)
(defun rwrite (key item rstream)
  (if (equal (libstream-mode rstream) 'input) (error "not output stream"))
  (let ((stream (libstream-indexstream rstream))
        (pos (if item (cons (file-position (libstream-indexstream rstream)) nil)
               (cons nil item))))   ;; for small items
    (make-entry (string key) rstream pos)
    (when (numberp (car pos))
          (write item :stream stream :level nil :length nil
                 :circle t :array t :escape t)
          (terpri stream))))

(defun make-entry (key rstream value-or-pos)
   (let ((entry (assoc key (libstream-indextable rstream) :test #'equal)))
     (if (null entry)
         (push (setq entry (cons key (cons 0 value-or-pos)))
               (libstream-indextable rstream))
       (progn
         (if (stringp (caddr entry)) ($erase (caddr entry)))
         (setf (cddr entry) value-or-pos)))
     entry))

;;(defun rshut (rstream)
;;  (when (and (equal rstream (cdr (assoc 'FILE OPTIONLIST)))
;;             (assoc 'compiler-output-stream optionlist))
;;        (close (cdr (assoc 'compiler-output-stream optionlist)))
;;        (setq optionlist nil))
;;  (if (eq (libstream-mode rstream) 'output)
;;      (write-indextable (libstream-indextable rstream) (libstream-indexstream rstream)))
;;  (close (libstream-indexstream rstream)))
(defun rshut (rstream)
  (when (and (equal rstream (cdr (assoc 'FILE OPTIONLIST)))
             (assoc 'compiler-output-stream optionlist))
        (close (cdr (assoc 'compiler-output-stream optionlist)))
        (setq optionlist (cddr optionlist)))
  (if (eq (libstream-mode rstream) 'output)
      (write-indextable (libstream-indextable rstream) (libstream-indexstream rstream)))
  (close (libstream-indexstream rstream)))

;; filespec is id or list of 1, 2 or 3 ids
;; filearg is filespec or 1, 2 or 3 ids
;; (RPACKFILE filearg)  -- compiles code files and converts to compressed format
(defun rpackfile (filespec)
  (setq filespec (make-filename filespec))
  (if (string= (pathname-type filespec) "NRLIB")
#-:GCL (recompile-lib-file-if-necessary 
         (concat (namestring filespec) "/code.lsp"))

;; When we compile an algebra file we create an NRLIB directory which contains
;; several files. One of the files is named [[code.lsp]]. 
;; On certain platforms this causes linking problems for GCL. 
;; The problem is that the compiler produces an init code block which is
;; sensitive to the name of the source file.
;; Since all of the [[code.lsp]] files have the same name all of
;; the init blocks have the same name. At link time this causes
;; the names to collide. Here we rename the file before we compile,
;; do the compile, and then rename the result back to [[code.o]].
;; This code used to read:
;; but has been changed to read:
#+:GCL (let* ((base (pathname-name filespec))
             (code (concatenate 'string (namestring filespec) "/code.lsp"))
             (temp (concatenate 'string (namestring filespec) "/" base ".lsp"))
             (o (make-pathname :type "o")))
        (si::system (format nil "cp ~S ~S" code temp))
        (recompile-lib-file-if-necessary temp)
        (|renameFile|
           (namestring (merge-pathnames o temp))
           (namestring (merge-pathnames o code))))
  ;; only pack non libraries to avoid lucid file handling problems    
    (let* ((rstream (rdefiostream (list (cons 'file filespec) (cons 'mode 'input))))
           (nstream nil)
           (nindextable nil)
           (nrstream nil)
           (index-file-name (concat (truename filespec) "/" |$IndexFilename|))
           (temp-index-file-name (make-pathname :name "oldindex"
                                                :defaults index-file-name)))
      (rename-file index-file-name temp-index-file-name ) ;; stays until closed
      (multiple-value-setq (nstream nindextable) (get-io-index-stream filespec))
      (setq nrstream (make-libstream :mode 'output  :dirname filespec
                                     :indextable nindextable
                                     :indexstream nstream ))
      (dolist (entry (libstream-indextable rstream))
              (rwrite (car entry) (rread (car entry) rstream) nrstream)
              (if (stringp (caddr entry))
                  (delete-file (concat filespec "/" (caddr entry)))))
      (close (libstream-indexstream rstream))
      (delete-file temp-index-file-name)
      (rshut nrstream)))
  filespec)

(defun recompile-lib-file-if-necessary (lfile)
   (let* ((bfile (make-pathname :type |$faslType| :defaults lfile))
          (bdate (and (probe-file bfile) (file-write-date bfile)))
          (ldate (and (probe-file lfile) (file-write-date lfile))))
     (if ldate
         (if (and bdate (> bdate ldate)) nil
           (progn (compile-lib-file lfile) (list bfile))))))

#+:CCL
(defun recompile-lib-file-if-necessary (lfile)
 (let ( (mname (pathname-name (file-namestring (directory-namestring lfile))))
        (mdate (modulep mname))
        (ldate (filedate lfile)) )
        (if (or (not mdate) (datelessp mdate ldate)) 
          (seq
            (if (null output-library)
                (|openOutputLibrary|
                  (setq |$outputLibraryName|
                   (if (null |$outputLibraryName|)
                       (make-pathname :directory (get-current-directory)
                                      :name "user.lib")
                        (if (filep |$outputLibraryName|)
                            (truename |$outputLibraryName|)
                            |$outputLibraryName|)))))
            (compile-file lfile 
                          :output-file (intern (pathname-name
                                               (directory-namestring lfile))))))))


#+:AKCL
(defun spad-fixed-arg (fname )
   (and (equal (symbol-package fname) (find-package "BOOT"))
        (not (get fname 'compiler::spad-var-arg))
        (search ";" (symbol-name fname))
        (or (get fname 'compiler::fixed-args)
            (setf (get fname 'compiler::fixed-args) t)))
   nil)

#+:AKCL
(defun compile-lib-file (fn &rest opts)
  (unwind-protect
      (progn
        (trace (compiler::fast-link-proclaimed-type-p
                :exitcond nil
                :entrycond (spad-fixed-arg (car system::arglist))))
        (trace (compiler::t1defun :exitcond nil
                :entrycond (spad-fixed-arg (caar system::arglist))))
        (apply #'compile-file fn opts))
    (untrace compiler::fast-link-proclaimed-type-p compiler::t1defun)))
#-:GCL
(define-function 'compile-lib-file #'compile-file)

;; (RDROPITEMS filearg keys) don't delete, used in files.spad
(defun rdropitems (filearg keys &aux (ctable (|getIndexTable| filearg)))
  (mapc #'(lambda(x)
           (setq ctable (delete x ctable :key #'car :test #'equal)) )
           (mapcar #'string keys))
  (putindextable ctable filearg))

;; cms file operations
(defun make-filename (filearg &optional (filetype nil))
  (let ((filetype (if (symbolp filetype) 
                      (symbol-name filetype)
                      filetype)))
    (cond
     ((pathnamep filearg) 
      (cond ((pathname-type filearg) (namestring filearg))
            (t (namestring (make-pathname :directory (pathname-directory filearg)
                                          :name (pathname-name filearg)
                                          :type filetype)))))
     ;; Previously, given a filename containing "." and
     ;; an extension this function would return filearg. MCD 23-8-95.
     ((and (stringp filearg) (pathname-type filearg) (null filetype)) filearg)
     ;;  ((and (stringp filearg)
     ;;    (or (pathname-type filearg) (null filetype)))
     ;;     filearg)
     ((and (stringp filearg) (stringp filetype)
           (pathname-type filearg) 
           (string-equal (pathname-type filearg) filetype))
      filearg)
     ((consp filearg)
      (make-filename (car filearg) (or (cadr filearg) filetype)))
     (t (if (stringp filetype) (setq filetype (intern filetype "BOOT")))
        (let ((ft (or (cdr (assoc filetype $filetype-table)) filetype)))
          (if ft 
              (concatenate 'string (string filearg) "." (string ft))
              (string filearg)))))))

(defun make-full-namestring (filearg &optional (filetype nil))
  (namestring (merge-pathnames (make-filename filearg filetype))))

(defun probe-name (file)
  (if (probe-file file) (namestring file) nil))

(defun get-directory-list (ft)
  (let ((cd (get-current-directory)))
    (cond ((member ft '("NRLIB" "DAASE" "EXPOSED") :test #'string=)
           (if (eq |$UserLevel| '|development|)
               (cons cd $library-directory-list)
	     $library-directory-list))
	  (t (adjoin cd 
		     (adjoin (namestring (user-homedir-pathname)) 
			     $directory-list 
			     :test #'string=) 
		     :test #'string=)))))

(defun make-input-filename (filearg &optional (filetype nil))
   (let*
     ((filename  (make-filename filearg filetype))
      (dirname (pathname-directory filename))
      (ft (pathname-type filename))
      (dirs (get-directory-list ft))
      (newfn nil))   
    (if (or (null dirname) (eqcar dirname :relative))
        (dolist (dir dirs (probe-name filename))
                (when 
                 (probe-file 
                  (setq newfn (concatenate 'string dir filename)))
                 (return newfn)))
      (probe-name filename))))

(defun $FILEP (&rest filearg) (make-full-namestring filearg))
(define-function '$OUTFILEP #'$FILEP) ;;temporary bogus def

(defun $findfile (filespec filetypelist)
  (let ((file-name (if (consp filespec) (car filespec) filespec))
        (file-type (if (consp filespec) (cadr filespec) nil)))
    (if file-type (push file-type filetypelist))
    (some #'(lambda (ft) (make-input-filename file-name ft))
          filetypelist)))

;;(defun move-file (namestring1 namestring2)
;;  (rename-file namestring1 namestring2))

(defun $FCOPY (filespec1 filespec2)
    (let ((name1 (make-full-namestring filespec1))
          (name2 (make-full-namestring filespec2)))
      (if (library-file name1)
        (copy-lib-directory name1 name2)
        (copy-file name1 name2))))


#+(OR :AKCL (AND :CCL :UNIX))
(defun copy-lib-directory (name1 name2)
   (|checkMkdir| name2)
   (system (concat "sh -c 'cp " name1 "/* " name2 "'")))

#+(OR :AKCL (AND :CCL :UNIX))
(defun copy-file (namestring1 namestring2)
  (system (concat "cp " namestring1 " " namestring2)))