home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 9 / 09.iso / e / e070 / 4.ddi / LISPLIB / FASDUMP.LSP < prev    next >
Encoding:
Text File  |  1984-11-06  |  7.5 KB  |  210 lines
  1. ;;; (C) Copyright 1984 by Gold Hill Computers
  2.  
  3. ;; This file contains routines to dump lisp objects to a
  4. ;; FASL (object code) file.
  5.  
  6. ;  "This is used to create a FASL stream to which lisp objects may be
  7. ;dumped.  Currently :PROPERTY-LIST is the only supported option.  It is
  8. ;a property list that is placed at the beginning of the FASL file. The
  9. ;stream returned by this function accepts the following messages:
  10. ;    :DUMP <obj>, dump object to the fasl file.  <obj> can be
  11. ;        a SYMBOL, STRING, FIXNUM, STRUCTURE, or LIST.
  12. ;    :NOP, insert a NOP operator.
  13. ;    :POP-FOR-EFFECT, pop and discard the top of stack.
  14. ;    :ALTER <idx>, alter the second item on the stack in the way
  15. ;        specified by index depending on type of second item on
  16. ;        stack (LIST or SYMBOL): 0 - RPLACA, SET, 1 - RPLACD, FSET,
  17. ;        2 - SETPLIST.  The top of stack will be the new value.
  18. ;    :EVAL, eval top of stack and then put in back.
  19. ;    :EVAL-FOR-EFFECT, eval top of stack and discard.
  20. ;    :FUNCALL <n>, take n items on stack top as args, funcall the n+1
  21. ;        item on these args (top of stack is last arg), push result to
  22. ;        stack.
  23. ;    :DUMP-PACKAGE pkg-name, dump package of specified name, returns idx.
  24. ;    :SET-PACKAGE pkg-name, sets the default package.
  25. ;    :CLOSE, close the FASL file."
  26. (DEFUN MAKE-FASL-OUTPUT-STREAM (FNAME &REST OPTIONS
  27.                    &aux notice comment)
  28.   (LET (PLIST
  29.     STRM
  30.     (TBL-IDX 0)              ;the fop table index
  31.     (PKG (AREF *PACKAGE* 1))      :pkg name
  32.     (PKG-ALIST NIL)
  33.     (DEF-PATHNAME (MAKE-PATHNAME :TYPE "FAS" 
  34.                      :DEFAULTS *DEFAULT-PATHNAME-DEFAULTS*))
  35.     )
  36.     (DO ((I OPTIONS (CDDR I)))
  37.     ((NULL I))
  38.       (CASE (CAR I)
  39.         (:PROPERTY-LIST (SETF PLIST (SECOND I)))
  40.         (:NOTICE (setf notice (cadr i)))
  41.         (:COMMENT (setf comment (cadr i)))
  42.     (OTHERWISE
  43.       (ERROR "MAKE-FASL-OUTPUT-STREAM: Unknown option: ~S" (CAR I)))))
  44.     (SETF STRM (OPEN (MERGE-PATHNAMES FNAME DEF-PATHNAME)
  45.              :DIRECTION :OUTPUT :ELEMENT-TYPE 'UNSIGNED-BYTE))
  46.     ;; put the header things in.
  47.     (PRINC "FASL FILE" STRM)
  48.     (WRITE-BYTE #\RETURN STRM)        ; TERPRI won't work quit right since
  49.     (WRITE-BYTE #\LINEFEED STRM)    ; we are in unsigned-byte mode.
  50.     (WHEN NOTICE (PRINC NOTICE STRM)
  51.       (WRITE-BYTE #\RETURN STRM)    ; TERPRI won't work quit right since
  52.       (WRITE-BYTE #\LINEFEED STRM))    ; we are in unsigned-byte mode.
  53.     (WHEN COMMENT 
  54.       (PRINC COMMENT STRM)
  55.       (WRITE-BYTE #\RETURN STRM)    ; TERPRI won't work quit right since
  56.       (WRITE-BYTE #\LINEFEED STRM))    ; we are in unsigned-byte mode.
  57.     ;; dump out the files properties
  58.     (DO ((I PLIST (CDDR I)))
  59.     ((NULL I))
  60.       (PRINC (CAR I) STRM)
  61.       (WRITE-BYTE #\RETURN STRM)
  62.       (WRITE-BYTE #\LINEFEED STRM)
  63.       (WRITE-BYTE #\TAB STRM)
  64.       (PRINC (SECOND I) STRM)
  65.       (WRITE-BYTE #\RETURN STRM)
  66.       (WRITE-BYTE #\LINEFEED STRM))
  67.     (WRITE-BYTE 26 STRM)        ; EOF if you look at this as text.
  68.     (WRITE-BYTE 255 STRM)        ; end of header
  69.     ;; return stream
  70.     (LET ((S (CLOSURE '(STRM TBL-IDX PKG PKG-ALIST) 'FASDUMP-INTERNAL)))
  71.       (SEND S :SET-PACKAGE PKG)          ;set default package
  72.       S)))
  73.  
  74. ;;; The closure variables are:
  75. ;;;    STRM - the dumping stream
  76. ;;;    TBL-IDX - the index into the table of the next free spot
  77. ;;;    PKG - the current default package name.
  78. ;;;    PKG-ALIST - an alist of packages and table indexes.
  79. ;;;
  80. (DEFUN FASDUMP-INTERNAL (OP &OPTIONAL ARG)
  81.   "Internal function for fasl streams.  See MAKE-FASL-OUTPUT-STREAM."
  82.   (CASE OP
  83.     ;; DUMP arg to fasl file
  84.     (:DUMP
  85.       (CASE (TYPE-OF ARG)
  86.         ((SYMBOL KEYWORD)
  87.           (LET ((PNAME (SYMBOL-NAME ARG))
  88.         (PG (AREF (SYMBOL-PACKAGE ARG) 1))
  89.         (IDX NIL))
  90.         (WHEN (> (LENGTH PNAME) 255.)
  91.           (ERROR "Can't dump symbol longer that 255 characters: ~S"
  92.              ARG))
  93.         (COND ((EQUAL PG PKG)      ;package is same as default
  94.            (WRITE-BYTE 7 STRM)      ;small symbol save operator.
  95.            (WRITE-BYTE (LENGTH PNAME) STRM))
  96.           (T
  97.            (SETQ IDX (FASDUMP-INTERNAL :DUMP-PACKAGE PG))
  98.            (IF (< IDX 256)
  99.                (PROGN
  100.                  (WRITE-BYTE 11 STRM)
  101.              (WRITE-BYTE IDX STRM))
  102.                (PROGN
  103.                  (WRITE-BYTE 9 STRM)
  104.              (WRITE-4-BYTE IDX STRM)))
  105.            (WRITE-BYTE (LENGTH PNAME) STRM)))
  106.         (PRINC PNAME STRM)))
  107.     (NULL
  108.       (WRITE-BYTE 4 STRM))        ; NIL
  109.         (FIXNUM
  110.           (WRITE-BYTE 35. STRM)
  111.       (WRITE-4-BYTE ARG STRM))
  112.         (CONS
  113.       (DO ((I ARG (CDR I)))
  114.           ((NOT (CONSP I))(FASDUMP-INTERNAL :DUMP I))
  115.         (FASDUMP-INTERNAL :DUMP (CAR I)))
  116.       (DO ((I (LENGTH ARG) (- I 254))
  117.            (1STP T NIL))
  118.           ((<= I 0))
  119.         (WRITE-BYTE 16 STRM)            ; LIST or LIST*
  120.         (WRITE-BYTE (MIN 254 I) STRM)))        ; dump list item
  121.     (OTHERWISE
  122.       (COND ((TYPEP ARG '(VECTOR STRING-CHAR))
  123.          (IF (< (LENGTH ARG) 256)
  124.              (PROGN
  125.                (WRITE-BYTE 38. STRM)
  126.                (WRITE-BYTE (LENGTH ARG) STRM))
  127.              (LET ((LEN (LENGTH ARG)))
  128.                (WRITE-BYTE 37. STRM)
  129.                (WRITE-BYTE (LOGAND #XFF LEN) STRM)
  130.                (WRITE-BYTE (LSH LEN -8) STRM)
  131.                (WRITE-BYTE 0 STRM)
  132.                (WRITE-BYTE 0 STRM)))
  133.          (PRINC ARG STRM))
  134.         ((OR (TYPEP ARG 'STRUCTURE)      ;a structure or general vector
  135.              (TYPEP ARG '(VECTOR T)))
  136.          (DOTIMES (I (LENGTH ARG))
  137.            (FASDUMP-INTERNAL :DUMP (AREF ARG I)))
  138.          (WRITE-BYTE 39. STRM)      ;vector
  139.          (WRITE-4-BYTE (LENGTH ARG) STRM) ;length
  140.          (WHEN (TYPEP ARG 'STRUCTURE)
  141.            (WRITE-BYTE 46. STRM))); turn vector into structure
  142.         (T (ERROR "Don't know how to dump: ~S" ARG))))))
  143.     ;; close the stream
  144.     (:CLOSE
  145.       (WRITE-BYTE 64. STRM)        ; end the group
  146.       (SEND STRM :CLOSE))
  147.     ;; NOP operator
  148.     (:NOP
  149.       (WRITE-BYTE 0 STRM))
  150.     (:SET-PACKAGE
  151.       (LET ((IDX (FASDUMP-INTERNAL :DUMP-PACKAGE ARG)))
  152.     (SETQ PKG ARG)
  153.     (WRITE-BYTE 13 STRM)
  154.     (WRITE-4-BYTE IDX STRM)))      ;set default package
  155.     (:DUMP-PACKAGE              ;dump package if not already dumped
  156.      (LET ((IDX (CDR (ASSOC (SETQ ARG (STRING ARG)) PKG-ALIST
  157.                 :TEST #'EQUAL))))
  158.        (IF IDX
  159.        IDX                  ;have it, just return index
  160.        (PROGN
  161.          (WRITE-BYTE 7 STRM)      ;send the package name
  162.          (WRITE-BYTE (LENGTH ARG) STRM)    ;its length
  163.          (PRINC ARG STRM)          ;its pname
  164.          (WRITE-BYTE 14 STRM)      ;fop-package
  165.          (PUSH (CONS ARG TBL-IDX) PKG-ALIST)  ;add to pkg table
  166.          (PROG1 TBL-IDX (INCF TBL-IDX))))))
  167.     ;; POP stack and discard
  168.     (:POP-FOR-EFFECT
  169.       (WRITE-BYTE 65. STRM))
  170.     ;; EVAL for top of stack, then put it back
  171.     (:EVAL
  172.       (WRITE-BYTE 53. STRM))
  173.     (:EVAL-FOR-EFFECT
  174.      (WRITE-BYTE 54. STRM))
  175.     ;; ALTER 2 item on stack with stack top
  176.     (:ALTER
  177.       (WRITE-BYTE 52. STRM)
  178.       (WRITE-BYTE ARG STRM))
  179.     (:WHICH-OPERATIONS
  180.       '(:DUMP :NOP :SET-PACKAGE :POP-FOR-EFFECT :ALTER :EVAL :EVAL-FOR-EFFECT :FUNCALL :CLOSE))
  181.     (OTHERWISE
  182.       (ERROR "FASDUMP-INTERNAL: Bad stream operation: ~S" OP))))
  183.  
  184. (DEFUN WRITE-4-BYTE (I STRM)
  185.   (WRITE-BYTE (LOGAND #XFF I) STRM) ;dump index
  186.   (WRITE-BYTE (LSH I -8) STRM)
  187.   (WRITE-BYTE 0 STRM)
  188.   (WRITE-BYTE 0 STRM)
  189.   )
  190.  
  191. ;; This is for faslfying a file so that it will load faster (when the
  192. ;; fasloader gets compiled).
  193. (DEFUN FASLFY-FILE (PN &rest OPTIONS)
  194.   (LET ((IN (MERGE-PATHNAMES PN))
  195.     (INS NIL)
  196.     (OUTS NIL)
  197.     (EOF (NCONS NIL))
  198.     (OBJ NIL))
  199.     (SETQ INS (OPEN IN))
  200.     (SETQ OUTS (apply 'MAKE-FASL-OUTPUT-STREAM (cons(MAKE-PATHNAME :TYPE "FAS"
  201.                                :DEFAULTS IN) OPTIONS)))
  202.     (UNWIND-PROTECT
  203.       (LOOP
  204.         (SETQ OBJ (READ INS NIL EOF))
  205.     (WHEN (EQ OBJ EOF) (RETURN NIL))
  206.     (SEND OUTS :DUMP OBJ)
  207.     (SEND OUTS :EVAL-FOR-EFFECT))
  208.       (CLOSE INS)
  209.       (CLOSE OUTS))))
  210.