home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 5.ddi / EXPLORER / VIEWER / FASLOAD.LSP < prev    next >
Encoding:
Text File  |  1984-10-16  |  5.0 KB  |  164 lines
  1. ;;; Copyright (c) Gold Hill Computers, Inc. 1984
  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) 0)
  45.     (DOTIMES (I SIZE)
  46.       (VECTOR-PUSH (GET-1-BYTE) FOP-STRING))
  47.     (PUSH (INTERN FOP-STRING) FOP-STACK)))
  48.  
  49. ; FOP-SMALL-SYMBOL-IN-BYTE-PACKAGE-SAVE
  50. (DEF-FOP 11
  51.   (LET ((I (GET-1-BYTE))
  52.     (SIZE (GET-1-BYTE)))
  53.     (SETF (FILL-POINTER FOP-STRING) 0)
  54.     (DOTIMES (I SIZE)
  55.       (VECTOR-PUSH (GET-1-BYTE) FOP-STRING))
  56.     (PUSH (INTERN FOP-STRING (AREF FOP-TABLE I)) FOP-STACK)))
  57.  
  58. ; FOP-DEFAULT-PACKAGE
  59. (DEF-FOP 13
  60.   (LET ((P (AREF FOP-TABLE (GET-4-BYTE))))
  61.     (UNLESS (TYPEP P 'PACKAGE)
  62.       (ERROR "FOP 13: ~S is not a package" P))
  63.     (SETQ *PACKAGE* P)))
  64.     
  65. ; FOP-PACKAGE
  66. (DEF-FOP 14
  67.   (LET* ((S (POP FOP-STACK))
  68.      (P (FIND-PACKAGE S)))
  69.     (UNLESS (TYPEP P 'PACKAGE)
  70.       (ERROR "~S is not the name of an existing package"))
  71.     (VECTOR-PUSH P FOP-TABLE)))
  72.  
  73. ; FOP-SMALL-STRING
  74. (DEF-FOP 38
  75.   (LET ((SIZE (GET-1-BYTE))
  76.         (STR))
  77.     (SETQ STR (MAKE-ARRAY SIZE :ELEMENT-TYPE 'STRING-CHAR))
  78.     (DOTIMES (I SIZE)
  79.       (ASET (GET-1-BYTE) STR I))
  80.     (PUSH STR FOP-STACK)))
  81.  
  82. ; FOP-FIXUP
  83. (DEF-FOP 51
  84.   (LET ((FEFOFF (GET-2-BYTE)) 
  85.     (CNT (GET-2-BYTE))
  86.     (FEF (CAR FOP-STACK))
  87.     SEG OFF X VAL)
  88.     (SETF (VALUES OFF SEG)(%POINTER FEF))
  89.     (SETQ FEFOFF (- OFF FEFOFF))
  90.     (DOTIMES (I CNT)
  91.       (SETF (VALUES NIL VAL) (%CONTENTS SEG (+& OFF (SETQ X (GET-2-BYTE)))))
  92.       (%CONTENTS-STORE SEG (+& OFF X) (+& VAL FEFOFF) T))
  93.     ))
  94.  
  95. ; FOP-ALTER, highly special cased.
  96. (DEF-FOP 52
  97.   (LET ((NV (POP FOP-STACK))
  98.         (OBJ (POP FOP-STACK))
  99.     (IDX (GET-1-BYTE)))
  100.     (FSET OBJ NV)))
  101.  
  102. ; FOP-EVAL-FOR-EFFECT
  103. ;(DEF-FOP 54
  104. ;  (EVAL (POP FOP-STACK)))
  105.  
  106. ; FOP-CODE-FORMAT
  107. (DEF-FOP 57
  108.   (GET-1-BYTE))
  109.  
  110. ; FOP-SMALL-CODE
  111. (DEF-FOP 59
  112.   (LET ((ITEMS (GET-1-BYTE))
  113.         (SIZE (GET-2-BYTE))
  114.     FEF SEG OFF C-OFF SEG1 OFF1)
  115.     (SETQ FEF (MAKE-ARRAY (- SIZE 11)
  116.               :ELEMENT-TYPE '(UNSIGNED-BYTE 8)))
  117.     (MULTIPLE-VALUE-SETQ (OFF SEG) (%POINTER FEF))
  118.     (%CONTENTS-STORE SEG (+& OFF 4) 0 NIL)        ; set constants 0
  119.     (DOTIMES (I SIZE)                    ; store FEF
  120.       (%CONTENTS-STORE SEG (+& OFF I) (GET-1-BYTE) NIL))
  121.     (SETQ C-OFF (+& OFF 11))                ; where constants go
  122.     ; We hang onto stack so constants don't get gc'ed too soon.
  123.     (LET ((STACK FOP-STACK))
  124.       (DOTIMES (I ITEMS)                ; store constants
  125.         (MULTIPLE-VALUE-SETQ (OFF1 SEG1) (%POINTER (POP FOP-STACK)))
  126.         (%CONTENTS-STORE SEG (+& C-OFF (* I 4)) OFF1 SEG1))
  127.       (%CONTENTS-STORE SEG (+& OFF 4) ITEMS NIL))
  128.     ; fix up entry point
  129.     (%CONTENTS-STORE SEG (+& OFF 5) (+& OFF (+& 11 (* ITEMS 4))) T) ; offset
  130.     (%CONTENTS-STORE SEG (+& OFF 7) SEG T)            ; segment
  131.     (PUSH FEF FOP-STACK)))    
  132.  
  133. ; FOP-END-GROUP
  134. (DEF-FOP 64
  135.   (THROW 'FASLGROUP 'OK))
  136.  
  137. ;; The TOPLEVEL function
  138. (DEFUN FASLOAD1 (FILE &AUX BYTE)
  139.   (LET ((*STANDARD-INPUT* (OPEN (SETQ FILE (MERGE-PATHNAMES FILE ".FAS"))
  140.                   :ELEMENT-TYPE 'UNSIGNED-BYTE))
  141.     (*PACKAGE* *PACKAGE*)
  142.         (FOP-STACK NIL)
  143.     (FOP-TABLE (MAKE-ARRAY 50 :FILL-POINTER 0))
  144.     BYTE FUNC)
  145.     (UNWIND-PROTECT
  146.       (PROGN
  147.         (DO () ((= #X0FF (FUNCALL *STANDARD-INPUT* :READ-CHAR))))
  148.         (CATCH 'FASLGROUP
  149.           (DO () (())
  150.             (UNLESS (SETQ BYTE (FUNCALL *STANDARD-INPUT* :READ-CHAR))
  151.               (ERROR "Unexpected EOF while loading FASL file."))
  152.             (COND ((SETQ FUNC (CDR (ASSOC BYTE FOP-DISPATCH-TABLE)))
  153.                    (FUNCALL FUNC))
  154.                   (T (ERROR "Unimplemented FOP instruction: ~S" BYTE)))))
  155.     FILE)
  156.       (CLOSE *STANDARD-INPUT*))))
  157.  
  158. (WITH-DISKETTE *LISP-LIBRARY-DISKETTE*
  159.            #'FASLOAD1
  160.            (MERGE-PATHNAMES "FLD.FAS"
  161.                 *LISP-LIBRARY-PATHNAME*))
  162.  
  163. (MAPC 'FMAKUNBOUND '(GET-4-BYTE GET-2-BYTE GET-1-BYTE DEF-FOP FASLOAD1))
  164. (MAPC 'MAKUNBOUND '(FOP-DISPATCH-TABLE))