source: branches/shrink-tcr/level-0/nfasload.lisp @ 14606

Last change on this file since 14606 was 14606, checked in by rme, 9 years ago

Checkpoint of work in progress.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 41.2 KB
Line 
1;;;-*- Mode: Lisp; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(eval-when (:compile-toplevel :execute)
21
22(require "FASLENV" "ccl:xdump;faslenv")
23
24
25(defconstant $primsizes (make-array 23
26                                    :element-type '(unsigned-byte 16)
27                                    :initial-contents
28                                    '(41 61 97 149 223 337 509 769 887 971 1153 1559 1733
29                                      2609 2801 3917 5879 8819 13229 19843 24989 29789 32749)))
30(defconstant $hprimes (make-array 8 
31                                  :element-type '(unsigned-byte 16)
32                                  :initial-contents '(5 7 11 13 17 19 23 29)))
33
34;;; Symbol hash tables: (htvec . (hcount . hlimit))
35
36(defmacro htvec (htab) `(%car ,htab))
37(defmacro htcount (htab) `(%cadr ,htab))
38(defmacro htlimit (htab) `(%cddr ,htab))
39)
40
41(eval-when (:execute :compile-toplevel)
42  (assert (= 80 numfaslops)))
43
44
45
46
47
48(defvar *fasl-dispatch-table* #80(%bad-fasl))
49
50
51
52
53
54(defun %bad-fasl (s)
55  (error "bad opcode near position ~d in FASL file ~s"
56         (%fasl-get-file-pos s)
57         (faslstate.faslfname s)))
58
59(defun %cant-epush (s)
60  (if (faslstate.faslepush s)
61    (%bad-fasl s)))
62
63(defun %epushval (s val)
64  (setf (faslstate.faslval s) val)
65  (when (faslstate.faslepush s)
66    (setf (svref (faslstate.faslevec s) (faslstate.faslecnt s)) val)
67    (incf (the fixnum (faslstate.faslecnt s))))
68  val)
69
70(defun %simple-fasl-read-buffer (s)
71  (let* ((fd (faslstate.faslfd s))
72         (buffer (faslstate.iobuffer s))
73         (bufptr (%get-ptr buffer)))
74    (declare (dynamic-extent bufptr)
75             (type macptr buffer bufptr))
76    (%setf-macptr bufptr (%inc-ptr buffer target::node-size))
77    (setf (%get-ptr buffer) bufptr)
78    (let* ((n (fd-read fd bufptr $fasl-buf-len)))
79      (declare (fixnum n))
80      (if (> n 0)
81        (setf (faslstate.bufcount s) n)
82        (error "Fix this: look at errno, EOF")))))
83
84 
85(defun %simple-fasl-read-byte (s)
86  (loop
87    (let* ((buffer (faslstate.iobuffer s))
88           (bufptr (%get-ptr buffer)))
89      (declare (dynamic-extent bufptr)
90               (type macptr buffer bufptr))
91      (if (>= (the fixnum (decf (the fixnum (faslstate.bufcount s))))
92              0)
93        (return
94         (prog1
95           (%get-unsigned-byte bufptr)
96           (setf (%get-ptr buffer)
97                 (%incf-ptr bufptr))))
98        (%fasl-read-buffer s)))))
99
100(defun %fasl-read-word (s)
101  (the fixnum 
102    (logior (the fixnum (ash (the fixnum (%fasl-read-byte s)) 8))
103            (the fixnum (%fasl-read-byte s)))))
104
105
106(defun %fasl-read-long (s)
107  (logior (ash (%fasl-read-word s) 16) (%fasl-read-word s)))
108
109(defun %fasl-read-signed-long (s)
110  (logior (ash (%word-to-int (%fasl-read-word s)) 16)
111          (%fasl-read-word s)))
112
113
114(defun %fasl-read-count (s)
115  (do* ((val 0)
116        (shift 0 (+ shift 7))
117        (done nil))
118       (done val)
119    (let* ((b (%fasl-read-byte s)))
120      (declare (type (unsigned-byte 8) b))
121      (setq done (logbitp 7 b) val (logior val (ash (logand b #x7f) shift))))))
122
123(defun %simple-fasl-read-n-bytes (s ivector byte-offset n)
124  (declare (fixnum byte-offset n))
125  (do* ()
126       ((= n 0))
127    (let* ((count (faslstate.bufcount s))
128           (buffer (faslstate.iobuffer s))
129           (bufptr (%get-ptr buffer))
130           (nthere (if (< count n) count n)))
131      (declare (dynamic-extent bufptr)
132               (type macptr buffer bufptr)
133               (fixnum count nthere))
134      (if (= nthere 0)
135        (%fasl-read-buffer s)
136        (progn
137          (decf n nthere)
138          (decf (the fixnum (faslstate.bufcount s)) nthere)
139          (%copy-ptr-to-ivector bufptr 0 ivector byte-offset nthere)
140          (incf byte-offset nthere)
141          (setf (%get-ptr buffer)
142                (%incf-ptr bufptr nthere)))))))
143       
144
145(defun %fasl-read-utf-8-string (s string nchars nextra)
146  (declare (fixnum nchars nextra))
147  (if (eql 0 nextra)
148    (dotimes (i nchars)
149      (setf (%scharcode string i) (%fasl-read-byte s)))
150    (flet ((trailer-byte ()
151             (when (> nextra 0)
152               (decf nextra)
153               (let* ((b (%fasl-read-byte s)))
154                 (declare ((unsigned-byte 8) b))
155                 (and (>= b #x80)
156                      (< b #xc0)
157                      (logand b #x3f))))))
158      (declare (inline trailer-byte))
159      (dotimes (i nchars)
160        (let* ((b0 (%fasl-read-byte s)))
161          (declare ((unsigned-byte 8) b0))
162          (setf (%scharcode string i)
163                (or
164                 (cond ((< b0 #x80) b0)
165                       ((and (>= b0 #xc2)
166                             (< b0 #xe0))
167                        (let* ((b1 (trailer-byte)))
168                          (and b1 (logior (ash (logand b0 #x1f) 6) b1))))
169                       ((and (>= b0 #xe0)
170                             (< b0 #xf0))
171                        (let* ((b1 (trailer-byte))
172                               (b2 (trailer-byte)))
173                          (and b1 b2 (logior (ash (logand b0 #x0f) 12)
174                                             (logior (ash b1 6)
175                                                     b2)))))
176                       ((and (>= b0 #xf0)
177                             (< b0 #xf5))
178                        (let* ((b1 (trailer-byte))
179                               (b2 (trailer-byte))
180                               (b3 (trailer-byte)))
181                          (and b1
182                               b2
183                               b3
184                               (logior (ash (logand b0 #x7) 18)
185                                       (logior (ash b1 12)
186                                               (logior (ash b2 6)
187                                                       b3)))))))
188                 (char-code #\Replacement_Character))))))))
189
190
191(defun %fasl-vreadstr (s)
192  (let* ((nchars (%fasl-read-count s))
193         (nextra (%fasl-read-count s))
194         (copy t)
195         (n nchars)
196         (str (faslstate.faslstr s)))
197    (declare (fixnum nchars n nextra))
198    (if (> n (length str))
199      (setq str (make-string n :element-type 'base-char))
200      (setq copy nil))
201    (%fasl-read-utf-8-string s str nchars nextra)
202    (values str nchars copy)))
203
204
205(defun %fasl-read-n-string (s string start n)
206  (declare (fixnum start n))
207  (do* ((i start (1+ i))
208        (n n (1- n)))
209       ((<= n 0))
210    (declare (fixnum i n))
211    (setf (%scharcode string i) (%fasl-read-byte s))))
212
213(defun %fasl-nvreadstr (s)
214  (let* ((nchars (%fasl-read-count s))
215         (copy t)
216         (n nchars)
217         (str (faslstate.faslstr s)))
218    (declare (fixnum n nchars))
219    (if (> n (length str))
220        (setq str (make-string n :element-type 'base-char))
221        (setq copy nil))
222    (%fasl-read-n-string  s str 0 nchars)
223    (values str n copy)))
224
225(defun %fasl-copystr (str len)
226  (declare (fixnum len))
227  (let* ((new (make-string len :element-type 'base-char)))
228    (declare (simple-base-string new))
229    (declare (optimize (speed 3)(safety 0)))
230    (dotimes (i len new)
231      (setf (schar new i) (schar str i)))))
232
233(defun %fasl-dispatch (s op)
234  (declare (fixnum op)) 
235  (setf (faslstate.faslepush s) (logbitp $fasl-epush-bit op))
236  #+debug
237  (format t "~& dispatch: op = ~d at ~x" (logand op (lognot (ash 1 $fasl-epush-bit)))
238          (1- (%fasl-get-file-pos s)))
239  (funcall (svref (faslstate.fasldispatch s) (logand op (lognot (ash 1 $fasl-epush-bit)))) 
240           s))
241
242(defun %fasl-expr (s)
243  (%fasl-dispatch s (%fasl-read-byte s))
244  (faslstate.faslval s))
245
246(defun %fasl-expr-preserve-epush (s)
247  (let* ((epush (faslstate.faslepush s))
248         (val (%fasl-expr s)))
249    (setf (faslstate.faslepush s) epush)
250    val))
251
252
253(defun %fasl-vmake-symbol (s &optional idx)
254  (let* ((n (%fasl-read-count s))
255         (nextra (%fasl-read-count s))
256         (str (make-string n :element-type 'base-char)))
257    (declare (fixnum n))
258    (%fasl-read-utf-8-string s str n nextra)
259    (let* ((sym (make-symbol str)))
260      (when idx (ensure-binding-index sym))
261      (%epushval s sym))))
262
263(defun %fasl-nvmake-symbol (s &optional idx)
264  (let* ((n (%fasl-read-count s))
265         (str (make-string n :element-type 'base-char)))
266    (declare (fixnum n))
267    (%fasl-read-n-string s str 0 n)
268    (let* ((sym (make-symbol str)))
269      (when idx (ensure-binding-index sym))
270      (%epushval s sym))))
271
272(defun %fasl-vintern (s package &optional binding-index)
273  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
274    (with-package-lock (package)
275      (multiple-value-bind (symbol access internal-offset external-offset)
276          (%find-symbol str len package)
277        (unless access
278          (unless new-p (setq str (%fasl-copystr str len)))
279          (setq symbol (%add-symbol str package internal-offset external-offset)))
280        (when binding-index
281          (ensure-binding-index symbol))
282        (%epushval s symbol)))))
283
284(defun %fasl-nvintern (s package &optional binding-index)
285  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
286    (with-package-lock (package)
287      (multiple-value-bind (symbol access internal-offset external-offset)
288          (%find-symbol str len package)
289        (unless access
290          (unless new-p (setq str (%fasl-copystr str len)))
291          (setq symbol (%add-symbol str package internal-offset external-offset)))
292        (when binding-index
293          (ensure-binding-index symbol))
294        (%epushval s symbol)))))
295
296(defvar *package-refs*)
297(setq *package-refs* (make-hash-table :test #'equal))
298(defvar *package-refs-lock*)
299(setq *package-refs-lock* (make-lock))
300
301(defun register-package-ref (name)
302  (unless (typep name 'string)
303    (report-bad-arg name 'string))
304  (let* ((ref
305          (or (gethash name *package-refs*)
306              (with-lock-grabbed (*package-refs-lock*)
307                (or
308                 (gethash name *package-refs*) ; check again
309                 (let* ((r (make-package-ref name)))
310                   (setf (gethash name *package-refs*) r)))))))
311    (unless (package-ref.pkg ref)
312      (setf (package-ref.pkg ref) (find-package name)))
313    ref))
314
315
316(dolist (p %all-packages%)
317  (dolist (name (pkg.names p))
318    (setf (package-ref.pkg (register-package-ref name)) p)))
319
320
321(defun find-package (name)
322  (if (typep  name 'package)
323    name
324    (%find-pkg (string name))))
325
326(defun %pkg-ref-find-package (ref)
327  (package-ref.pkg ref))
328
329(defun set-package (name &aux (pkg (find-package name)))
330  (if pkg
331    (setq *package* pkg)
332    (set-package (%kernel-restart $xnopkg name))))
333
334 
335(defun %find-pkg (name &optional (len (length name)))
336  (declare (fixnum len))
337  (with-package-list-read-lock
338      (dolist (p %all-packages%)
339        (if (dolist (pkgname (pkg.names p))
340              (when (and (= (the fixnum (length pkgname)) len)
341                         (dotimes (i len t)
342                           ;; Aref: allow non-simple strings
343                           (unless (eq (aref name i) (schar pkgname i))
344                             (return))))
345                (return t)))
346          (return p)))))
347
348
349
350(defun pkg-arg (thing &optional deleted-ok)
351  (let* ((xthing (cond ((or (symbolp thing) (typep thing 'character))
352                        (string thing))
353                       ((typep thing 'string)
354                        (ensure-simple-string thing))
355                       (t
356                        thing))))
357    (let* ((typecode (typecode xthing)))
358        (declare (fixnum typecode))
359        (cond ((= typecode target::subtag-package)
360               (if (or deleted-ok (pkg.names xthing))
361                 xthing
362                 (error "~S is a deleted package ." thing)))
363              ((= typecode target::subtag-simple-base-string)
364               (or (%find-pkg xthing)
365                   (%kernel-restart $xnopkg xthing)))
366              (t (report-bad-arg thing 'simple-string))))))
367
368(defun %fasl-vpackage (s)
369  (multiple-value-bind (str len new-p) (%fasl-vreadstr s)
370    (let* ((p (%find-pkg str len)))
371      (%epushval s (or p (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
372
373
374(defun %fasl-nvpackage (s)
375  (multiple-value-bind (str len new-p) (%fasl-nvreadstr s)
376    (let* ((p (%find-pkg str len)))
377      (%epushval s (or p  (%kernel-restart $XNOPKG (if new-p str (%fasl-copystr str len))))))))
378
379(defun %fasl-vlistX (s dotp)
380  (let* ((len (%fasl-read-count s)))
381    (declare (fixnum len))
382    (let* ((val (%epushval s (cons nil nil)))
383           (tail val))
384      (declare (type cons val tail))
385      (setf (car val) (%fasl-expr s))
386      (dotimes (i len)
387        (setf (cdr tail) (setq tail (cons (%fasl-expr s) nil))))
388      (if dotp
389        (setf (cdr tail) (%fasl-expr s)))
390      (setf (faslstate.faslval s) val))))
391
392(deffaslop $fasl-noop (s)
393  (%cant-epush s))
394
395
396(deffaslop $fasl-vetab-alloc (s)
397  (%cant-epush s)
398  (setf (faslstate.faslevec s) (make-array (the fixnum (%fasl-read-count s)))
399        (faslstate.faslecnt s) 0))
400
401(deffaslop $fasl-platform (s)
402  (%cant-epush s)
403  (let* ((platform (%fasl-expr s))
404         (host-platform (%get-kernel-global 'host-platform)))
405    (declare (fixnum platform host-platform))
406    (unless (= platform host-platform)
407      (error "Not a native fasl file : ~s" (faslstate.faslfname s)))))
408
409
410(deffaslop $fasl-veref (s)
411  (let* ((idx (%fasl-read-count s)))
412    (declare (fixnum idx))
413    (if (>= idx (the fixnum (faslstate.faslecnt s)))
414      (%bad-fasl s))
415    (%epushval s (svref (faslstate.faslevec s) idx))))
416
417(defun decode-imm-word-count (imm-word-count element-count)
418  (if (logbitp 15 imm-word-count)
419    (- element-count (ldb (byte 15 0) imm-word-count))
420    imm-word-count))
421
422#+x86-target
423;;; Read a "concatenated" lisp function, in which the machine code
424;;; and constants are both contained in the same underlying uvector.
425(deffaslop $fasl-clfun (s)
426  (let* ((size-in-elements (%fasl-read-count s))
427         (size-of-code (%fasl-read-count s))
428         (vector (%alloc-misc size-in-elements target::subtag-function))
429         (function (function-vector-to-function vector)))
430    (declare (fixnum size-in-elements size-of-code))
431    (%epushval s function)
432    #+x8632-target
433    (setq size-of-code (decode-imm-word-count size-of-code size-in-elements))
434    (%fasl-read-n-bytes s vector 0 (ash size-of-code target::word-shift))
435    #+x8632-target
436    (%update-self-references vector)
437    #+x8632-target
438    (let* ((addr (%address-of vector))
439           (insn (%get-unsigned-long (%int-to-ptr addr))))
440      (when (eql insn #xbf)
441        (pdbg "update-self-references blew it")
442        (dbg vector)))
443    (do* ((numconst (- size-in-elements size-of-code))
444          (i 0 (1+ i))
445          (constidx size-of-code (1+ constidx)))
446         ((= i numconst)
447          (setf (faslstate.faslval s) function))
448      (declare (fixnum i numconst constidx))
449      (setf (%svref vector constidx) (%fasl-expr s)))))
450   
451   
452(deffaslop $fasl-lfuncall (s)
453  (let* ((fun (%fasl-expr-preserve-epush s)))
454    ;(break "fun = ~s" fun)
455     (%epushval s (funcall fun))))
456
457(deffaslop $fasl-globals (s)
458  (setf (faslstate.faslgsymbols s) (%fasl-expr s)))
459
460(deffaslop $fasl-char (s)
461  (%epushval s (code-char (%fasl-read-count s))))
462
463;;; Deprecated
464(deffaslop $fasl-fixnum (s)
465  (%epushval
466   s
467   (logior (the fixnum (ash (the fixnum (%word-to-int (%fasl-read-word s)))
468                            16))
469           (the fixnum (%fasl-read-word s))) ))
470
471(deffaslop $fasl-s32 (s)
472  (%epushval s (%fasl-read-signed-long s)))
473
474(deffaslop $fasl-s64 (s)
475  (%epushval s (logior (ash (%fasl-read-signed-long s) 32)
476                       (%fasl-read-long s))))
477
478(deffaslop $fasl-dfloat (s)
479  ;; A double-float is a 3-element "misc" object.
480  ;; Element 0 is always 0 and exists solely to keep elements 1 and 2
481  ;; aligned on a 64-bit boundary.
482  (%epushval s (double-float-from-bits (%fasl-read-long s) (%fasl-read-long s))))
483
484(deffaslop $fasl-sfloat (s)
485  (%epushval s (host-single-float-from-unsigned-byte-32 (%fasl-read-long s))))
486
487(deffaslop $fasl-vstr (s)
488  (let* ((nchars (%fasl-read-count s))
489         (nextra (%fasl-read-count s))
490         (str (make-string (the fixnum nchars) :element-type 'base-char)))
491    (%epushval s str)
492    (%fasl-read-utf-8-string s str nchars nextra)))
493
494
495(deffaslop $fasl-nvstr (s)
496  (let* ((n (%fasl-read-count s))
497         (str (make-string (the fixnum n) :element-type 'base-char)))
498    (%epushval s str)
499    (%fasl-read-n-string s str 0 n)))
500
501(deffaslop $fasl-word-fixnum (s)
502  (%epushval s (%word-to-int (%fasl-read-word s))))
503
504(deffaslop $fasl-vmksym (s)
505  (%fasl-vmake-symbol s))
506
507(deffaslop $fasl-nvmksym (s)
508  (%fasl-nvmake-symbol s))
509
510(deffaslop $fasl-vmksym-special (s)
511  (%fasl-vmake-symbol s t))
512
513(deffaslop $fasl-nvmksym-special (s)
514  (%fasl-nvmake-symbol s t))
515
516(deffaslop $fasl-vintern (s)
517  (%fasl-vintern s *package*))
518
519(deffaslop $fasl-nvintern (s)
520  (%fasl-nvintern s *package*))
521
522(deffaslop $fasl-vintern-special (s)
523  (%fasl-vintern s *package* t))
524
525(deffaslop $fasl-nvintern-special (s)
526  (%fasl-nvintern s *package* t))
527
528
529
530
531(deffaslop $fasl-vpkg-intern (s)
532  (let* ((pkg (%fasl-expr-preserve-epush s)))
533    #+paranoia
534    (setq pkg (pkg-arg pkg))
535    (%fasl-vintern s pkg)))
536
537(deffaslop $fasl-nvpkg-intern (s)
538  (let* ((pkg (%fasl-expr-preserve-epush s)))
539    #+paranoia
540    (setq pkg (pkg-arg pkg))
541    (%fasl-nvintern s pkg)))
542
543(deffaslop $fasl-vpkg-intern-special (s)
544  (let* ((pkg (%fasl-expr-preserve-epush s)))
545    #+paranoia
546    (setq pkg (pkg-arg pkg))
547    (%fasl-vintern s pkg t)))
548
549(deffaslop $fasl-nvpkg-intern-special (s)
550  (let* ((pkg (%fasl-expr-preserve-epush s)))
551    #+paranoia
552    (setq pkg (pkg-arg pkg))
553    (%fasl-nvintern s pkg t)))
554
555(deffaslop $fasl-vpkg (s)
556  (%fasl-vpackage s))
557
558(deffaslop $fasl-nvpkg (s)
559  (%fasl-nvpackage s))
560
561(deffaslop $fasl-cons (s)
562  (let* ((cons (%epushval s (cons nil nil))))
563    (declare (type cons cons))
564    (setf (car cons) (%fasl-expr s)
565          (cdr cons) (%fasl-expr s))
566    (setf (faslstate.faslval s) cons)))
567
568(deffaslop $fasl-vlist (s)
569  (%fasl-vlistX s nil))
570
571(deffaslop $fasl-vlist* (s)
572  (%fasl-vlistX s t))
573
574(deffaslop $fasl-nil (s)
575  (%epushval s nil))
576
577(deffaslop $fasl-timm (s)
578  (rlet ((p :int))
579    (setf (%get-long p) (%fasl-read-long s))
580    (%epushval s (%get-unboxed-ptr p))))
581
582(deffaslop $fasl-symfn (s)
583  (%epushval s (%function (%fasl-expr-preserve-epush s))))
584   
585(deffaslop $fasl-eval (s)
586  (%epushval s (eval (%fasl-expr-preserve-epush s))))
587
588;;; For bootstrapping. The real version is cheap-eval in l1-readloop
589(when (not (fboundp 'eval))
590  (defun eval (form)
591    (if (and (listp form)
592             (let ((f (%car form)))
593               (and (symbolp f)
594                    (functionp (fboundp f)))))
595      (do* ((tail (%cdr form) (%cdr tail)))
596           ((null tail) (apply (%car form) (%cdr form)))
597        (let* ((head (car tail)))
598          (when (and (consp head) (eq (car head) 'quote))
599            (setf (car tail) (cadr head)))))
600      (error "Can't eval yet: ~s" form))))
601
602
603(deffaslop $fasl-vivec (s)
604  (let* ((subtag (%fasl-read-byte s))
605         (element-count (%fasl-read-count s))
606         (size-in-bytes (subtag-bytes subtag element-count))
607         (vector (%alloc-misc element-count subtag))
608         (byte-offset (or #+32-bit-target (if (= subtag target::subtag-double-float-vector) 4) 0)))
609    (declare (fixnum subtag element-count size-in-bytes))
610    (%epushval s vector)
611    (%fasl-read-n-bytes s vector byte-offset size-in-bytes)
612    vector))
613
614(defun fasl-read-ivector (s subtag)
615  (let* ((element-count (%fasl-read-count s))
616         (size-in-bytes (subtag-bytes subtag element-count))
617         (vector (%alloc-misc element-count subtag)))
618    (declare (fixnum subtag element-count size-in-bytes))
619    (%epushval s vector)
620    (%fasl-read-n-bytes s vector 0 size-in-bytes)
621    vector))
622 
623(deffaslop $fasl-u8-vector (s)
624  (fasl-read-ivector s target::subtag-u8-vector))
625
626(deffaslop $fasl-s8-vector (s)
627  (fasl-read-ivector s target::subtag-s8-vector))
628
629(deffaslop $fasl-u16-vector (s)
630  (fasl-read-ivector s target::subtag-u16-vector))
631
632(deffaslop $fasl-s16-vector (s)
633  (fasl-read-ivector s target::subtag-s16-vector))
634
635(deffaslop $fasl-u32-vector (s)
636  (fasl-read-ivector s target::subtag-u32-vector))
637
638(deffaslop $fasl-s32-vector (s)
639  (fasl-read-ivector s target::subtag-s32-vector))
640
641#+64-bit-target
642(deffaslop $fasl-u64-vector (s)
643  (fasl-read-ivector s target::subtag-u64-vector))
644
645#+64-bit-target
646(deffaslop $fasl-u64-vector (s)
647  (fasl-read-ivector s target::subtag-s64-vector))
648
649(deffaslop $fasl-bit-vector (s)
650  (fasl-read-ivector s target::subtag-bit-vector))
651
652(deffaslop $fasl-bignum32 (s)
653  (let* ((element-count (%fasl-read-count s))
654         (size-in-bytes (* element-count 4))
655         (num (%alloc-misc element-count target::subtag-bignum)))
656    (declare (fixnum element-count size-in-bytes))
657    (%fasl-read-n-bytes s num 0 size-in-bytes)
658    (setq num (%normalize-bignum-2 t num))
659    (%epushval s num)
660    num))
661
662(deffaslop $fasl-single-float-vector (s)
663  (fasl-read-ivector s target::subtag-single-float-vector))
664
665(deffaslop $fasl-double-float-vector (s)
666  #+64-bit-target
667  (fasl-read-ivector s target::subtag-double-float-vector)
668  #+32-bit-target
669  (let* ((element-count (%fasl-read-count s))
670         (size-in-bytes (subtag-bytes target::subtag-double-float-vector
671                                      element-count))
672         (vector (%alloc-misc element-count
673                              target::subtag-double-float-vector)))
674    (declare (fixnum element-count size-in-bytes))
675    (%epushval s vector)
676    (%fasl-read-n-bytes s vector (- target::misc-dfloat-offset
677                                    target::misc-data-offset)
678                        size-in-bytes)
679    vector))
680
681
682
683#-x86-target
684(deffaslop $fasl-code-vector (s)
685  (let* ((element-count (%fasl-read-count s))
686         (size-in-bytes (* 4 element-count))
687         (vector (allocate-typed-vector :code-vector element-count)))
688    (declare (fixnum element-count size-in-bytes))
689    (%epushval s vector)
690    (%fasl-read-n-bytes s vector 0 size-in-bytes)
691    (%make-code-executable vector)
692    vector))
693
694(defun fasl-read-gvector (s subtype)
695  (let* ((n (%fasl-read-count s))
696         (vector (%alloc-misc n subtype)))
697    (declare (fixnum n subtype))
698    (%epushval s vector)
699    (dotimes (i n (setf (faslstate.faslval s) vector))
700      (setf (%svref vector i) (%fasl-expr s)))))
701
702(deffaslop $fasl-vgvec (s)
703  (let* ((subtype (%fasl-read-byte s)))
704    (fasl-read-gvector s subtype)))
705 
706(deffaslop $fasl-ratio (s)
707  (let* ((r (%alloc-misc target::ratio.element-count target::subtag-ratio)))
708    (%epushval s r)
709    (setf (%svref r target::ratio.numer-cell) (%fasl-expr s)
710          (%svref r target::ratio.denom-cell) (%fasl-expr s))
711    (setf (faslstate.faslval s) r)))
712
713(deffaslop $fasl-complex (s)
714  (let* ((c (%alloc-misc target::complex.element-count
715                         target::subtag-complex)))
716    (%epushval s c)
717    (setf (%svref c target::complex.realpart-cell) (%fasl-expr s)
718          (%svref c target::complex.imagpart-cell) (%fasl-expr s))
719    (setf (faslstate.faslval s) c)))
720
721(deffaslop $fasl-t-vector (s)
722  (fasl-read-gvector s target::subtag-simple-vector))
723
724(deffaslop $fasl-function (s)
725  (fasl-read-gvector s target::subtag-function))
726
727(deffaslop $fasl-istruct (s)
728  (fasl-read-gvector s target::subtag-istruct))
729
730(deffaslop $fasl-vector-header (s)
731  (fasl-read-gvector s target::subtag-vectorH))
732
733(deffaslop $fasl-array-header (s)
734  (fasl-read-gvector s target::subtag-arrayH))
735
736
737(deffaslop $fasl-defun (s)
738  (%cant-epush s)
739  (%defun (%fasl-expr s) (%fasl-expr s)))
740
741(deffaslop $fasl-macro (s)
742  (%cant-epush s)
743  (%macro (%fasl-expr s) (%fasl-expr s)))
744
745(deffaslop $fasl-defconstant (s)
746  (%cant-epush s)
747  (%defconstant (%fasl-expr s) (%fasl-expr s) (%fasl-expr s)))
748
749(deffaslop $fasl-defparameter (s)
750  (%cant-epush s)
751  (let* ((sym (%fasl-expr s))
752         (val (%fasl-expr s)))
753    (%defvar sym (%fasl-expr s))
754    (set sym val)))
755
756;;; (defvar var)
757(deffaslop $fasl-defvar (s)
758  (%cant-epush s)
759  (%defvar (%fasl-expr s)))
760
761;;; (defvar var initfom doc)
762(deffaslop $fasl-defvar-init (s)
763  (%cant-epush s)
764  (let* ((sym (%fasl-expr s))
765         (val (%fasl-expr s)))
766    (unless (%defvar sym (%fasl-expr s))
767      (set sym val))))
768
769
770(deffaslop $fasl-prog1 (s)
771  (let* ((val (%fasl-expr s)))
772    (%fasl-expr s)
773    (setf (faslstate.faslval s) val)))
774
775
776
777(deffaslop $fasl-src (s)
778  (%cant-epush s)
779  (let* ((source-file (%fasl-expr s)))
780    ; (format t "~& source-file = ~s" source-file)
781    (setq *loading-file-source-file* source-file)))
782
783(deffaslop $fasl-toplevel-location (s)
784  (%cant-epush s)
785  (setq *loading-toplevel-location* (%fasl-expr s)))
786
787(defvar *modules* nil)
788
789;;; Bootstrapping version
790(defun provide (module-name)
791  (push (string module-name) *modules*))
792
793(deffaslop $fasl-provide (s)
794  (provide (%fasl-expr s)))
795
796(deffaslop $fasl-istruct-cell (s)
797  (%epushval s (register-istruct-cell (%fasl-expr-preserve-epush s))))
798
799
800
801;;; files compiled with code coverage do this
802;; list of lfuns and (source-fn-name vector-of-lfuns external-format id), the latter put there by fasloading.
803(defvar *code-covered-functions* nil)
804
805(defun register-code-covered-functions (functions &optional external-format id)
806  ;; unpack the parent-note references - see comment at fcomp-digest-code-notes
807  (labels ((reg (lfun refs)
808             (unless (memq lfun refs)
809               (let* ((lfv (function-to-function-vector lfun))
810                      (start #+ppc-target 0 #+x86-target (%function-code-words lfun))
811                      (refs (cons lfun refs)))
812                 (declare (dynamic-extent refs))
813                 (loop for i from start below (uvsize lfv) as imm = (uvref lfv i)
814                       do (typecase imm
815                            (code-note
816                             (let ((parent (code-note-parent-note imm)))
817                               (when (integerp parent)
818                                 (setf (code-note-parent-note imm) (uvref lfv parent)))))
819                            (function (reg imm refs))))))))
820    (loop for fn across functions do (reg fn nil)))
821  (let ((a (assoc (pathname *loading-file-source-file*)
822                  *code-covered-functions*
823                  :test #'(lambda (p q)
824                            (and (equalp (pathname-name p) (pathname-name q))
825                                 ;; same name, so worth trying harder to match 'em up.
826                                 (or (equal p q)
827                                     (let ((p (full-pathname p)) (q (full-pathname q)))
828                                       (and p q (equalp p q)))
829                                     (let ((p (probe-file p)) (q (probe-file q)))
830                                       (and p q (equalp p q)))))))))
831    (when (null a)
832      (push (setq a (list nil nil nil nil)) *code-covered-functions*))
833    (setf (car a) *loading-file-source-file*
834          (cadr a) functions
835          (caddr a) external-format
836          (cadddr a) id))
837  nil)
838
839;;; The loader itself
840
841(defun %simple-fasl-set-file-pos (s new)
842  (let* ((fd (faslstate.faslfd s))
843         (posoffset (fd-tell fd)))
844    (if (>= (decf posoffset new) 0)
845      (let* ((count (faslstate.bufcount s)))
846        (if (>= (decf count posoffset ) 0)
847          (progn
848            (setf (faslstate.bufcount s) posoffset)
849            (incf #+32-bit-target (%get-long (faslstate.iobuffer s))
850                  #+64-bit-target (%%get-signed-longlong (faslstate.iobuffer s)
851                                                        0)
852                  count)
853            (return-from %simple-fasl-set-file-pos nil)))))
854    (progn
855      (setf (faslstate.bufcount s) 0)
856      (fd-lseek fd new #$SEEK_SET))))
857
858(defun %simple-fasl-get-file-pos (s)
859  (- (fd-tell (faslstate.faslfd s)) (faslstate.bufcount s)))
860
861(defparameter *%fasload-verbose* t)
862
863;;; the default fasl file opener sets up the fasl state and checks the header
864(defun %simple-fasl-open (string s)
865  (let* ((ok nil)
866         (fd (fd-open string #$O_RDONLY))
867         (err 0))
868    (declare (fixnum fd))
869    (if (>= fd 0)
870      (if (< (fd-lseek fd 0 #$SEEK_END) 4)
871        (setq err $xnotfasl)
872        (progn
873          (setq err 0)
874          (setf (faslstate.bufcount s) 0
875                (faslstate.faslfd s) fd)
876          (fd-lseek fd 0 #$SEEK_SET)
877          (multiple-value-setq (ok err) (%fasl-check-header s))))
878      (setq err fd))
879    (unless (eql err 0) (setf (faslstate.faslerr s) err))
880    ok))
881
882;;; once the fasl state is set up, this checks the fasl header and
883;;; returns (values ok err)
884(defun %fasl-check-header (s)
885  (let* ((signature (%fasl-read-word s)))
886    (declare (fixnum signature))
887    (if (= signature $fasl-file-id)
888        (values t 0)
889      (if (= signature $fasl-file-id1)
890          (progn
891            (%fasl-set-file-pos s (%fasl-read-long s))
892            (values t 0))
893        (values nil $xnotfasl)))))
894
895(defun %simple-fasl-close (s)
896  (let* ((fd (faslstate.faslfd s)))
897    (when fd (fd-close fd))))
898
899(defun %simple-fasl-init-buffer (s)
900  (declare (ignore s))
901  nil)
902
903(defvar *fasl-api* nil)
904(setf *fasl-api* (%istruct 'faslapi
905                           #'%simple-fasl-open
906                           #'%simple-fasl-close
907                           #'%simple-fasl-init-buffer
908                           #'%simple-fasl-set-file-pos
909                           #'%simple-fasl-get-file-pos
910                           #'%simple-fasl-read-buffer
911                           #'%simple-fasl-read-byte
912                           #'%simple-fasl-read-n-bytes))
913
914(defun %fasl-open (string s)
915  (funcall (faslapi.fasl-open *fasl-api*) string s))
916(defun %fasl-close (s)
917  (funcall (faslapi.fasl-close *fasl-api*) s))
918(defun %fasl-init-buffer (s)
919  (funcall (faslapi.fasl-init-buffer *fasl-api*) s))
920(defun %fasl-set-file-pos (s new)
921  (funcall (faslapi.fasl-set-file-pos *fasl-api*) s new))
922(defun %fasl-get-file-pos (s)
923  (funcall (faslapi.fasl-get-file-pos *fasl-api*) s))
924(defun %fasl-read-buffer (s)
925  (funcall (faslapi.fasl-read-buffer *fasl-api*) s))
926(defun %fasl-read-byte (s)
927  (funcall (faslapi.fasl-read-byte *fasl-api*) s))
928(defun %fasl-read-n-bytes (s ivector byte-offset n)
929  (funcall (faslapi.fasl-read-n-bytes *fasl-api*) s ivector byte-offset n))
930
931(defun %fasload (string &optional (table *fasl-dispatch-table*))
932  ;;(dbg string)
933  (when (and *%fasload-verbose*
934             (not *load-verbose*))
935    (%string-to-stderr ";Loading ") (pdbg string))
936  (let* ((s (%istruct
937             'faslstate
938             nil
939             nil
940             nil
941             nil
942             nil
943             nil
944             nil
945             nil
946             nil
947             nil
948             nil
949             nil
950             nil
951             nil)))
952    (declare (dynamic-extent s))
953    (setf (faslstate.faslfname s) string)
954    (setf (faslstate.fasldispatch s) table)
955    (setf (faslstate.faslversion s) 0)
956    (%stack-block ((buffer (+ target::node-size $fasl-buf-len)))
957      (setf (faslstate.iobuffer s) buffer)
958      (%fasl-init-buffer s)
959      (let* ((parse-string (make-string 255 :element-type 'base-char)))
960        (declare (dynamic-extent parse-string))
961        (setf (faslstate.oldfaslstr s) nil
962              (faslstate.faslstr s) parse-string)
963        (unwind-protect
964             (when (%fasl-open string s)
965               (let* ((nblocks (%fasl-read-word s)))
966                 (declare (fixnum nblocks))
967                 (unless (= nblocks 0)
968                   (let* ((pos (%fasl-get-file-pos s)))
969                     (dotimes (i nblocks)
970                       (%fasl-set-file-pos s pos)
971                       (%fasl-set-file-pos s (%fasl-read-long s))
972                       (incf pos 8)
973                       (let* ((version (%fasl-read-word s)))
974                         (declare (fixnum version))
975                         (if (or (> version (+ #xff00 $fasl-vers))
976                                 (< version (+ #xff00 $fasl-min-vers)))
977                           (%err-disp (if (>= version #xff00) $xfaslvers $xnotfasl))
978                           (progn
979                             (setf (faslstate.faslversion s) version)
980                             (%fasl-read-word s) 
981                             (%fasl-read-word s) ; Ignore kernel version stuff
982                             (setf (faslstate.faslevec s) nil
983                                   (faslstate.faslecnt s) 0)
984                             (do* ((op (%fasl-read-byte s) (%fasl-read-byte s)))
985                                  ((= op $faslend))
986                               (declare (fixnum op))
987                               (%fasl-dispatch s op))))))))))
988          (%fasl-close s))
989        (let* ((err (faslstate.faslerr s)))
990          (if err
991            (progn
992              (when *%fasload-verbose*
993                (let* ((herald ";!!Error loading ")
994                       (hlen (length herald))
995                       (len (length string))
996                       (msg (make-string (+ hlen len))))
997                  (declare (dynamic-extent msg))
998                  (%copy-ivector-to-ivector herald 0 msg 0 (* hlen 4))
999                  (%copy-ivector-to-ivector string 0 msg (* hlen 4) (* len 4))
1000                  (bug msg)))
1001              (values nil err))
1002            (values t nil)))))))
1003
1004
1005(defun %new-package-hashtable (size)
1006  (%initialize-htab (cons nil (cons 0 0)) size))
1007
1008(defun %initialize-htab (htab size)
1009  (declare (fixnum size))
1010  ;; Ensure that "size" is relatively prime to all secondary hash values.
1011  ;; If it's small enough, pick the next highest known prime out of the
1012  ;; "primsizes" array.  Otherwize, iterate through all all of "hprimes"
1013  ;; until we find something relatively prime to all of them.
1014  (setq size
1015        (if (> size 32749)
1016          (do* ((nextsize (logior 1 size) (+ nextsize 2)))
1017               ()
1018            (declare (fixnum nextsize))
1019            (when (dotimes (i 8 t)
1020                    (unless (eql 1 (gcd nextsize (uvref #.$hprimes i)))
1021                      (return)))
1022              (return nextsize)))
1023          (dotimes (i (the fixnum (length #.$primsizes)))
1024            (let* ((psize (uvref #.$primsizes i)))
1025              (declare (fixnum psize))
1026              (if (>= psize size) 
1027                (return psize))))))
1028  (setf (htvec htab) (make-array size #|:initial-element 0|#))
1029  (setf (htcount htab) 0)
1030  (setf (htlimit htab) (the fixnum (- size (the fixnum (ash size -3)))))
1031  htab)
1032
1033
1034(defun %resize-htab (htab)
1035  (declare (optimize (speed 3) (safety 0)))
1036  (without-interrupts
1037   (let* ((old-vector (htvec htab))
1038          (old-len (length old-vector)))
1039     (declare (fixnum old-len)
1040              (simple-vector old-vector))
1041     (let* ((nsyms 0))
1042       (declare (fixnum nsyms))
1043       (dovector (s old-vector)
1044         (when (symbolp s) (incf nsyms)))
1045       (%initialize-htab htab 
1046                         (the fixnum (+ 
1047                                      (the fixnum 
1048                                        (+ nsyms (the fixnum (ash nsyms -2))))
1049                                      2)))
1050       (let* ((new-vector (htvec htab))
1051              (nnew 0))
1052         (declare (fixnum nnew)
1053                  (simple-vector new-vector))
1054         (dotimes (i old-len (setf (htcount htab) nnew))
1055           (let* ((s (svref old-vector i)))
1056               (if (symbolp s)
1057                 (let* ((pname (symbol-name s)))
1058                   (setf (svref 
1059                          new-vector 
1060                          (nth-value 
1061                           2
1062                           (%get-htab-symbol 
1063                            pname
1064                            (length pname)
1065                            htab)))
1066                         s)
1067                   (incf nnew)))))
1068         htab)))))
1069       
1070(defun hash-pname (str len)
1071  (declare (optimize (speed 3) (safety 0)))
1072  (let* ((primary (%pname-hash str len)))
1073    (declare (fixnum primary))
1074    (values primary (aref (the (simple-array (unsigned-byte 16) (8)) $hprimes) (logand primary 7)))))
1075   
1076
1077
1078(defun %get-hashed-htab-symbol (str len htab primary secondary)
1079  (declare (optimize (speed 3) (safety 0))
1080           (fixnum primary secondary len))
1081  (let* ((vec (htvec htab))
1082         (vlen (length vec)))
1083    (declare (fixnum vlen))
1084    (do* ((idx (fast-mod primary vlen) (+ i secondary))
1085          (i idx (if (>= idx vlen) (- idx vlen) idx))
1086          (elt (svref vec i) (svref vec i)))
1087         ((eql elt 0) (values nil nil i))
1088      (declare (fixnum i idx))
1089      (when (symbolp elt)
1090        (let* ((pname (symbol-name elt)))
1091          (if (and 
1092               (= (the fixnum (length pname)) len)
1093               (dotimes (j len t)
1094                 (unless (eq (aref str j) (schar pname j))
1095                   (return))))
1096            (return (values t (%symptr->symbol elt) i))))))))
1097
1098(defun %get-htab-symbol (string len htab)
1099  (declare (optimize (speed 3) (safety 0)))
1100  (multiple-value-bind (p s) (hash-pname string len)
1101    (%get-hashed-htab-symbol string len htab p s)))
1102
1103(defun %find-symbol (string len package)
1104  (declare (optimize (speed 3) (safety 0)))
1105  (multiple-value-bind (found-p sym internal-offset)
1106                       (%get-htab-symbol string len (pkg.itab package))
1107    (if found-p
1108      (values sym :internal internal-offset nil)
1109      (multiple-value-bind (found-p sym external-offset)
1110                           (%get-htab-symbol string len (pkg.etab package))
1111        (if found-p
1112          (values sym :external internal-offset external-offset)
1113          (dolist (p (pkg.used package) (values nil nil internal-offset external-offset))
1114            (multiple-value-bind (found-p sym)
1115                                 (%get-htab-symbol string len (pkg.etab p))
1116              (when found-p
1117                (return (values sym :inherited internal-offset external-offset))))))))))
1118         
1119(defun %htab-add-symbol (symbol htab idx)
1120  (declare (optimize (speed 3) (safety 0)))
1121  (setf (svref (htvec htab) idx) (%symbol->symptr symbol))
1122  (if (>= (incf (the fixnum (htcount htab)))
1123          (the fixnum (htlimit htab)))
1124    (%resize-htab htab))
1125  symbol)
1126
1127(defun %set-symbol-package (symbol package-or-nil)
1128  (declare (optimize (speed 3) (safety 0)))
1129  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1130         (old-pp (%svref symvec target::symbol.package-predicate-cell)))
1131    (if (consp old-pp)
1132      (setf (car old-pp) package-or-nil)
1133      (setf (%svref symvec target::symbol.package-predicate-cell) package-or-nil))))
1134
1135
1136(let* ((force-export-packages (list *keyword-package*))
1137       (force-export-packages-lock (make-lock)))
1138  (defun force-export-packages ()
1139    (with-lock-grabbed (force-export-packages-lock)
1140      (copy-list force-export-packages)))
1141  (defun package-force-export (p)
1142    (let* ((pkg (pkg-arg p)))
1143      (with-lock-grabbed (force-export-packages-lock)
1144        (pushnew pkg force-export-packages))
1145    pkg))
1146  (defun force-export-package-p (pkg)
1147    (with-lock-grabbed (force-export-packages-lock)
1148      (if (memq pkg force-export-packages)
1149        t))))
1150
1151
1152(defun %insert-symbol (symbol package internal-idx external-idx &optional force-export)
1153  (let* ((symvec (symptr->symvector (%symbol->symptr symbol)))
1154         (package-predicate (%svref symvec target::symbol.package-predicate-cell))
1155         (keyword-package (eq package *keyword-package*)))
1156    ;; Set home package
1157    (if package-predicate
1158      (if (listp package-predicate)
1159        (unless (%car package-predicate) (%rplaca package-predicate package)))
1160      (setf (%svref symvec target::symbol.package-predicate-cell) package))
1161    (if (or force-export (force-export-package-p package))
1162      (progn
1163        (%htab-add-symbol symbol (pkg.etab package) external-idx)
1164        (if keyword-package
1165          ;;(define-constant symbol symbol)
1166          (progn
1167            (%set-sym-global-value symbol symbol)
1168            (%symbol-bits symbol 
1169                          (logior (ash 1 $sym_vbit_special) 
1170                                  (ash 1 $sym_vbit_const)
1171                                  (the fixnum (%symbol-bits symbol)))))))
1172      (%htab-add-symbol symbol (pkg.itab package) internal-idx))
1173    (let* ((hook (pkg.intern-hook package)))
1174      (when hook (funcall hook symbol)))
1175    symbol))
1176
1177;;; PNAME must be a simple string!
1178(defun %add-symbol (pname package internal-idx external-idx &optional force-export)
1179  (let* ((sym (make-symbol pname)))
1180    (%insert-symbol sym package internal-idx external-idx force-export)))
1181
1182
1183
1184
1185;;; The initial %toplevel-function% sets %toplevel-function% to NIL;
1186;;; if the %fasload call fails, the lisp should exit (instead of
1187;;; repeating the process endlessly ...
1188
1189
1190(defvar %toplevel-function%
1191  #'(lambda ()
1192      (declare (special *xload-cold-load-functions*
1193                        *xload-cold-load-documentation*
1194                        *xload-startup-file*
1195                        *early-class-cells*))
1196      (%set-tcr-toplevel-function (%current-tcr) nil) ; should get reset by l1-boot.
1197      (setq %system-locks% (%cons-population nil))
1198      ;; Need to make %ALL-PACKAGES-LOCK% early, so that we can casually
1199      ;; do SET-PACKAGE in cold load functions.
1200      (setq %all-packages-lock% (make-read-write-lock))
1201      (dolist (f (prog1 *xload-cold-load-functions* (setq *xload-cold-load-functions* nil)))
1202        (funcall f))
1203      (dolist (pair (prog1 *early-class-cells* (setq *early-class-cells* nil)))
1204        (setf (gethash (car pair) %find-classes%) (cdr pair)))
1205      (dolist (p %all-packages%)
1206        (%resize-htab (pkg.itab p))
1207        (%resize-htab (pkg.etab p)))
1208      (dolist (f (prog1 *xload-cold-load-documentation* (setq *xload-cold-load-documentation* nil)))
1209        (apply 'set-documentation f))
1210      ;; Can't bind any specials until this happens
1211      (let* ((max 0))
1212        (%map-areas #'(lambda (symvec)
1213                        (when (= (the fixnum (typecode symvec))
1214                                 target::subtag-symbol)
1215                          (let* ((s (symvector->symptr symvec))
1216                                 (idx (symbol-binding-index s)))
1217                            (when (> idx 0)
1218                              (cold-load-binding-index s))
1219                            (when (> idx max)
1220                              (setq max idx))))))
1221        (%set-binding-index max))
1222      (%fasload *xload-startup-file*)))
1223
Note: See TracBrowser for help on using the repository browser.