3 (export '(compile compile-file
*compile-verbose
* *compile-print
*))
7 (:import-from
"XLISP" "*CMP-SETF*" "*CMP-STRUCTS*" "*CMP-GLOBAL-MACROS*"
8 "*CMP-MACROS*" "*CMP-SPECIALS*" #+xlisp-stat
"ADD-METHOD"))
14 move macros to cmpmacr.lsp
15 move cps stuff to convert.lsp
30 Macros currently defined
(**** need to be checked over
***):
32 DEFSETF PUSH PUSHNEW STEP WITH-INPUT-FROM-STRING WITH-OPEN-FILE
36 Macros needed
(check which are really needed
):
38 assert call-method ccase check-type ctypecase decf declaim defclass
39 defgeneric define-compiler-macro define-condition define-declaration
40 define-method-combination define-modify-macro define-setf-method
41 defmethod
defpackage deftype destructuring-bind do-all-symbols
42 do-external-symbols do-symbols ecase encapsulated etypecase formatter
43 gathering generic-function handler-bind handler-case ignore-errors
44 in-package incf iterate loop-finish mapping multiple-value-bind
45 multiple-value-list multiple-value-setq next-in nth-value pop
46 pprint-exit-if-exhausted pprint-logical-block pprint-pop
47 print-unreadable-object producing psetf remf restart-bind restart-case
48 rotatef shiftf terminate-producing typecase with-accessors
49 with-compilation-unit with-condition-restarts with-hash-table-iterator
50 with-open-stream with-package-iterator with-simple-restarts with-slots
51 with-standard-io-syntax
55 (progv '(*cmp-env
* *cmp-fenv
* *cmp-denv
* *cmp-tenv
* *cmp-specials
*
56 *cmp-gvars
* *cmp-gfuns
* *cmp-consts
*
57 *cmp-specials
* *cmp-macros
* *cmp-setf
* *cmp-structs
*)
58 '(nil nil nil nil nil nil nil nil nil nil nil nil
)
59 (let ((n (if (and (consp e
) (eq (first e
) 'lambda
))
61 (convert-lambda `(lambda () ,e
)))))
62 (pp-cps (merge-tests (simplify-tree (insert-cells n
)))))))
66 ;;;; Simple compiler front end
69 (defun cmp (e &optional name
)
70 (progv '(*cmp-env
* *cmp-denv
* *cmp-tenv
*
71 *cmp-gvars
* *cmp-gfuns
* *cmp-consts
*)
72 '(nil nil nil nil nil nil
)
73 (let ((n (if (and (consp e
) (eq (first e
) 'lambda
))
75 (convert-named-lambda (cons name
(rest e
)))
77 (convert-lambda `(lambda () ,e
)))))
79 (substitute-all-variables n
)
80 (collapse-null-lambda-calls n
)
83 (let ((pieces (lift-lambdas n
)))
87 (remove-unused-cells c
)
90 (generate-code pieces
)))))
92 (defun pcmp (e) (pprint (cmp e
)))
96 '(*cmp-env
* *cmp-fenv
* *cmp-denv
* *cmp-tenv
*
97 *cmp-specials
* *cmp-macros
* *cmp-setf
* *cmp-structs
*
98 *cmp-gvars
* *cmp-gfuns
* *cmp-consts
*)
99 '(nil nil nil nil nil nil nil nil nil nil nil
)))
102 (defparameter *cmp-files
*
103 '("backquot" "cmpmacro" "convert" "cells" "simplify"
104 "lift" "gencode" "peephole" "assemble" "cmpfront"))
106 (defun compile-file-list (list &optional load
)
108 #+unix
'((WINDOWS DIALOGS COLOR UNIX X11 XLISP
))
109 #+macintosh
'((WINDOWS DIALOGS MACINTOSH XLISP
))
111 (format t
"~%Compiling file ~s ... ~%" f
)
113 (format t
"finished compiling file ~s~%~%" f
)
114 (if load
(load f
)))))
116 (defun compile-cmp () (compile-file-list *cmp-files
* t
))
120 ;;;;; New File Compiler
124 (defun print-compiled-form (form stream sp
)
125 (let ((*print-readably
* t
)
126 (*print-symbol-package
* sp
))
127 (format stream
"~s~%" form
)))
129 (defun accumulate-compiled-form (form outstuff
)
130 (rplacd (last outstuff
) (list form
)))
132 ;;**** change default later?
133 (defvar *compile-verbose
* t
)
134 (defvar *compile-print
* t
)
136 (defvar *compile-print-symbol-package
* nil
)
138 (defvar *compile-warn-specials
* nil
)
140 (defvar *cmp-specials
* nil
)
141 (defvar *cmp-macros
* nil
)
142 (defvar *cmp-setf
* nil
)
143 (defvar *cmp-structs
* nil
)
146 (defun file-name-needs-extension (fname)
148 (find-if-not #'(lambda (x) (or (digit-char-p x
) (alpha-char-p x
)))
152 (defun lsp-file-name (f)
153 (if (file-name-needs-extension f
)
154 (concatenate 'string f
".lsp")
157 (defun fsl-file-name (f)
158 (let ((n (length f
)))
159 (unless (and (<= 4 (length f
)) (string= (subseq f
(- n
4) n
) ".lsp"))
160 (error "not a valid lisp file name -- ~s" f
))
161 (concatenate 'string
(subseq f
0 (- n
4)) ".fsl")))
164 (defun cmp-print-start-message (form)
165 (when *compile-print
*
166 (let ((*print-level
* 2)
168 (format t
"~&; compiling ~s ... " form
)
171 (defun cmp-print-end-message ()
172 (when *compile-print
*
176 (defun expand-one (e)
179 (if (member (first e
) '(progn macrolet eval-when
)) (return e
))
180 (multiple-value-bind (ee flag
) (cmp-macroexpand-1 e
)
185 ;;**** %set-cmp-macro???
186 (defun compile-one (e compile-time-too stream
)
189 (setq e
(expand-one e
))
191 (progn (dolist (e (rest e
)) (compile-one e compile-time-too stream
)))
193 (let ((macs (second e
))
194 (env (list nil
*cmp-fenv
* *cmp-macros
* *cmp-global-macros
*))
196 (body (rest (rest e
)))
197 (*cmp-fenv
* *cmp-fenv
*))
202 (parse-macro (first m
) (second m
) (rest (rest m
)) env
)))
204 (dolist (x frame
) (push x
*cmp-fenv
*))
205 (compile-one `(progn ,@body
) compile-time-too stream
)))
207 (let* ((sits (second e
))
208 (body `(progn ,@(rest (rest e
))))
209 (lt (or (member 'load sits
) (member :load-toplevel sits
)))
210 (ct (or (member 'compile sits
) (member :compile-toplevel sits
)))
211 (ex (or (member 'eval sits
) (member :execute sits
))))
214 (and lt
(not ct
) ex compile-time-too
))
215 (compile-one body t stream
))
216 ((or (and lt
(not ct
) (not compile-time-too
))
217 (and lt
(not ct
) (not ex
)))
218 (compile-one body nil stream
))
219 ((or (and (not lt
) ct
)
220 (and (not lt
) (not ct
) ex compile-time-too
))
222 (t (if compile-time-too
(eval e
))
223 (compile-form e stream
))))
225 (format *error-output
* "~&Compiler error: ~a~%" c
)
226 ;;****(format stream "~&;;**** Error compiling exression:~%")
227 (compile-form `(eval ',e
) stream
))))
229 ;;**** could ignore top level atoms, (function ...) expressions
230 (defun compile-form (e outstuff
)
234 (eq (first e
) 'function
)
236 (eq (first (second e
)) 'lambda
))
237 ;;**** should be put in quote?
238 `(byte-code-close (quote ,(assemble (cmp (second e
))))))
245 (not (assoc f
*cmp-fenv
*))
246 (not (assoc f
*cmp-macros
*))
247 (not (assoc f
*cmp-global-macros
*))
249 (functionp (symbol-function f
)))
250 `(,(first e
) ,@(mapcar #'cmparg
(rest e
)))
255 ;;**** don't need the test -- top level (function ...) 's are not done
256 (accumulate-compiled-form
257 (if (typep ce
'byte-code
) ce
(assemble (cmp ce
)))
258 ;(if (typep ce 'byte-code) ce (assemble (cmp `(eval ',ce))))
261 (format *error-output
* "~&Compiler error: ~a~%" c
)
262 (accumulate-compiled-form (assemble (cmp `(eval ',e
)))
267 (defun compile-form (e outstuff
)
268 (accumulate-compiled-form (assemble (cmp e
)) outstuff
))
271 (defun print-fsl-version-check (out sp
)
272 (let ((major xlisp
::*fsl-major-version
*)
273 (minor xlisp
::*fsl-minor-version
*))
274 (print-compiled-form `(xlisp::check-fsl-version
,major
,minor
) out sp
)))
276 ;;**** need to avoid creating bad .fsl file
277 (defun compile-file (file &key
278 (output-file (merge-pathnames ".fsl" file
))
279 (temporary-file (merge-pathnames "cmptmp.fsl" file
))
281 ((:print
*compile-print
*) *compile-print
*)
282 ((:verbose
*compile-verbose
*) *compile-verbose
*)
283 ((:print-symbol-package sp
) ;;**** do this cleaner
284 *compile-print-symbol-package
*))
285 (let* ((*package
* *package
*)
286 (*readtable
* *readtable
*)
291 (iname (merge-pathnames ".lsp" file
)))
292 (with-open-file (in iname
)
293 (with-open-file (out temporary-file
:direction
:output
)
294 (when *compile-verbose
*
295 (format t
"~&; compiling file ~s~%" iname
)
297 (print-fsl-version-check out sp
)
298 (let ((eof (list 'eof
)))
299 (do ((e (read in nil eof
) (read in nil eof
)))
301 (let ((outstuff (list 'progn
)))
302 (cmp-print-start-message e
)
303 (let ((*cmp-fenv
* nil
))
304 (compile-one e nil outstuff
))
305 (cmp-print-end-message)
306 ;; this insures that a single expression is printed for
307 ;; each expression read -- so common literals can be
308 ;; handled by circle printing/reading.
309 (case (length outstuff
)
311 (2 (print-compiled-form (second outstuff
) out sp
))
312 (t (print-compiled-form (assemble (cmp `(eval ',outstuff
)))
315 (rename-file temporary-file output-file
)
316 (if load
(load output-file
))))
318 ;;**** this doesn't currently work for compiling macros
319 (defun compile-lambda-expression (fun name env macrop
)
320 (when env
(error "COMPILE can only compile top level definitions"))
321 (let ((*cmp-specials
* nil
)
326 (let* ((fun (if macrop
(cons 'lambda
(rest fun
)) fun
))
327 (cfun (byte-code-close (assemble (cmp fun name
)))))
328 (if macrop
(coerce-to-macro cfun
) cfun
))))
330 (defun compile-return (f cfun
)
332 (xlisp::install-function f cfun
)
335 (defun compile (f &optional
(fun (symbol-function f
)))
337 ((or (typep fun
'subr
) (typep fun
'fsubr
) (compiled-function-p fun
))
338 (compile-return f fun
))
339 ((typep fun
'closure
)
340 (multiple-value-bind (flam top fname
) (function-lambda-expression fun
)
341 (let ((name (if f f fname
))
342 (macrop (eq (first flam
) 'macro
)))
343 (compile-return f
(compile-lambda-expression flam name top macrop
)))))
344 ((and (consp fun
) (eq (first fun
) 'lambda
))
345 (compile-return f
(compile-lambda-expression fun f nil nil
)))
346 (t (error "bad argument type -- ~s" fun
))))