Newer
Older
;;; -*- Log: code.log; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/load.lisp,v 1.36 1992/02/13 16:01:24 ram Exp $")
;;; **********************************************************************
;;;
;;; Loader for Spice Lisp.
;;; Written by Skef Wholey and Rob MacLachlan.
;;;
(in-package "LISP")
(export '(load *load-verbose* *load-print* *load-truename* *load-pathname*))
(export '(*load-if-source-newer* *load-source-types* *load-object-types*))
(in-package "SYSTEM")
(export 'foreign-symbol-address)
;;;; Variables:
;;; Public:
(defvar *load-if-source-newer* :load-object
"The default for the :IF-SOURCE-NEWER argument to load."))
(declaim (type (member :load-object :load-source :query :compile)
*load-if-source-newer*))
(defvar *load-source-types* '("lisp" "l" "cl" "lsp" nil)
"The source file types which LOAD recognizes.")
(defvar *load-object-types*
'(#.(c:backend-fasl-file-type c:*backend*) "fasl")
"A list of the object file types recognized by LOAD.")
(declaim (list *load-source-types* *load-object-types*))
"The default for the :VERBOSE argument to Load.")
(defvar *load-print* ()
"The default for the :PRINT argument to Load.")
(defvar *load-truename* nil
"The TRUENAME of the file that LOAD is currently loading.")
(defvar *load-pathname* nil
"The defaulted pathname that LOAD is currently loading.")
(declaim (type (or pathname null) *load-truename* *load-pathname*))
;;; Internal state variables:
(defvar *load-depth* 0
"Count of the number of recursive loads.")
(defvar *fasl-file* ()
"The fasl file we're reading from.")
(defvar *current-code-format*
"The code format that we think we are loading.")
;;; LOAD-FRESH-LINE -- internal.
;;;
;;; Output the corrent number of semicolons after a fresh-line.
;;;
(defconstant semicolons ";;;;;;;;;;;;;;;;")
;;;
(defun load-fresh-line ()
(fresh-line)
(do ((count *load-depth* (- count (length semicolons))))
((< count (length semicolons))
(unless (zerop count)
(write-string semicolons *standard-output* :end count)))
(write-string semicolons))
(write-char #\space))
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
;;;; The Fop-Table:
;;;
;;; The table is implemented as a simple-vector indexed by the table
;;; offset. We may need to have several, since load can be called recursively.
(defvar *free-fop-tables* (list (make-array 1000))
"List of free fop tables for the fasloader.")
(defvar *current-fop-table* ()
"The current fop table.")
(defvar *current-fop-table-size* ()
"The length of the current fop table.")
(defvar *current-fop-table-index* ()
"Index in the fop-table of the next entry to be used.")
(defun grow-fop-table ()
(let* ((new-size (* *current-fop-table-size* 2))
(new-table (make-array new-size)))
(declare (fixnum new-size) (simple-vector new-table))
(replace new-table (the simple-vector *current-fop-table*))
(setq *current-fop-table* new-table)
(setq *current-fop-table-size* new-size)))
(defmacro push-table (thing)
(let ((n-index (gensym)))
`(let ((,n-index *current-fop-table-index*))
(declare (fixnum ,n-index))
(when (= ,n-index (the fixnum *current-fop-table-size*))
(grow-fop-table))
(setq *current-fop-table-index* (1+ ,n-index))
(setf (svref *current-fop-table* ,n-index) ,thing))))
;;;; The Fop-Stack:
;;;
;;; The is also in a simple-vector, but it grows down, since it is somewhat
;;; cheaper to test for overflow that way.
;;;
(defvar *fop-stack* (make-array 100)
"The fop stack (we only need one!).")
(defvar *fop-stack-pointer* 100
"The index of the most recently pushed item on the fop-stack.")
(defvar *fop-stack-pointer-on-entry* ()
"The current index into the fop stack when we last recursively entered LOAD.")
(defun grow-fop-stack ()
(let* ((size (length (the simple-vector *fop-stack*)))
(new-size (* size 2))
(new-stack (make-array new-size)))
(declare (fixnum size new-size) (simple-vector new-stack))
(replace new-stack (the simple-vector *fop-stack*) :start1 size)
(incf *fop-stack-pointer-on-entry* size)
(setq *fop-stack-pointer* size)
(setq *fop-stack* new-stack)))
;;; With-Fop-Stack -- Internal
;;;
;;; Cache information about the fop-stack in local variables. Define
;;; a local macro to pop from the stack. Push the result of evaluation if
;;; specified.
;;;
(defmacro with-fop-stack (pushp &body forms)
(let ((n-stack (gensym))
(n-index (gensym))
(n-res (gensym)))
`(let ((,n-stack *fop-stack*)
(,n-index *fop-stack-pointer*))
(declare (simple-vector ,n-stack) (fixnum ,n-index))
(macrolet ((pop-stack ()
`(prog1
(svref ,',n-stack ,',n-index)
(setq ,',n-index (1+ ,',n-index))))
(call-with-popped-things (fun n)
(let ((n-start (gensym)))
`(let ((,n-start (+ ,',n-index ,n)))
(setq ,',n-index ,n-start)
(,fun ,@(make-list n :initial-element
`(svref ,',n-stack
(decf ,n-start))))))))
,(if pushp
`(let ((,n-res (progn ,@forms)))
(when (zerop ,n-index)
(grow-fop-stack)
(setq ,n-index *fop-stack-pointer*
,n-stack *fop-stack*))
(decf ,n-index)
(setq *fop-stack-pointer* ,n-index)
(setf (svref ,n-stack ,n-index) ,n-res))
`(prog1
(progn ,@forms)
(setq *fop-stack-pointer* ,n-index)))))))
;;; FOP database:
(defvar fop-codes (make-array 256)
"Vector indexed by a FaslOP that yields the FOP's name.")
(defvar fop-functions
(make-array 256 :initial-element #'(lambda () (error "Losing FOP!")))
"Vector indexed by a FaslOP that yields a function of 0 arguments which
will perform the operation.")
;;; Define-FOP -- Internal
;;;
;;; Defines Name as a fasl operation, with op-code op. If pushp is :nope,
;;; the the body neither pushes or pops the fop stack. If it is nil, then
;;; the body may pop, but the result is ignored. If it is true, the the result
;;; is pushed on the stack.
;;;
(defmacro define-fop ((name op &optional (pushp t)) &rest forms)
`(progn
(defun ,name ()
,(if (eq pushp :nope)
`(progn ,@forms)
`(with-fop-stack ,pushp ,@forms)))
(setf (svref fop-codes ,op) ',name)
(setf (get ',name 'fop-code) ,op)
(setf (svref fop-functions ,op) #',name)))
;;; Clone-Fop -- Internal
;;;
;;; Defines a pair of fops which are identical except in that one reads
;;; a four byte argument and the other reads a one byte argument. The
;;; argument can be accessed by using the Clone-Arg macro.
;;;
(defmacro clone-fop ((name op &optional (pushp t))
(small-name small-op) &rest forms)
`(progn
(macrolet ((clone-arg () '(read-arg 4)))
(define-fop (,name ,op ,pushp) ,@forms))
(macrolet ((clone-arg () '(read-arg 1)))
(define-fop (,small-name ,small-op ,pushp) ,@forms))))
;;;; Utilities for reading from the fasl file.
(proclaim '(inline read-byte))
;;; Fast-Read-U-Integer -- Internal
;;;
;;; Expands into code to read an N-byte unsigned integer using
;;; fast-read-byte.
;;;
(defmacro fast-read-u-integer (n)
(do ((res '(fast-read-byte)
`(logior (fast-read-byte)
(ash ,res 8)))
(cnt 1 (1+ cnt)))
((>= cnt n) res)))
;;; Fast-Read-Variable-U-Integer -- Internal
;;;
;;; Like Fast-Read-U-Integer, but the size may be determined at run time.
;;;
(defmacro fast-read-variable-u-integer (n)
(let ((n-pos (gensym))
(n-res (gensym))
(n-cnt (gensym)))
`(do ((,n-pos 8 (+ ,n-pos 8))
(,n-cnt (1- ,n) (1- ,n-cnt))
(,n-res
(fast-read-byte)
(dpb (fast-read-byte) (byte 8 ,n-pos) ,n-res)))
((zerop ,n-cnt) ,n-res))))
;;; Fast-Read-S-Integer -- Internal
;;;
;;; Read a signed integer.
;;;
(defmacro fast-read-s-integer (n)
(let ((n-last (gensym)))
(do ((res `(let ((,n-last (fast-read-byte)))
(if (zerop (logand ,n-last #x80))
,n-last
(logior ,n-last #x-100)))
`(logior (fast-read-byte)
(ash ,res 8)))
(cnt 1 (1+ cnt)))
((>= cnt n) res))))
;;; Read-Arg -- Internal
;;;
;;; Read an N-byte unsigned integer from the *fasl-file*
;;;
(defmacro read-arg (n)
(if (= n 1)
`(read-byte *fasl-file*)
`(prepare-for-fast-read-byte *fasl-file*
(prog1
(fast-read-u-integer ,n)
(done-with-fast-read-byte)))))
;;; Fasload:
(defun do-load-verbose (stream)
(when *load-verbose*
(load-fresh-line)
(let ((name (file-name stream)))
(if name
(format t "Loading ~S.~%" name)
(format t "Loading stuff from ~S.~%" stream)))))
(when (zerop (file-length stream))
(error "Attempt to load an empty FASL FILE:~% ~S" (namestring stream)))
(do-load-verbose stream)
(let* ((*fasl-file* stream)
(*current-fop-table* (pop *free-fop-tables*))
(*current-fop-table-size* ())
(*fop-stack-pointer-on-entry* *fop-stack-pointer*))
(if (null *current-fop-table*)
(setq *current-fop-table* (make-array 1000)))
(setq *current-fop-table-size*
(length (the simple-vector *current-fop-table*)))
(unwind-protect
(do ((loaded-group (load-group stream) (load-group stream)))
((not loaded-group)))
(setq *fop-stack-pointer* *fop-stack-pointer-on-entry*)
(push *current-fop-table* *free-fop-tables*)
;; Nil out the stack and table, so we don't hold onto garbage.
(dotimes (i *fop-stack-pointer-on-entry*)
(declare (fixnum i))
(setf (svref *fop-stack* i) nil))
(let ((tab *current-fop-table*))
(dotimes (i (length tab))
(declare (fixnum i))
(setf (svref tab i) nil)))))
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
t)
#|
(defvar *fop-counts* (make-array 256 :initial-element 0))
(defvar *fop-times* (make-array 256 :initial-element 0))
(defvar *print-fops* nil)
(defun clear-counts ()
(fill (the simple-vector *fop-counts*) 0)
(fill (the simple-vector *fop-times*) 0)
t)
(defun analyze-counts ()
(let ((counts ())
(total-count 0)
(times ())
(total-time 0))
(macrolet ((breakdown (lvar tvar vec)
`(progn
(dotimes (i 255)
(declare (fixnum i))
(let ((n (svref ,vec i)))
(push (cons (svref fop-codes i) n) ,lvar)
(incf ,tvar n)))
(setq ,lvar (subseq (sort ,lvar #'(lambda (x y)
(> (cdr x) (cdr y))))
0 10)))))
(breakdown counts total-count *fop-counts*)
(breakdown times total-time *fop-times*)
(format t "Total fop count is ~D~%" total-count)
(dolist (c counts)
(format t "~30S: ~4D~%" (car c) (cdr c)))
(format t "~%Total fop time is ~D~%" (/ (float total-time) 60.0))
(dolist (m times)
(format t "~30S: ~6,2F~%" (car m) (/ (float (cdr m)) 60.0))))))
|#
;;; Load-Group -- Internal
;;;
;;; Load-Group returns t if it successfully loads a group from the file,
;;; or () if EOF was encountered while trying to read from the file.
;;; Dispatch to the right function for each fop. Special-case fop-byte-push
;;; since it is real common.
;;;
(defun load-group (file)
(when (check-header file)
(catch 'group-end
(let ((*current-code-format* nil)
(*current-fop-table-index* 0))
(let ((byte (read-byte file)))
(if (eql byte 3)
(let ((index *fop-stack-pointer*))
(when (zerop index)
(grow-fop-stack)
(setq index *fop-stack-pointer*))
(decf index)
(setq *fop-stack-pointer* index)
(setf (svref *fop-stack* index)
(svref *current-fop-table* (read-byte file))))
(funcall (svref fop-functions byte)))))))))
;;; Check-Header returns t if t succesfully read a header from the file,
;;; or () if EOF was hit before anything was read. An error is signaled
;;; if garbage is encountered.
(defun check-header (file)
(let ((byte (read-byte file NIL '*eof*)))
(cond ((eq byte '*eof*) ())
(do ((byte (read-byte file) (read-byte file))
(count 1 (1+ count)))
((= byte 255) t)
(declare (fixnum byte))
(if (and (< count 9)
(not (eql byte (char-code (schar "FASL FILE" count)))))
(error "Bad FASL file format."))))
(t (error "Bad FASL file format.")))))
;;; Load-S-Integer loads a signed integer Length bytes long from the File.
(defun load-s-integer (length)
(declare (fixnum length))
(do* ((index length (1- index))
(byte 0 (read-byte *fasl-file*))
(result 0 (+ result (ash byte bits)))
(bits 0 (+ bits 8)))
((= index 0)
(if (logbitp 7 byte) ; look at sign bit
(- result (ash 1 bits))
result))
(declare (fixnum index byte bits))))
;;; Sloload:
;;; Something not EQ to anything read from a file:
(defconstant load-eof-value '(()))
;;; Sloload loads a text file into the given Load-Package.
(defun sloload (stream)
(do-load-verbose stream)
(do ((sexpr (read stream nil load-eof-value)
(read stream nil load-eof-value)))
((eq sexpr load-eof-value))
(if *load-print*
(let ((results (multiple-value-list (eval sexpr))))
(load-fresh-line)
(format t "~{~S~^, ~}~%" results))
(eval sexpr)))
t)
;;; LOAD -- Public
;;;
;;; This function mainly sets up special bindings and then calls
;;; sub-functions. We conditionally bind the switches with PROGV so that
;;; people can set them in their init files and have the values take effect.
;;; If the compiler is loaded, we make the compiler-policy local to LOAD by
;;; binding it to itself.
;;;
(defun load (filename &key (verbose nil verbose-p) (print nil print-p)
(if-source-newer nil if-source-newer-p)
(if-does-not-exist :error) contents)
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
"Loads the file named by Filename into the Lisp environment. The file type
(a.k.a extension) is defaulted if missing. These options are defined:
:IF-SOURCE-NEWER <keyword>
If the file type is not specified, and both source and object files
exist, then this argument controls which is loaded:
:LOAD-OBJECT - load object file (default),
:LOAD-SOURCE - load the source file,
:COMPILE - compile the source and then load the object file, or
:QUERY - ask the user which to load.
:IF-DOES-NOT-EXIST {:ERROR | NIL}
If :ERROR (the default), signal an error if the file can't be located.
If NIL, simply return NIL (LOAD normally returns T.)
:VERBOSE {T | NIL}
If true, print a line describing each file loaded.
:PRINT {T | NIL}
If true, print information about loaded values. When loading the
source, the result of evaluating each top-level form is printed.
:CONTENTS {NIL | :SOURCE | :BINARY}
Forces the input to be interpreted as a source or object file, instead
of guessing based on the file type. Probably only necessary if you have
source files with a \"fasl\" type.
The variables *LOAD-VERBOSE*, *LOAD-PRINT* and EXT:*LOAD-IF-SOURCE-NEWER*
determine the defaults for the corresponding keyword arguments. These
variables are also bound to the specified argument values, so specifying a
keyword affects nested loads. The variables EXT:*LOAD-SOURCE-TYPES* and
EXT:*LOAD-OBJECT-TYPES* determine the file types that we use for defaulting
when none is specified."
(declare (type (or null (member :source :binary)) contents))
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
(collect ((vars)
(vals))
(macrolet ((frob (wot)
`(when ,(concat-pnames wot '-p)
(vars ',(intern (format nil "*LOAD-~A*" wot)))
(vals ,wot))))
(frob if-source-newer)
(frob verbose)
(frob print))
(when (boundp 'c::*default-cookie*)
(vars 'c::*default-cookie* 'c::*default-interface-cookie*)
(vals c::*default-cookie* c::*default-interface-cookie*))
(progv (vars) (vals)
(let ((*package* *package*)
(*readtable* *readtable*)
(*load-depth* (1+ *load-depth*)))
(values
(with-simple-restart (continue "Return NIL from load of ~S." filename)
(if (streamp filename)
(if (or (eq contents :binary)
(and (null contents)
(equal (stream-element-type filename)
'(unsigned-byte 8))))
(fasload filename)
(sloload filename))
(let ((pn (merge-pathnames (pathname filename)
*default-pathname-defaults*)))
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
(cond ((wild-pathname-p pn)
(dolist (file (directory pn) t)
(internal-load pn file if-does-not-exist contents)))
((pathname-type pn)
(internal-load pn (probe-file pn) if-does-not-exist
contents))
(t
(internal-load-default-type
pn if-does-not-exist)))))))))))
;;; INTERNAL-LOAD -- Internal
;;;
;;; Load the stuff in a file when we have got the name.
;;;
(defun internal-load (pathname truename if-does-not-exist contents)
(unless truename
(return-from
internal-load
(ecase if-does-not-exist
(:error
(restart-case (error "~S does not exist." (namestring pathname))
(check-again () :report "See if it exists now."
(load pathname))
(use-value () :report "Prompt for a new name."
(write-string "New name: " *query-io*)
(force-output *query-io*)
(load (read-line *query-io*)))))
((nil) nil))))
(let ((*load-truename* truename)
(*load-pathname* pathname))
(case contents
(:source
(with-open-file (file pathname
:direction :input
:if-does-not-exist if-does-not-exist)
(sloload file)))
(:binary
(with-open-file (file pathname
:direction :input
:if-does-not-exist if-does-not-exist
:element-type '(unsigned-byte 8))
(fasload file)))
(t
(let ((first-line (with-open-file (file truename :direction :input)
(read-line file nil))))
(cond
((and first-line
(>= (length first-line) 9)
(string= first-line "FASL FILE" :end1 9))
(internal-load pathname truename if-does-not-exist :binary))
(t
(when (member (pathname-type truename) *load-object-types*
:test #'string=)
(cerror
"Load it as a source file."
"File has a fasl file type, but no fasl file header:~% ~S"
(namestring truename)))
(internal-load pathname truename if-does-not-exist :source))))))))
;;; TRY-DEFAULT-TYPES -- Internal
;;;
(defun try-default-types (pathname types)
(dolist (type types (values nil nil))
(let* ((pn (make-pathname :type type :defaults pathname))
(tn (probe-file pn)))
(when tn (return (values pn tn))))))
;;; INTERNAL-LOAD-DEFAULT-TYPE -- Internal
;;;
;;; Handle the case of INTERNAL-LOAD where the file does not exist.
;;;
(defun internal-load-default-type (pathname if-does-not-exist)
(multiple-value-bind
(src-pn src-tn)
(try-default-types pathname *load-source-types*)
(multiple-value-bind
(obj-pn obj-tn)
(try-default-types pathname *load-object-types*)
(cond
((and obj-tn src-tn
(> (file-write-date src-tn) (file-write-date obj-tn)))
(ecase *load-if-source-newer*
(:load-object
(warn "Loading object file ~A,~@
which is older than the presumed source:~% ~A."
(namestring obj-tn) (namestring src-tn))
(internal-load obj-pn obj-tn if-does-not-exist :binary))
(:load-source
(warn "Loading source file ~A,~@
which is newer than the presumed object file:~% ~A."
(namestring src-tn) (namestring obj-tn))
(internal-load src-pn src-tn if-does-not-exist :source))
(:compile
(let ((obj-tn (compile-file src-pn)))
(unless obj-tn
(error "Compile of source failed, cannot load object."))
(internal-load src-pn obj-tn :error :binary)))
(:query
(restart-case
(error "Object file ~A is~@
older than the presumed source:~% ~A."
(namestring obj-tn) (namestring src-tn))
(continue () :report "load source file"
(internal-load src-pn src-tn if-does-not-exist :source))
(load-object () :report "load object file"
(internal-load src-pn obj-tn if-does-not-exist :binary))))))
(obj-tn
(internal-load obj-pn obj-tn if-does-not-exist :binary))
(src-pn
(internal-load src-pn src-tn if-does-not-exist :source))
(internal-load pathname nil if-does-not-exist nil))))))
;;;; Actual FOP definitions:
(define-fop (fop-nop 0 :nope))
(define-fop (fop-pop 1 nil) (push-table (pop-stack)))
(define-fop (fop-pop-for-effect 65 nil) (pop-stack))
(define-fop (fop-push 2) (svref *current-fop-table* (read-arg 4)))
(define-fop (fop-byte-push 3) (svref *current-fop-table* (read-arg 1)))
(define-fop (fop-empty-list 4) ())
(define-fop (fop-truth 5) t)
(define-fop (fop-misc-trap 66)
(%primitive make-other-immediate-type 0 vm:unbound-marker-type))
(define-fop (fop-short-character 69)
(code-char (read-arg 1)))
(clone-fop (fop-struct 48)
(fop-small-struct 49)
(let* ((size (clone-arg))
(res (make-structure size)))
(declare (type index size))
(do ((n (1- size) (1- n)))
((minusp n))
(declare (type (integer -1 #.most-positive-fixnum) n))
(setf (structure-ref res n) (pop-stack)))
res))
(define-fop (fop-end-group 64 :nope) (throw 'group-end t))
(define-fop (fop-end-header 255)
(error "Fop-End-Header was executed???"))
;;; In the normal loader, we just ignore these. Genesis overwrites
;;; fop-maybe-cold-load with something that knows when to revert to
;;; cold-loading or not.
;;;
(define-fop (fop-maybe-cold-load 82 :nope))
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
(define-fop (fop-verify-table-size 62 :nope)
(if (/= *current-fop-table-index* (read-arg 4))
(error "Fasl table of improper size. Bug!")))
(define-fop (fop-verify-empty-stack 63 :nope)
(if (/= *fop-stack-pointer* *fop-stack-pointer-on-entry*)
(error "Fasl stack not empty. Bug!")))
;;;; Loading symbols:
(defvar *load-symbol-buffer* (make-string 100))
(defvar *load-symbol-buffer-size* 100)
(macrolet ((frob (name code name-size package)
(let ((n-package (gensym))
(n-size (gensym))
(n-buffer (gensym)))
`(define-fop (,name ,code)
(prepare-for-fast-read-byte *fasl-file*
(let ((,n-package ,package)
(,n-size (fast-read-u-integer ,name-size)))
(when (> ,n-size *load-symbol-buffer-size*)
(setq *load-symbol-buffer*
(make-string (setq *load-symbol-buffer-size*
(* ,n-size 2)))))
(done-with-fast-read-byte)
(let ((,n-buffer *load-symbol-buffer*))
(read-n-bytes *fasl-file* ,n-buffer 0 ,n-size)
(push-table (intern* ,n-buffer ,n-size ,n-package)))))))))
(frob fop-symbol-save 6 4 *package*)
(frob fop-small-symbol-save 7 1 *package*)
(frob fop-lisp-symbol-save 75 4 *lisp-package*)
(frob fop-lisp-small-symbol-save 76 1 *lisp-package*)
(frob fop-keyword-symbol-save 77 4 *keyword-package*)
(frob fop-keyword-small-symbol-save 78 1 *keyword-package*)
(frob fop-symbol-in-package-save 8 4
(svref *current-fop-table* (fast-read-u-integer 4)))
(frob fop-small-symbol-in-package-save 9 1
(svref *current-fop-table* (fast-read-u-integer 4)))
(frob fop-symbol-in-byte-package-save 10 4
(svref *current-fop-table* (fast-read-u-integer 1)))
(frob fop-small-symbol-in-byte-package-save 11 1
(svref *current-fop-table* (fast-read-u-integer 1))))
(clone-fop (fop-uninterned-symbol-save 12)
(fop-uninterned-small-symbol-save 13)
(let* ((arg (clone-arg))
(res (make-string arg)))
(read-n-bytes *fasl-file* res 0 arg)
(push-table (make-symbol res))))
(define-fop (fop-package 14)
(let ((name (pop-stack)))
(or (find-package name)
(error "The package ~S does not exist." name))))
;;;; Loading numbers:
(clone-fop (fop-integer 33)
(fop-small-integer 34)
(load-s-integer (clone-arg)))
(define-fop (fop-word-integer 35)
(prepare-for-fast-read-byte *fasl-file*
(prog1
(fast-read-s-integer 4)
(done-with-fast-read-byte))))
(define-fop (fop-byte-integer 36)
(prepare-for-fast-read-byte *fasl-file*
(prog1
(fast-read-s-integer 1)
(done-with-fast-read-byte))))
(define-fop (fop-ratio 70)
(let ((den (pop-stack)))
(%make-ratio (pop-stack) den)))
(%make-complex (pop-stack) im)))
(define-fop (fop-single-float 46)
(make-single-float (load-s-integer 4)))
(define-fop (fop-double-float 47)
(let ((lo (ldb (byte 32 0) (load-s-integer 4))))
(make-double-float (load-s-integer 4) lo)))
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
;;;; Loading lists:
(define-fop (fop-list 15)
(do ((res () (cons (pop-stack) res))
(n (read-arg 1) (1- n)))
((zerop n) res)))
(define-fop (fop-list* 16)
(do ((res (pop-stack) (cons (pop-stack) res))
(n (read-arg 1) (1- n)))
((zerop n) res)))
(macrolet ((frob (name op fun n)
`(define-fop (,name ,op)
(call-with-popped-things ,fun ,n))))
(frob fop-list-1 17 list 1)
(frob fop-list-2 18 list 2)
(frob fop-list-3 19 list 3)
(frob fop-list-4 20 list 4)
(frob fop-list-5 21 list 5)
(frob fop-list-6 22 list 6)
(frob fop-list-7 23 list 7)
(frob fop-list-8 24 list 8)
(frob fop-list*-1 25 list* 2)
(frob fop-list*-2 26 list* 3)
(frob fop-list*-3 27 list* 4)
(frob fop-list*-4 28 list* 5)
(frob fop-list*-5 29 list* 6)
(frob fop-list*-6 30 list* 7)
(frob fop-list*-7 31 list* 8)
(frob fop-list*-8 32 list* 9))
;;;; Loading arrays:
;;;
(clone-fop (fop-string 37)
(fop-small-string 38)
(let* ((arg (clone-arg))
(res (make-string arg)))
(read-n-bytes *fasl-file* res 0 arg)
res))
(clone-fop (fop-vector 39)
(fop-small-vector 40)
(let* ((size (clone-arg))
(res (make-array size)))
(declare (fixnum size))
(do ((n (1- size) (1- n)))
((minusp n))
(setf (svref res n) (pop-stack)))
res))
(clone-fop (fop-uniform-vector 41)
(fop-small-uniform-vector 42)
(make-array (clone-arg) :initial-element (pop-stack)))
(define-fop (fop-array 83)
(let* ((rank (read-arg 4))
(vec (pop-stack))
(length (length vec))
(res (make-array-header vm:simple-array-type rank)))
(declare (simple-array vec)
(type (unsigned-byte 24) rank))
(define-fop (fop-single-float-vector 84)
(let* ((length (read-arg 4))
(result (make-array length :element-type 'single-float)))
(read-n-bytes *fasl-file* result 0 (* length vm:word-bytes))
result))
(define-fop (fop-double-float-vector 85)
(let* ((length (read-arg 4))
(result (make-array length :element-type 'double-float)))
(read-n-bytes *fasl-file* result 0 (* length vm:word-bytes 2))
result))
;;; FOP-INT-VECTOR -- Internal
;;;
;;; *** NOT *** the FOP-INT-VECTOR as currently documented in rtguts. Size
;;; must be a directly supported I-vector element size, with no extra bits.
;;; This must be packed according to the local byte-ordering, allowing us to
;;; directly read the bits.
;;;
(define-fop (fop-int-vector 43)
(prepare-for-fast-read-byte *fasl-file*
(let* ((len (fast-read-u-integer 4))
(size (fast-read-byte))
(res (case size
(1 (make-array len :element-type 'bit))
(2 (make-array len :element-type '(unsigned-byte 2)))
(4 (make-array len :element-type '(unsigned-byte 4)))
(8 (make-array len :element-type '(unsigned-byte 8)))
(16 (make-array len :element-type '(unsigned-byte 16)))
(32 (make-array len :element-type '(unsigned-byte 32)))
(t (error "Losing i-vector element size: ~S" size)))))
(declare (type index len))
(done-with-fast-read-byte)
(read-n-bytes *fasl-file* res 0 (ceiling (* size len) vm:byte-bits))
res)))
(define-fop (fop-uniform-int-vector 44)
(prepare-for-fast-read-byte *fasl-file*
(let* ((n (fast-read-u-integer 4))
(size (fast-read-byte))
(value (fast-read-variable-u-integer (ceiling size 8))))
(done-with-fast-read-byte)
(make-array n :element-type `(unsigned-byte ,size)
:initial-element value))))
(define-fop (fop-eval 53)
(let ((result (eval (pop-stack))))
(when *load-print*
(load-fresh-line)
(prin1 result)
(terpri))
result))
(define-fop (fop-eval-for-effect 54 nil)
(let ((result (eval (pop-stack))))
(when *load-print*
(load-fresh-line)
(prin1 result)
(terpri))))
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
(define-fop (fop-funcall 55)
(let ((arg (read-arg 1)))
(if (zerop arg)
(funcall (pop-stack))
(do ((args () (cons (pop-stack) args))
(n arg (1- n)))
((zerop n) (apply (pop-stack) args))))))
(define-fop (fop-funcall-for-effect 56 nil)
(let ((arg (read-arg 1)))
(if (zerop arg)
(funcall (pop-stack))
(do ((args () (cons (pop-stack) args))
(n arg (1- n)))
((zerop n) (apply (pop-stack) args))))))
;;;; Fixing up circularities.
(define-fop (fop-rplaca 200 nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4))
(val (pop-stack)))
(setf (car (nthcdr idx obj)) val)))
(define-fop (fop-rplacd 201 nil)
(let ((obj (svref *current-fop-table* (read-arg 4)))
(idx (read-arg 4))
(val (pop-stack)))
(setf (cdr (nthcdr idx obj)) val)))
(define-fop (fop-svset 202 nil)
(let* ((obi (read-arg 4))
(obj (svref *current-fop-table* obi))
(idx (read-arg 4))
(val (pop-stack)))
(if (structurep obj)
(setf (c::structure-ref obj idx) val)
(setf (svref obj idx) val))))
(define-fop (fop-structset 204 nil)
(setf (c::structure-ref (svref *current-fop-table* (read-arg 4))
(read-arg 4))
(pop-stack)))
(define-fop (fop-nthcdr 203 t)
(nthcdr (read-arg 4) (pop-stack)))
;;;; Loading functions:
(define-fop (fop-code-format 57 :nope)
(setf *current-code-format*
(cons (read-arg 1) (read-arg 1))))
;;; Load-Code loads a code object. NItems objects are popped off the stack for
;;; the boxed storage section, then Size bytes of code are read in.
`(if *current-code-format*
(let ((implementation (car *current-code-format*))
(version (cdr *current-code-format*)))
(unless (= implementation
#.(c:backend-fasl-file-implementation c:*backend*))
(error "~A was compiled for a ~A, but this is a ~A"
*Fasl-file*
(or (elt c:fasl-file-implementations implementation)
"unknown machine")
(or (elt c:fasl-file-implementations
#.(c:backend-fasl-file-implementation c:*backend*))
"unknown machine")))
(unless (= version #.(c:backend-fasl-file-version c:*backend*))
(error "~A was compiled for fasl-file version ~A, ~
but this is version ~A"
*Fasl-file* version #.(c:backend-fasl-file-version c:*backend*)))
(let ((box-num ,nitems)
(code-length ,size))
(declare (fixnum box-num code-length))
(let ((code (%primitive allocate-code-object box-num code-length))
(index (+ vm:code-trace-table-offset-slot box-num)))
(setf (code-header-ref code vm:code-debug-info-slot) (pop-stack))
(dotimes (i box-num)
(declare (fixnum i))
(setf (code-header-ref code (decf index)) (pop-stack)))
(system:without-gcing
(read-n-bytes *fasl-file* (code-instructions code) 0
code-length))
code)))
(error
"Code Format not set? Can't load code until after FOP-CODE-FORMAT.")))
(load-code (read-arg 4) (read-arg 4)))
(load-code (read-arg 1) (read-arg 2)))