Changeset 8384
- Timestamp:
- 01/22/05 12:26:21 (16 years ago)
- File:
-
- 1 edited
-
trunk/j/src/org/armedbear/lisp/jvm.lisp (modified) (14 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/j/src/org/armedbear/lisp/jvm.lisp
r8378 r8384 2 2 ;;; 3 3 ;;; Copyright (C) 2003-2005 Peter Graves 4 ;;; $Id: jvm.lisp,v 1.36 1 2005-01-21 03:27:43piso Exp $4 ;;; $Id: jvm.lisp,v 1.362 2005-01-22 12:26:21 piso Exp $ 5 5 ;;; 6 6 ;;; This program is free software; you can redistribute it and/or … … 80 80 parent 81 81 (children 0) ; Number of local functions defined with FLET or LABELS. 82 contains-lambda83 82 argument-register 84 83 closure-register … … 874 873 (defconstant +lisp-go-class+ "org/armedbear/lisp/Go") 875 874 (defconstant +lisp-ctf-class+ "org/armedbear/lisp/ClosureTemplateFunction") 875 (defconstant +lisp-compiled-function-class+ "org/armedbear/lisp/CompiledFunction") 876 (defconstant +lisp-primitive-class+ "org/armedbear/lisp/Primitive") 876 877 877 878 (defsubst emit-push-nil () … … 3957 3958 (cond (*compile-file-truename* 3958 3959 ;; Verify that the class file is loadable. 3959 ( unless (ignore-errors (sys:load-compiled-functionclassfile))3960 ( error "P2-LOCAL-FUNCTION: unable to load ~S." classfile)))3961 (t3962 (setf function (sys:load-compiled-function classfile))))3960 (let ((*default-pathname-defaults* classfile)) 3961 (unless (ignore-errors (sys:load-compiled-function classfile)) 3962 (error "P2-LOCAL-FUNCTION: unable to load ~S." classfile)))) 3963 (t (setf function (sys:load-compiled-function classfile)))) 3963 3964 (cond (local-function 3964 3965 (setf (local-function-classfile local-function) classfile) … … 3971 3972 +lisp-object+) 3972 3973 (emit 'var-set (local-function-variable local-function)))) 3973 (t 3974 (push (make-local-function :name name 3975 :function function 3976 :classfile classfile) 3977 *local-functions*))))) 3974 (t (push (make-local-function :name name 3975 :function function 3976 :classfile classfile) 3977 *local-functions*))))) 3978 3978 3979 3979 (defun p2-flet (form &key (target *val*) representation) … … 5021 5021 (return-from analyze-args 5022 5022 (if *closure-variables* 5023 #.(%format nil "([~A[~A)~A" +lisp-object+ +lisp-object+ +lisp-object+) 5024 #.(%format nil "([~A)~A" +lisp-object+ +lisp-object+)))) 5023 (make-descriptor (list +lisp-object-array+ +lisp-object-array+) 5024 +lisp-object+) 5025 (make-descriptor (list +lisp-object-array+) 5026 +lisp-object+)))) 5025 5027 (cond 5026 5028 (*closure-variables* … … 5030 5032 (make-list arg-count :initial-element +lisp-object+)) 5031 5033 +lisp-object+)) 5032 (t 5033 ;; (error "analyze-args unsupported case") 5034 (setf *using-arg-array* t) 5035 (setf *arity* arg-count) 5036 (make-descriptor (list +lisp-object-array+ +lisp-object-array+) 5037 +lisp-object+) 5038 )))) 5034 (t (setf *using-arg-array* t) 5035 (setf *arity* arg-count) 5036 (make-descriptor (list +lisp-object-array+ +lisp-object-array+) 5037 +lisp-object+))))) 5039 5038 (t 5040 5039 (return-from analyze-args … … 5042 5041 (make-descriptor (make-list arg-count :initial-element +lisp-object+) 5043 5042 +lisp-object+)) 5044 (t 5045 (setf *using-arg-array* t) 5046 (setf *arity* arg-count) 5047 (make-descriptor (list +lisp-object-array+) +lisp-object+))) 5048 )))) 5049 5050 5043 (t (setf *using-arg-array* t) 5044 (setf *arity* arg-count) 5045 (make-descriptor (list +lisp-object-array+) 5046 +lisp-object+))))))) 5051 5047 (when (or (memq '&KEY args) 5052 5048 (memq '&OPTIONAL args) … … 5056 5052 (return-from analyze-args 5057 5053 (make-descriptor (list +lisp-object-array+) +lisp-object+))) 5058 5059 5054 (cond ((<= arg-count 4) 5060 5055 (make-descriptor (make-list (length args) :initial-element +lisp-object+) … … 5063 5058 (setf *using-arg-array* t) 5064 5059 (setf *arity* arg-count) 5065 (make-descriptor (list +lisp-object-array+) +lisp-object+))) 5066 5067 )) 5060 (make-descriptor (list +lisp-object-array+) +lisp-object+))))) 5068 5061 5069 5062 (defun write-class-file (args body execute-method classfile) 5070 5063 (dformat t "write-class-file ~S~%" classfile) 5071 (let* ((super 5072 (cond (*child-p* 5073 (dformat t "write-class-file *child-p* case~%") 5074 (dformat t "*closure-variables* = ~S~%" (mapcar #'variable-name *closure-variables*)) 5075 (dformat t "args = ~S~%" args) 5076 (dformat t "*hairy-arglist-p* = ~S~%" *hairy-arglist-p*) 5077 (if *closure-variables* 5078 "org/armedbear/lisp/ClosureTemplateFunction" 5079 (if *hairy-arglist-p* 5080 "org/armedbear/lisp/CompiledFunction" 5081 "org/armedbear/lisp/Primitive"))) 5082 (*hairy-arglist-p* 5083 "org/armedbear/lisp/CompiledFunction") 5084 (t 5085 "org/armedbear/lisp/Primitive"))) 5064 (let* ((super (cond (*child-p* 5065 (if *closure-variables* 5066 "org/armedbear/lisp/ClosureTemplateFunction" 5067 (if *hairy-arglist-p* 5068 +lisp-compiled-function-class+ 5069 +lisp-primitive-class+))) 5070 (*hairy-arglist-p* +lisp-compiled-function-class+) 5071 (t +lisp-primitive-class+))) 5086 5072 (this-index (pool-class *this-class*)) 5087 5073 (super-index (pool-class super)) … … 5134 5120 5135 5121 5122 #+nil 5123 (unless (or (memq '&KEY lambda-list) (memq '&REST lambda-list)) 5124 (let ((optionals (memq '&OPTIONAL lambda-list))) 5125 (dformat t "optionals = ~S~%" optionals) 5126 (when (= (length optionals) 2) 5127 (let* ((optional-arg (second optionals)) 5128 (name (if (consp optional-arg) (car optional-arg) optional-arg)) 5129 (initform (if (consp optional-arg) (cadr optional-arg) nil)) 5130 (wrapper-args (subseq lambda-list 0 (position '&OPTIONAL lambda-list))) 5131 (converted-args (append wrapper-args (list name)))) 5132 (dformat t "optional-arg = ~S~%" optional-arg) 5133 (dformat t "wrapper-args = ~S~%" wrapper-args) 5134 (dformat t "converted-args = ~S~%" converted-args) 5135 (let ((wrapper-form 5136 `(lambda ,wrapper-args 5137 (let ((,name ,initform)) 5138 (,(compiland-name compiland) ,@converted-args))))) 5139 (dformat t "wrapper-form = ~S~%" wrapper-form) 5140 ) 5141 )))) 5142 5143 5136 5144 (let* ((closure (sys::make-closure `(lambda ,lambda-list nil) nil)) 5137 5145 (syms (sys::varlist closure)) … … 5151 5159 (mapcar #'variable-name *visible-variables*)) 5152 5160 (setf (compiland-p1-result compiland) 5153 ;; (list* 'LAMBDA lambda-list (mapcar #'p1 (cddr form))) 5154 (list* 'LAMBDA lambda-list (mapcar #'p1 body)) 5155 ;; (p1 form) 5156 )))))) 5161 (list* 'LAMBDA lambda-list (mapcar #'p1 body)))))))) 5157 5162 5158 5163 (defun p2-compiland (compiland) … … 5213 5218 (dformat t "pass2 *using-arg-array* = ~S~%" *using-arg-array*) 5214 5219 (dformat t "pass2 *child-p* = ~S~%" *child-p*) 5220 (dformat t "pass2 *closure-variables* = ~S~%" 5221 (mapcar #'variable-name *closure-variables*)) 5215 5222 (setf (method-name-index execute-method) 5216 5223 (pool-name (method-name execute-method))) … … 5456 5463 (dformat t "compile-1 ~S~%" (compiland-name compiland)) 5457 5464 (let ((*all-variables* ()) 5465 (*closure-variables* ()) 5458 5466 (*current-compiland* compiland) 5459 5467 (*speed* *speed*)
Note: See TracChangeset
for help on using the changeset viewer.
