Changeset 13810
- Timestamp:
- 01/25/12 21:24:06 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r13792 r13810 4089 4089 (let ((*current-compiland* compiland)) 4090 4090 (with-saved-compiler-policy 4091 ( p2-compilandcompiland)4091 (compile-to-jvm-class compiland) 4092 4092 (finish-class (compiland-class-file compiland) f))))) 4093 4093 (when stream … … 6973 6973 6974 6974 6975 ;; Returns a list with the types of the arguments6976 (defun analyze-args (compiland)6977 (let* ((args (cadr (compiland-p1-result compiland)))6978 (arg-count (length args)))6979 (dformat t "analyze-args args = ~S~%" args)6980 (aver (not (memq '&AUX args)))6981 6982 (when (or (memq '&KEY args)6983 (memq '&OPTIONAL args)6984 (memq '&REST args))6985 (setf *using-arg-array* t6986 *hairy-arglist-p* t)6987 (return-from analyze-args (list +lisp-object-array+)))6988 6989 (cond ((<= arg-count call-registers-limit)6990 (lisp-object-arg-types arg-count))6991 (t (setf *using-arg-array* t)6992 (setf (compiland-arity compiland) arg-count)6993 (list +lisp-object-array+)))))6994 6995 6975 (defmacro with-open-class-file ((var class-file) &body body) 6996 6976 `(with-open-file (,var (abcl-class-file-pathname ,class-file) … … 7050 7030 (symbol-name (gensym "LFUN")))) 7051 7031 7032 7033 7052 7034 (defknown p2-compiland (t) t) 7053 (defun p2-compiland (compiland )7035 (defun p2-compiland (compiland method) 7054 7036 (let* ((p1-result (compiland-p1-result compiland)) 7055 7037 (class-file (compiland-class-file compiland)) … … 7061 7043 (find compiland *closure-variables* :key #'variable-compiland)) 7062 7044 (body (cddr p1-result)) 7063 (*using-arg-array* nil)7064 (*hairy-arglist-p* nil)7065 ;; *hairy-arglist-p* != NIL --> *using-arglist-array* != NIL7066 7045 7067 7046 (*child-p* (not (null (compiland-parent compiland)))) 7068 7047 7069 (arg-types (analyze-args compiland))7070 (method (make-jvm-method "execute" +lisp-object+ arg-types7071 :flags '(:final :public)))7072 7048 (*visible-variables* *visible-variables*) 7073 7049 7074 7050 (*thread* nil) 7075 7051 (*initialize-thread-var* nil)) 7076 7077 (class-add-method class-file method)7078 7079 (setf (abcl-class-file-superclass class-file)7080 (if (or *hairy-arglist-p*7081 (and *child-p* *closure-variables*))7082 +lisp-compiled-closure+7083 +lisp-compiled-primitive+))7084 7085 (let ((constructor7086 (make-constructor class-file (compiland-name compiland) args)))7087 (setf (abcl-class-file-constructor class-file) constructor)7088 (class-add-method class-file constructor))7089 (let ((clinit (make-static-initializer class-file)))7090 (setf (abcl-class-file-static-initializer class-file) clinit)7091 (class-add-method class-file clinit))7092 7052 7093 7053 (with-code-to-method (class-file method) … … 7256 7216 (setf *code* ()) 7257 7217 (let ((arity (compiland-arity compiland))) 7258 (when arity 7218 (when (and arity 7219 *using-arg-array*) 7259 7220 (generate-arg-count-check arity))) 7260 7221 7261 7222 (when *hairy-arglist-p* 7262 (aload 0) ; this7223 (aload 0) ; this 7263 7224 (aver (not (null (compiland-argument-register compiland)))) 7264 7225 (aload (compiland-argument-register compiland)) ; arg vector … … 7283 7244 t) 7284 7245 7246 (defun compile-to-jvm-class (compiland) 7247 "Returns ?what? ### a jvm class-file object?" 7248 (let* ((class-file (compiland-class-file compiland)) 7249 (args (cadr (compiland-p1-result compiland))) 7250 (*hairy-arglist-p* (or (memq '&KEY args) 7251 (memq '&OPTIONAL args) 7252 (memq '&REST args))) 7253 (*using-arg-array* (or *hairy-arglist-p* 7254 (< call-registers-limit (length args))))) 7255 (setf (abcl-class-file-superclass class-file) 7256 (if (or *hairy-arglist-p* 7257 (and (not (null (compiland-parent compiland))) 7258 *closure-variables*)) 7259 +lisp-compiled-closure+ 7260 +lisp-compiled-primitive+)) 7261 (unless *hairy-arglist-p* 7262 (setf (compiland-arity compiland) 7263 (length args))) 7264 7265 ;; Static initializer 7266 (let ((clinit (make-static-initializer class-file))) 7267 (setf (abcl-class-file-static-initializer class-file) clinit) 7268 (class-add-method class-file clinit)) 7269 7270 ;; Constructor 7271 (let ((constructor 7272 (make-constructor class-file (compiland-name compiland) args))) 7273 (setf (abcl-class-file-constructor class-file) constructor) 7274 (class-add-method class-file constructor)) 7275 7276 ;; Main method 7277 (let* ((method-arg-types (if *using-arg-array* 7278 (list +lisp-object-array+) 7279 (lisp-object-arg-types (length args)))) 7280 (method (make-jvm-method "execute" +lisp-object+ method-arg-types 7281 :flags '(:final :public)))) 7282 (class-add-method class-file method) 7283 (p2-compiland compiland method)))) 7284 7285 7285 (defun p2-with-inline-code (form target representation) 7286 7286 ;;form = (with-inline-code (&optional target-var repr-var) ...body...) … … 7326 7326 (with-class-file (compiland-class-file compiland) 7327 7327 (with-saved-compiler-policy 7328 ( p2-compilandcompiland)7328 (compile-to-jvm-class compiland) 7329 7329 ;; (finalize-class-file (compiland-class-file compiland)) 7330 7330 (finish-class (compiland-class-file compiland) stream)))))
Note: See TracChangeset
for help on using the changeset viewer.