home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / FASLOAD.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  5.0 KB  |  158 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;;; This file contains a bootstap loader for the fasload function which
  4. ;;; is compiled code in fasload format.  It implements enough of the
  5. ;;; fasloader to load the compiled version.
  6.  
  7. (DEFCONSTANT FOP-DISPATCH-TABLE ())    ; the operations
  8.  
  9. (DEFCONSTANT FOP-STRING (MAKE-ARRAY 50 :FILL-POINTER 0
  10.                        :ELEMENT-TYPE 'STRING-CHAR))
  11.  
  12. ; for reading a 4 byte sequence and returning a number.  NOTE: the 2 most
  13. ; significant bytes are currently ignored.
  14. (DEFMACRO GET-4-BYTE X
  15.   '(PROG1 (+& (FUNCALL *STANDARD-INPUT* :READ-CHAR)
  16.           (LSH (FUNCALL *STANDARD-INPUT* :READ-CHAR) 8))
  17.       (FUNCALL *STANDARD-INPUT* :READ-CHAR)    ; dump 2 high bytes for now
  18.       (FUNCALL *STANDARD-INPUT* :READ-CHAR)))
  19.  
  20. ; for reading a 2 byte sequence and returning a number.
  21. (DEFMACRO GET-2-BYTE X
  22.   '(+& (FUNCALL *STANDARD-INPUT* :READ-CHAR)
  23.       (LSH (FUNCALL *STANDARD-INPUT* :READ-CHAR) 8)))
  24.  
  25. ; for reading 1 byte and returning its value.
  26. (DEFMACRO GET-1-BYTE X
  27.   '(FUNCALL *STANDARD-INPUT* :READ-CHAR))
  28.  
  29. ; For defining the operations
  30. (DEFMACRO DEF-FOP X
  31.   (LET ((OP (CAR X))
  32.     (BODY (CDR X)))
  33.     `(PUSH '(,OP . (LAMBDA () ,@BODY)) FOP-DISPATCH-TABLE)))
  34.  
  35. ;;; The various FOP instructions
  36.  
  37. ; FOP-EMPTY-LIST
  38. (DEF-FOP 4
  39.   (PUSH NIL FOP-STACK))
  40.  
  41. ; FOP-SMALL-SYMBOL-SAVE
  42. (DEF-FOP 7
  43.   (LET ((SIZE (GET-1-BYTE)))
  44.     (SETF (FILL-POINTER FOP-STRING) SIZE)
  45.     (SEND *STANDARD-INPUT* :FILL-ARRAY FOP-STRING)
  46.     (PUSH (INTERN FOP-STRING) FOP-STACK)))
  47.  
  48. ; FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE
  49. (DEF-FOP 11
  50.   (LET ((I (GET-1-BYTE))
  51.     (SIZE (GET-1-BYTE)))
  52.     (SETF (FILL-POINTER FOP-STRING) SIZE)
  53.     (SEND *STANDARD-INPUT* :FILL-ARRAY FOP-STRING)
  54.     (PUSH (INTERN FOP-STRING (AREF FOP-TABLE I)) FOP-STACK)))
  55.  
  56. ; FOP-DEFAULT-PACKAGE
  57. (DEF-FOP 13
  58.   (LET ((P (AREF FOP-TABLE (GET-4-BYTE))))
  59.     (UNLESS (TYPEP P 'PACKAGE)
  60.       (ERROR "FOP 13: ~S is not a package" P))
  61.     (SETQ *PACKAGE* P)))
  62.     
  63. ; FOP-PACKAGE
  64. (DEF-FOP 14
  65.   (LET* ((S (POP FOP-STACK))
  66.      (P (FIND-PACKAGE S)))
  67.     (UNLESS (TYPEP P 'PACKAGE)
  68.       (ERROR "~S is not the name of an existing package"))
  69.     (VECTOR-PUSH P FOP-TABLE)))
  70.  
  71. ; FOP-SMALL-STRING
  72. (DEF-FOP 38
  73.   (LET ((SIZE (GET-1-BYTE))
  74.         (STR))
  75.     (SETQ STR (MAKE-ARRAY SIZE :ELEMENT-TYPE 'STRING-CHAR))
  76.     (SEND *STANDARD-INPUT* :FILL-ARRAY STR)
  77.     (PUSH STR FOP-STACK)))
  78.  
  79. ; FOP-FIXUP
  80. (DEF-FOP 51
  81.   (LET ((FEFOFF (GET-2-BYTE)) 
  82.     (CNT (GET-2-BYTE))
  83.     (FEF (CAR FOP-STACK))
  84.     SEG OFF X VAL)
  85.     (SETF (VALUES OFF SEG)(%POINTER FEF))
  86.     (SETQ FEFOFF (-& OFF FEFOFF))
  87.     (DOTIMES (I CNT)
  88.       (SETF (VALUES NIL VAL) (%CONTENTS SEG (+& OFF (SETQ X (GET-2-BYTE)))))
  89.       (%CONTENTS-STORE SEG (+& OFF X) (+& VAL FEFOFF) T))
  90.     ))
  91.  
  92. ; FOP-ALTER, highly special cased.
  93. (DEF-FOP 52
  94.   (LET ((NV (POP FOP-STACK))
  95.         (OBJ (POP FOP-STACK))
  96.     (IDX (GET-1-BYTE)))
  97.     (FSET OBJ NV)))
  98.  
  99. ; FOP-CODE-FORMAT
  100. (DEF-FOP 57
  101.   (GET-1-BYTE))
  102.  
  103. ; FOP-SMALL-CODE
  104. (DEF-FOP 59
  105.   (LET ((ITEMS (GET-1-BYTE))
  106.         (SIZE (GET-2-BYTE))
  107.     FEF SEG OFF C-OFF SEG1 OFF1)
  108.     (SETQ FEF (MAKE-ARRAY (-& SIZE 11)
  109.               :ELEMENT-TYPE '(UNSIGNED-BYTE 8)))
  110.     (MULTIPLE-VALUE-SETQ (OFF SEG) (%POINTER FEF))
  111.     (%CONTENTS-STORE SEG (+& OFF 4) 0 NIL)        ; set constants 0
  112.     (%CONTENTS-STORE SEG OFF 20. NIL)            ; make it a FEF
  113.     (SEND *STANDARD-INPUT* :FILL-ARRAY FEF)        ; fill the FEF
  114.     (SETQ C-OFF (+& OFF 11))                ; where constants go
  115.     ; We hang onto stack so constants don't get gc'ed too soon.
  116.     (LET ((STACK FOP-STACK))
  117.       (DOTIMES (I ITEMS)                ; store constants
  118.         (MULTIPLE-VALUE-SETQ (OFF1 SEG1) (%POINTER (POP FOP-STACK)))
  119.         (%CONTENTS-STORE SEG (+& C-OFF (* I 4)) OFF1 SEG1))
  120.       (%CONTENTS-STORE SEG (+& OFF 4) ITEMS NIL))
  121.     ; fix up entry point
  122.     (%CONTENTS-STORE SEG (+& OFF 5) (+& OFF (+& 11 (* ITEMS 4))) T) ; offset
  123.     (%CONTENTS-STORE SEG (+& OFF 7) SEG T)            ; segment
  124.     (PUSH FEF FOP-STACK)))    
  125.  
  126. ; FOP-END-GROUP
  127. (DEF-FOP 64
  128.   (THROW 'FASLGROUP 'OK))
  129.  
  130. ;; The TOPLEVEL function
  131. (DEFUN FASLOAD1 (FILE &AUX BYTE)
  132.   (LET ((*STANDARD-INPUT* (OPEN (SETQ FILE (MERGE-PATHNAMES FILE ".FAS"))
  133.                   :ELEMENT-TYPE 'UNSIGNED-BYTE))
  134.     (*PACKAGE* *PACKAGE*)
  135.         (FOP-STACK NIL)
  136.     (FOP-TABLE (MAKE-ARRAY 50 :FILL-POINTER 0))
  137.     BYTE FUNC)
  138.     (UNWIND-PROTECT
  139.       (PROGN
  140.         (DO () ((= #X0FF (FUNCALL *STANDARD-INPUT* :READ-CHAR))))
  141.         (CATCH 'FASLGROUP
  142.           (DO () (())
  143.             (UNLESS (SETQ BYTE (FUNCALL *STANDARD-INPUT* :READ-CHAR))
  144.               (ERROR "Unexpected EOF while loading FASL file."))
  145.             (COND ((SETQ FUNC (CDR (ASSOC BYTE FOP-DISPATCH-TABLE)))
  146.                    (FUNCALL FUNC))
  147.                   (T (ERROR "Unimplemented FOP instruction: ~S" BYTE)))))
  148.     FILE)
  149.       (CLOSE *STANDARD-INPUT*))))
  150.  
  151. (WITH-DISKETTE *LISP-LIBRARY-DISKETTE*
  152.            #'FASLOAD1
  153.            (MERGE-PATHNAMES "FLD.FAS"
  154.                 *LISP-LIBRARY-PATHNAME*))
  155.  
  156. (MAPC 'FMAKUNBOUND '(GET-4-BYTE GET-2-BYTE GET-1-BYTE DEF-FOP FASLOAD1))
  157. (MAPC 'MAKUNBOUND '(FOP-DISPATCH-TABLE))
  158.