Changeset 11843
- Timestamp:
- 05/08/09 21:09:09 (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
r11841 r11843 100 100 (declaim (ftype (function (t stream t) t) process-toplevel-form)) 101 101 (defun process-toplevel-form (form stream compile-time-too) 102 (cond ((atom form) 103 (when compile-time-too 104 (eval form))) 105 (t 106 (let ((operator (%car form))) 107 (case operator 108 (MACROLET 109 (process-toplevel-macrolet form stream compile-time-too) 110 (return-from process-toplevel-form)) 111 ((IN-PACKAGE DEFPACKAGE) 112 (note-toplevel-form form) 113 (setf form (precompile-form form nil)) 114 (eval form) 115 ;; Force package prefix to be used when dumping form. 116 (let ((*package* +keyword-package+)) 117 (dump-form form stream)) 118 (%stream-terpri stream) 119 (return-from process-toplevel-form)) 120 ((DEFVAR DEFPARAMETER) 121 (note-toplevel-form form) 122 (if compile-time-too 123 (eval form) 124 ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, 125 ;; the compiler must recognize that the name has been proclaimed 126 ;; special. However, it must neither evaluate the initial-value 127 ;; form nor assign the dynamic variable named NAME at compile 128 ;; time." 129 (let ((name (second form))) 130 (%defvar name)))) 131 (DEFCONSTANT 132 (note-toplevel-form form) 133 (process-defconstant form stream) 134 (return-from process-toplevel-form)) 135 (DEFUN 136 (note-toplevel-form form) 137 (let* ((name (second form)) 138 (block-name (fdefinition-block-name name)) 139 (lambda-list (third form)) 140 (body (nthcdr 3 form)) 141 (*speed* *speed*) 142 (*space* *space*) 143 (*safety* *safety*) 144 (*debug* *debug*)) 145 (multiple-value-bind (body decls doc) 146 (parse-body body) 147 (let* ((expr `(lambda ,lambda-list ,@decls (block ,block-name ,@body))) 148 (classfile-name (next-classfile-name)) 149 (classfile (report-error 150 (jvm:compile-defun name expr nil classfile-name))) 151 (compiled-function (verify-load classfile))) 152 (cond (compiled-function 153 (setf form 154 `(fset ',name 155 (load-compiled-function ,(file-namestring classfile)) 156 ,*source-position* 157 ',lambda-list 158 ,doc)) 159 (when compile-time-too 160 (fset name compiled-function))) 161 (t 162 ;; FIXME This should be a warning or error of some sort... 163 (format *error-output* "; Unable to compile function ~A~%" name) 164 (let ((precompiled-function (precompile-form expr nil))) 165 (setf form 166 `(fset ',name 167 ,precompiled-function 168 ,*source-position* 169 ',lambda-list 170 ,doc))) 171 (when compile-time-too 172 (eval form))))) 173 (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) 174 ;; FIXME Need to support SETF functions too! 175 (setf (inline-expansion name) 176 (jvm::generate-inline-expansion block-name lambda-list body)) 177 (dump-form `(setf (inline-expansion ',name) ',(inline-expansion name)) 178 stream) 179 (%stream-terpri stream))) 180 (push name jvm::*functions-defined-in-current-file*) 181 (note-name-defined name) 182 ;; If NAME is not fbound, provide a dummy definition so that 183 ;; getSymbolFunctionOrDie() will succeed when we try to verify that 184 ;; functions defined later in the same file can be loaded correctly. 185 (unless (fboundp name) 186 (setf (fdefinition name) #'dummy) 187 (push name *fbound-names*)))) 188 ((DEFGENERIC DEFMETHOD) 189 (note-toplevel-form form) 190 (note-name-defined (second form)) 191 (let ((*compile-print* nil)) 192 (process-toplevel-form (macroexpand-1 form *compile-file-environment*) 193 stream compile-time-too)) 194 (return-from process-toplevel-form)) 195 (DEFMACRO 196 (note-toplevel-form form) 197 (let ((name (second form))) 198 (eval form) 199 (let* ((expr (function-lambda-expression (macro-function name))) 200 (classfile-name (next-classfile-name)) 201 (classfile 202 (ignore-errors 203 (jvm:compile-defun nil expr nil classfile-name)))) 204 (if (verify-load classfile) 205 (progn 206 (setf form 207 (if (special-operator-p name) 208 `(put ',name 'macroexpand-macro 209 (make-macro ',name 210 (load-compiled-function 211 ,(file-namestring classfile)))) 212 `(fset ',name 213 (make-macro ',name 214 (load-compiled-function 215 ,(file-namestring classfile))) 216 ,*source-position* 217 ',(third form))))) 218 ;; FIXME error or warning 219 (format *error-output* "; Unable to compile macro ~A~%" name))))) 220 (DEFTYPE 221 (note-toplevel-form form) 222 (eval form)) 223 (EVAL-WHEN 224 (multiple-value-bind (ct lt e) 225 (parse-eval-when-situations (cadr form)) 226 (let ((new-compile-time-too (or ct 227 (and compile-time-too e))) 228 (body (cddr form))) 229 (cond (lt 230 (process-toplevel-progn body stream new-compile-time-too)) 231 (new-compile-time-too 232 (eval `(progn ,@body))))) 233 (return-from process-toplevel-form))) 234 (LOCALLY 235 ;; FIXME Need to handle special declarations too! 236 (let ((*speed* *speed*) 237 (*safety* *safety*) 238 (*debug* *debug*) 239 (*space* *space*) 240 (*inline-declarations* *inline-declarations*)) 241 (multiple-value-bind (forms decls) 242 (parse-body (cdr form) nil) 243 (process-optimization-declarations decls) 244 (process-toplevel-progn forms stream compile-time-too) 245 (return-from process-toplevel-form)))) 246 (PROGN 247 (process-toplevel-progn (cdr form) stream compile-time-too) 248 (return-from process-toplevel-form)) 249 (DECLARE 250 (compiler-style-warn "Misplaced declaration: ~S" form)) 251 (t 252 (when (and (symbolp operator) 253 (macro-function operator *compile-file-environment*)) 254 (note-toplevel-form form) 255 ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in 256 ;; case the form being expanded expands into something that needs 257 ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). 258 (let ((*compile-print* nil)) 259 (process-toplevel-form (macroexpand-1 form *compile-file-environment*) 260 stream compile-time-too)) 261 (return-from process-toplevel-form)) 262 263 (cond ((eq operator 'QUOTE) 264 ;; (setf form (precompile-form form nil)) 265 (when compile-time-too 266 (eval form)) 267 (return-from process-toplevel-form) 268 ) 269 ((eq operator 'PUT) 270 (setf form (precompile-form form nil))) 271 ((eq operator 'COMPILER-DEFSTRUCT) 272 (setf form (precompile-form form nil))) 273 ((eq operator 'PROCLAIM) 274 (setf form (precompile-form form nil))) 275 ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) 276 (or (keywordp (second form)) 277 (and (listp (second form)) 278 (eq (first (second form)) 'QUOTE)))) 279 (setf form (precompile-form form nil))) 280 ((eq operator 'IMPORT) 281 (setf form (precompile-form form nil)) 282 ;; Make sure package prefix is printed when symbols are imported. 283 (let ((*package* +keyword-package+)) 284 (dump-form form stream)) 285 (%stream-terpri stream) 286 (when compile-time-too 287 (eval form)) 288 (return-from process-toplevel-form)) 289 ((and (eq operator '%SET-FDEFINITION) 290 (eq (car (second form)) 'QUOTE) 291 (consp (third form)) 292 (eq (%car (third form)) 'FUNCTION) 293 (symbolp (cadr (third form)))) 294 (setf form (precompile-form form nil))) 295 ;; ((memq operator '(LET LET*)) 296 ;; (let ((body (cddr form))) 297 ;; (if (dolist (subform body nil) 298 ;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) 299 ;; (return t))) 300 ;; (setf form (convert-toplevel-form form)) 301 ;; (setf form (precompile-form form nil))))) 302 ((eq operator 'mop::ensure-method) 303 (setf form (convert-ensure-method form))) 304 ((and (symbolp operator) 305 (not (special-operator-p operator)) 306 (null (cdr form))) 307 (setf form (precompile-form form nil))) 308 (t 309 ;; (setf form (precompile-form form nil)) 310 (note-toplevel-form form) 311 (setf form (convert-toplevel-form form)) 312 ))))))) 102 (if (atom form) 103 (when compile-time-too 104 (eval form)) 105 (progn 106 (let ((operator (%car form))) 107 (case operator 108 (MACROLET 109 (process-toplevel-macrolet form stream compile-time-too) 110 (return-from process-toplevel-form)) 111 ((IN-PACKAGE DEFPACKAGE) 112 (note-toplevel-form form) 113 (setf form (precompile-form form nil)) 114 (eval form) 115 ;; Force package prefix to be used when dumping form. 116 (let ((*package* +keyword-package+)) 117 (dump-form form stream)) 118 (%stream-terpri stream) 119 (return-from process-toplevel-form)) 120 ((DEFVAR DEFPARAMETER) 121 (note-toplevel-form form) 122 (if compile-time-too 123 (eval form) 124 ;; "If a DEFVAR or DEFPARAMETER form appears as a top level form, 125 ;; the compiler must recognize that the name has been proclaimed 126 ;; special. However, it must neither evaluate the initial-value 127 ;; form nor assign the dynamic variable named NAME at compile 128 ;; time." 129 (let ((name (second form))) 130 (%defvar name)))) 131 (DEFCONSTANT 132 (note-toplevel-form form) 133 (process-defconstant form stream) 134 (return-from process-toplevel-form)) 135 (DEFUN 136 (note-toplevel-form form) 137 (let* ((name (second form)) 138 (block-name (fdefinition-block-name name)) 139 (lambda-list (third form)) 140 (body (nthcdr 3 form)) 141 (*speed* *speed*) 142 (*space* *space*) 143 (*safety* *safety*) 144 (*debug* *debug*)) 145 (multiple-value-bind (body decls doc) 146 (parse-body body) 147 (let* ((expr `(lambda ,lambda-list 148 ,@decls (block ,block-name ,@body))) 149 (classfile-name (next-classfile-name)) 150 (classfile (report-error 151 (jvm:compile-defun name expr nil 152 classfile-name))) 153 (compiled-function (verify-load classfile))) 154 (cond 155 (compiled-function 156 (setf form 157 `(fset ',name 158 (load-compiled-function ,(file-namestring classfile)) 159 ,*source-position* 160 ',lambda-list 161 ,doc)) 162 (when compile-time-too 163 (fset name compiled-function))) 164 (t 165 ;; FIXME Should be a warning or error of some sort... 166 (format *error-output* 167 "; Unable to compile function ~A~%" name) 168 (let ((precompiled-function (precompile-form expr nil))) 169 (setf form 170 `(fset ',name 171 ,precompiled-function 172 ,*source-position* 173 ',lambda-list 174 ,doc))) 175 (when compile-time-too 176 (eval form))))) 177 (when (and (symbolp name) (eq (get name '%inline) 'INLINE)) 178 ;; FIXME Need to support SETF functions too! 179 (setf (inline-expansion name) 180 (jvm::generate-inline-expansion block-name 181 lambda-list body)) 182 (dump-form `(setf (inline-expansion ',name) 183 ',(inline-expansion name)) 184 stream) 185 (%stream-terpri stream))) 186 (push name jvm::*functions-defined-in-current-file*) 187 (note-name-defined name) 188 ;; If NAME is not fbound, provide a dummy definition so that 189 ;; getSymbolFunctionOrDie() will succeed when we try to verify that 190 ;; functions defined later in the same file can be loaded correctly. 191 (unless (fboundp name) 192 (setf (fdefinition name) #'dummy) 193 (push name *fbound-names*)))) 194 ((DEFGENERIC DEFMETHOD) 195 (note-toplevel-form form) 196 (note-name-defined (second form)) 197 (let ((*compile-print* nil)) 198 (process-toplevel-form (macroexpand-1 form *compile-file-environment*) 199 stream compile-time-too)) 200 (return-from process-toplevel-form)) 201 (DEFMACRO 202 (note-toplevel-form form) 203 (let ((name (second form))) 204 (eval form) 205 (let* ((expr (function-lambda-expression (macro-function name))) 206 (classfile-name (next-classfile-name)) 207 (classfile 208 (ignore-errors 209 (jvm:compile-defun nil expr nil classfile-name)))) 210 (if (null (verify-load classfile)) 211 ;; FIXME error or warning 212 (format *error-output* "; Unable to compile macro ~A~%" name) 213 (progn 214 (setf form 215 (if (special-operator-p name) 216 `(put ',name 'macroexpand-macro 217 (make-macro ',name 218 (load-compiled-function 219 ,(file-namestring classfile)))) 220 `(fset ',name 221 (make-macro ',name 222 (load-compiled-function 223 ,(file-namestring classfile))) 224 ,*source-position* 225 ',(third form))))))))) 226 (DEFTYPE 227 (note-toplevel-form form) 228 (eval form)) 229 (EVAL-WHEN 230 (multiple-value-bind (ct lt e) 231 (parse-eval-when-situations (cadr form)) 232 (let ((new-compile-time-too (or ct (and compile-time-too e))) 233 (body (cddr form))) 234 (if lt 235 (process-toplevel-progn body stream new-compile-time-too) 236 (when new-compile-time-too 237 (eval `(progn ,@body))))) 238 (return-from process-toplevel-form))) 239 (LOCALLY 240 ;; FIXME Need to handle special declarations too! 241 (let ((*speed* *speed*) 242 (*safety* *safety*) 243 (*debug* *debug*) 244 (*space* *space*) 245 (*inline-declarations* *inline-declarations*)) 246 (multiple-value-bind (forms decls) 247 (parse-body (cdr form) nil) 248 (process-optimization-declarations decls) 249 (process-toplevel-progn forms stream compile-time-too) 250 (return-from process-toplevel-form)))) 251 (PROGN 252 (process-toplevel-progn (cdr form) stream compile-time-too) 253 (return-from process-toplevel-form)) 254 (DECLARE 255 (compiler-style-warn "Misplaced declaration: ~S" form)) 256 (t 257 (when (and (symbolp operator) 258 (macro-function operator *compile-file-environment*)) 259 (note-toplevel-form form) 260 ;; Note that we want MACROEXPAND-1 and not MACROEXPAND here, in 261 ;; case the form being expanded expands into something that needs 262 ;; special handling by PROCESS-TOPLEVEL-FORM (e.g. DEFMACRO). 263 (let ((*compile-print* nil)) 264 (process-toplevel-form (macroexpand-1 form *compile-file-environment*) 265 stream compile-time-too)) 266 (return-from process-toplevel-form)) 267 268 (cond ((eq operator 'QUOTE) 269 ;;; (setf form (precompile-form form nil)) 270 (when compile-time-too 271 (eval form)) 272 (return-from process-toplevel-form)) 273 ((eq operator 'PUT) 274 (setf form (precompile-form form nil))) 275 ((eq operator 'COMPILER-DEFSTRUCT) 276 (setf form (precompile-form form nil))) 277 ((eq operator 'PROCLAIM) 278 (setf form (precompile-form form nil))) 279 ((and (memq operator '(EXPORT REQUIRE PROVIDE SHADOW)) 280 (or (keywordp (second form)) 281 (and (listp (second form)) 282 (eq (first (second form)) 'QUOTE)))) 283 (setf form (precompile-form form nil))) 284 ((eq operator 'IMPORT) 285 (setf form (precompile-form form nil)) 286 ;; Make sure package prefix is printed when symbols are imported. 287 (let ((*package* +keyword-package+)) 288 (dump-form form stream)) 289 (%stream-terpri stream) 290 (when compile-time-too 291 (eval form)) 292 (return-from process-toplevel-form)) 293 ((and (eq operator '%SET-FDEFINITION) 294 (eq (car (second form)) 'QUOTE) 295 (consp (third form)) 296 (eq (%car (third form)) 'FUNCTION) 297 (symbolp (cadr (third form)))) 298 (setf form (precompile-form form nil))) 299 ;;; ((memq operator '(LET LET*)) 300 ;;; (let ((body (cddr form))) 301 ;;; (if (dolist (subform body nil) 302 ;;; (when (and (consp subform) (eq (%car subform) 'DEFUN)) 303 ;;; (return t))) 304 ;;; (setf form (convert-toplevel-form form)) 305 ;;; (setf form (precompile-form form nil))))) 306 ((eq operator 'mop::ensure-method) 307 (setf form (convert-ensure-method form))) 308 ((and (symbolp operator) 309 (not (special-operator-p operator)) 310 (null (cdr form))) 311 (setf form (precompile-form form nil))) 312 (t 313 ;;; (setf form (precompile-form form nil)) 314 (note-toplevel-form form) 315 (setf form (convert-toplevel-form form))))))))) 313 316 (when (consp form) 314 317 (dump-form form stream)
Note: See TracChangeset
for help on using the changeset viewer.
