root/trunk/lisp/nzwei/fasupd.lisp @ 258

Revision 258, 5.9 KB (checked in by rjs, 3 years ago)

Update.

Line 
1;; -*-MODE:LISP; PACKAGE:ZWEI-*-
2;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
3
4(DEFCOM COM-FASL-UPDATE
5             "Update the fasl file of the file you are visiting.
6Uses the function definitions present in the environment,
7compiling them if they are not already compiled.   Note that
8you must have already compiled any functions you changed since
9the fasl file you loaded was compiled.  Also note that
10DECLAREs and EVAL-WHEN (COMPILE)s will be ignored!" ()
11    (LET ((BUFFER (READ-BUFFER-NAME "Update fasl file of buffer:"
12                       *INTERVAL*               ;Default is current buffer.
13                       NIL)))
14      (OR (BUFFER-FILE-ID BUFFER)
15          (BARF "This buffer is not associated with a file"))
16      (FASL-UPDATE BUFFER))
17    DIS-NONE)
18
19;; Write out the compilations of the functions whose sources are in BUFFER.
20;; We assume that the user has compiled all the functions he has changed.
21;; The QFASL file name is formed from the name of the buffer.
22;; We don't actually do any compilation or evaluation of the buffer,
23;; though we do expand the macros.
24
25;; Normally, we read each form from the buffer and process it.
26;; For forms starting with DEFUN and DEFMETHOD, we read only the
27;; function name, which is enough to use to dump the function,
28;; and then we skip the rest of the form and cons up a dummy DEFUN or DEFMETHOD
29;; with no body or arglist to use in doing the dumping.
30
31(DEFUN FASL-UPDATE (BUFFER &OPTIONAL OUTFILE
32                           &AUX COMPILER:QC-FILE-LOAD-FLAG (COMPILER:QC-FILE-IN-CORE-FLAG T)
33                                INFILE INPUT-STREAM COMPILER:FASD-STREAM
34                                COMPILER:LAST-ERROR-FUNCTION
35                                DEFTYPE FNNAME
36                                (DEFAULT-CONS-AREA DEFAULT-CONS-AREA)
37                                (COMPILER:QC-FILE-OLD-DEFAULT-CONS-AREA DEFAULT-CONS-AREA))
38  (SETQ INFILE (BUFFER-FILE-NAME BUFFER))
39  (SETQ OUTFILE
40        (IF OUTFILE
41            (SI:FILE-PARSE-NAME OUTFILE NIL (FUNCALL INFILE ':COPY-WITH-TYPE ':QFASL))
42            (FUNCALL INFILE ':COPY-WITH-TYPE ':QFASL)))
43  (SETQ INPUT-STREAM (INTERVAL-STREAM BUFFER))
44  (UNWIND-PROTECT
45    (LET ((COMPILER:QC-FILE-IN-PROGRESS T)
46          (LOCAL-DECLARATIONS NIL)
47          (COMPILER:FILE-LOCAL-DECLARATIONS NIL))
48      (COMPILER:FASD-OPEN OUTFILE)
49      (COMPILER:FASD-INITIALIZE)
50      ;; First thing in QFASL file must be property list
51      ;; Only property supported just now is PACKAGE property
52      (COMPILER:FASD-FILE-PROPERTY-LIST
53        (LIST ':PACKAGE (INTERN (PKG-NAME PACKAGE) SI:PKG-USER-PACKAGE)))
54      (COMPILER:QC-PROCESS-INITIALIZE)
55      (DO ((EOF (NCONS NIL))
56           (BP)
57           (FORM))
58          (NIL)
59        ;; Start a new whack if FASD-TABLE is getting too big.
60        (AND ( (COMPILER:FASD-TABLE-LENGTH) COMPILER:QC-FILE-WHACK-THRESHOLD)
61             (COMPILER:FASD-END-WHACK))
62        ;; Find next interesting object in buffer.
63        (SETQ BP (SKIP-OVER-BLANK-LINES-AND-COMMENTS
64                   (FUNCALL INPUT-STREAM ':READ-BP)))
65        (OR BP (RETURN NIL))
66        ;; Read and macroexpand in temp area.
67        (SETQ DEFAULT-CONS-AREA COMPILER:QC-FILE-TEMPORARY-AREA)
68        ;; This is intended to look at the form that follows,
69        ;; decide whether it is a defun, and if so
70        ;; just create a dummy, since we will not look at the body anyway.
71        (MULTIPLE-VALUE (DEFTYPE FNNAME)
72          (FASL-UPDATE-CHECK-DEFUN BP))
73        (COND ((AND DEFTYPE
74                    (FDEFINEDP (IF (EQ DEFTYPE 'DEFMETHOD)
75                                   (CONS ':METHOD FNNAME)
76                                   FNNAME)))
77               (FUNCALL INPUT-STREAM ':SET-BP
78                        ;; The memo-izing lisp parser can cons permanent information
79                        (LET ((DEFAULT-CONS-AREA COMPILER:QC-FILE-OLD-DEFAULT-CONS-AREA))
80                          (FORWARD-SEXP BP)))
81               (SETQ FORM `(,DEFTYPE ,FNNAME NIL NIL)))
82              (T
83               (FUNCALL INPUT-STREAM ':SET-BP BP)
84               (LET ((COMPILER:QC-FILE-READ-IN-PROGRESS T))
85                 (SETQ FORM (READ INPUT-STREAM EOF)))))
86        (AND (EQ EOF FORM)
87             (RETURN NIL))
88        (SETQ FORM (MACROEXPAND FORM T))
89        (SETQ DEFAULT-CONS-AREA COMPILER:QC-FILE-OLD-DEFAULT-CONS-AREA)
90        ;; Output this form in the appropriate way.
91        (COMPILER:COMPILE-DRIVER FORM (FUNCTION FASL-UPDATE-FORM) NIL))
92      (COMPILER:FASD-END-WHACK)
93      (COMPILER:FASD-END-FILE)
94      (COMPILER:FASD-CLOSE OUTFILE))
95    (COMPILER:QC-FILE-RESET)))
96
97;; This is the list of types of form that we don't even need to read.
98(DECLARE (SPECIAL FASL-UPDATE-DEFTYPES-ALIST))
99(SETQ FASL-UPDATE-DEFTYPES-ALIST
100      '(("DEFUN" DEFUN) ("DEFMETHOD" DEFMETHOD)))
101
102(DEFUN FASL-UPDATE-CHECK-DEFUN (BP &AUX BP1 DEFTYPE FNNAME)
103  ;; Now get the second word after BP.
104  (AND (= (BP-CH-CHAR BP) #/()
105       (SETQ BP (FORWARD-CHAR BP))
106       (SETQ BP1 (FORWARD-ATOM BP))
107       (SETQ DEFTYPE (CADR (ASSOC (STRING-INTERVAL BP BP1)
108                                  FASL-UPDATE-DEFTYPES-ALIST)))
109       (SETQ BP (FORWARD-OVER *BLANKS* BP1))
110       (SETQ BP1 (FORWARD-SEXP BP))
111       (SETQ FNNAME (STRING-INTERVAL BP BP1))
112       (MVRETURN DEFTYPE (READ-FROM-STRING FNNAME))))
113
114;; Process one form, for COMPILE-DRIVER.
115(DEFUN FASL-UPDATE-FORM (FORM TYPE)
116    (SELECTQ TYPE
117      (SPECIAL (COMPILER:FASD-FORM FORM NIL))
118      (DECLARE)         ;Ignore DECLAREs -- this may not always be right!
119      ((BEGF COMMENT))
120      ((DEFUN MACRO)    ;Don't compile -- send over whatever is already compiled
121        (OR (FDEFINEDP (CADR FORM))
122            (FERROR NIL "You forgot to compile ~S" (CADR FORM)))
123        (PROG (TEM TEM1)
124         LOOP
125           (SETQ TEM (FDEFINITION (CADR FORM)))
126           (AND (LISTP TEM) (EQ (CAR TEM) 'MACRO) (SETQ TEM (CDR TEM)))
127           (COND ((AND (LISTP TEM)
128                       (MEMQ (CAR TEM) '(LAMBDA NAMED-LAMBDA)))
129                  (COND ((AND (EQ (CAR TEM) 'NAMED-LAMBDA)
130                              (LISTP (CADR TEM))
131                              (SETQ TEM1 (ASSQ 'TRACE (CDADR TEM))))
132                         (FORMAT ERROR-OUTPUT "~&Untracing ~S~%" (CADR FORM))
133                         (FDEFINE (CADR FORM) (FDEFINITION (CADR TEM1)))
134                         (GO LOOP)))
135                  (FORMAT ERROR-OUTPUT "~&Compiling ~S~%" (CADR FORM))
136                  (COMPILE (CADR FORM))))
137           ;; This works on this bodiless DEFUN by virtue of the fact that FASD-FORM in
138           ;; Optimize mode calls FDEFINITION rather than looking at the form.
139           (COMPILER:FASD-FORM FORM T)))
140      (OTHERWISE (COMPILER:FASD-FORM FORM T))))
Note: See TracBrowser for help on using the browser.