Changeset 12630
- Timestamp:
- 04/23/10 21:23:02 (14 years ago)
- Location:
- branches/less-reflection/abcl/src/org/armedbear/lisp
- Files:
-
- 12 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/less-reflection/abcl/src/org/armedbear/lisp/Autoload.java
r12583 r12630 684 684 autoload(Symbol.COPY_LIST, "copy_list"); 685 685 686 autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); 687 autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false); 688 686 689 autoload(Symbol.SET_CHAR, "StringFunctions"); 687 690 autoload(Symbol.SET_SCHAR, "StringFunctions"); -
branches/less-reflection/abcl/src/org/armedbear/lisp/Lisp.java
r12607 r12630 2363 2363 internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL); 2364 2364 2365 // ### *fasl-loader* 2366 public static final Symbol _FASL_LOADER_ = 2367 exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL); 2368 2365 2369 // ### *source* 2366 2370 // internal symbol -
branches/less-reflection/abcl/src/org/armedbear/lisp/Load.java
r12607 r12630 279 279 url = Lisp.class.getResource(path); 280 280 if (url == null || url.toString().endsWith("/")) { 281 url = Lisp.class.getResource(path + ".abcl");281 url = Lisp.class.getResource(path.replace('-', '_') + ".abcl"); 282 282 if (url == null) { 283 283 url = Lisp.class.getResource(path + ".lisp"); -
branches/less-reflection/abcl/src/org/armedbear/lisp/compile-file.lisp
r12626 r12630 46 46 "Computes the name of the class file associated with number `n'." 47 47 (let ((name 48 (%format nil "~A-~D" 49 (substitute #\_ #\. 50 (pathname-name output-file-pathname)) n))) 48 (sanitize-class-name 49 (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) 51 50 (namestring (merge-pathnames (make-pathname :name name :type "cls") 52 51 output-file-pathname)))) 52 53 (defun sanitize-class-name (name) 54 (dotimes (i (length name)) 55 (declare (type fixnum i)) 56 (when (or (char= (char name i) #\-) 57 (char= (char name i) #\.) 58 (char= (char name i) #\Space)) 59 (setf (char name i) #\_))) 60 name) 61 53 62 54 63 (declaim (ftype (function () t) next-classfile-name)) … … 70 79 (declaim (ftype (function (t) t) verify-load)) 71 80 (defun verify-load (classfile) 72 (if (> *safety* 0) 73 (and classfile 81 82 #|(if (> *safety* 0) 83 (and classfile 74 84 (let ((*load-truename* *output-file-pathname*)) 75 85 (report-error 76 86 (load-compiled-function classfile)))) 77 t)) 87 t)|# 88 (declare (ignore classfile)) 89 t) 78 90 79 91 (declaim (ftype (function (t) t) process-defconstant)) … … 169 181 (setf form 170 182 `(fset ',name 171 (proxy-preloaded-function ',name ,(file-namestring classfile)) 183 (sys::get-fasl-function *fasl-loader* 184 ,(pathname-name classfile)) 185 ; (proxy-preloaded-function ',name ,(file-namestring classfile)) 172 186 ,*source-position* 173 187 ',lambda-list … … 242 256 `(put ',name 'macroexpand-macro 243 257 (make-macro ',name 244 (proxy-preloaded-function 245 '(macro-function ,name) 246 ,(file-namestring classfile)))) 258 ;(proxy-preloaded-function 259 ; '(macro-function ,name) 260 ; ,(file-namestring classfile)) 261 (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))) 247 262 `(fset ',name 248 263 (make-macro ',name 249 (proxy-preloaded-function 250 '(macro-function ,name) 251 ,(file-namestring classfile))) 264 ;(proxy-preloaded-function 265 ; '(macro-function ,name) 266 ; ,(file-namestring classfile)) 267 (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile))) 252 268 ,*source-position* 253 269 ',(third form))))))))) … … 349 365 ;; was already used in verify-load before I used it, 350 366 ;; however, binding *load-truename* isn't fully compliant, I think. 351 (let ((*load-truename* *output-file-pathname*)) 352 (when compile-time-too 367 (when compile-time-too 368 (let ((*load-truename* *output-file-pathname*) 369 (*fasl-loader* (make-fasl-class-loader))) 353 370 (eval form)))) 354 371 … … 380 397 (cond (compiled-function 381 398 (setf (getf tail key) 382 `(load-compiled-function ,(file-namestring classfile)))) 399 `(sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)))) 400 ;; `(load-compiled-function ,(file-namestring classfile)))) 383 401 (t 384 402 ;; FIXME This should be a warning or error of some sort... … … 426 444 (setf form 427 445 (if compiled-function 428 `(funcall ( load-compiled-function ,(file-namestring classfile)))446 `(funcall (sys::get-fasl-function *fasl-loader* ,(pathname-name classfile)));(load-compiled-function ,(file-namestring classfile))) 429 447 (precompiler:precompile-form form nil *compile-file-environment*))))) 430 448 … … 566 584 (write "; -*- Mode: Lisp -*-" :escape nil :stream out) 567 585 (%stream-terpri out) 568 (let ((*package* (find-package '#:cl)) 569 (count-sym (gensym)))586 (let ((*package* (find-package '#:cl))) 587 ;(count-sym (gensym))) 570 588 (write (list 'init-fasl :version *fasl-version*) 571 589 :stream out) … … 574 592 :stream out) 575 593 (%stream-terpri out) 576 (dump-form `(dotimes (,count-sym ,*class-number*) 594 595 ;;TODO FAKE TEST ONLY!!! 596 (when (> *class-number* 0) 597 (write (list 'setq '*fasl-loader* 598 '(sys::make-fasl-class-loader)) :stream out) 599 (%stream-terpri out)) 600 #| (dump-form 601 `(dotimes (,count-sym ,*class-number*) 602 (java:jcall "loadFunction" *fasl-loader* 603 (%format nil "~A_~D" 604 ,(sanitize-class-name 605 (pathname-name output-file)) 606 (1+ ,count-sym)))) 607 out)|# 608 609 ;;END TODO 610 611 #| (dump-form `(dotimes (,count-sym ,*class-number*) 577 612 (function-preload 578 (%format nil "~A-~D.cls" 579 ,(substitute #\_ #\. (pathname-name output-file)) 580 (1+ ,count-sym)))) out) 613 (%format nil "~A_~D.cls" 614 ,(sanitize-class-name 615 (pathname-name output-file)) 616 (1+ ,count-sym)))) 617 out)|# 581 618 (%stream-terpri out)) 582 619 -
branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r12562 r12630 1299 1299 (return-from p1-function-call 1300 1300 (let ((*inline-declarations* 1301 (remove op *inline-declarations* :key #'car )))1301 (remove op *inline-declarations* :key #'car :test #'equal))) 1302 1302 (p1 expansion)))))) 1303 1303 -
branches/less-reflection/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12622 r12630 199 199 n))) 200 200 201 (defconstant +fasl-loader-class+ 202 "org/armedbear/lisp/FaslClassLoader") 201 203 (defconstant +java-string+ "Ljava/lang/String;") 202 204 (defconstant +java-object+ "Ljava/lang/Object;") … … 2175 2177 (setf g (symbol-name (gensym "LFUN"))) 2176 2178 (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function))) 2179 (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname))) 2177 2180 (*code* *static-code*)) 2178 2181 ;; fixme *declare-inline* 2179 2182 (declare-field g +lisp-object+ +field-access-default+) 2180 (emit 'ldc (pool-string (file-namestring pathname))) 2181 (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" 2182 (list +java-string+) +lisp-object+) 2183 (emit 'new class-name) 2184 (emit 'dup) 2185 (emit-invokespecial-init class-name '()) 2186 2187 ;(emit 'ldc (pool-string (pathname-name pathname))) 2188 ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction" 2189 ;(list +java-string+) +lisp-object+) 2190 2191 ; (emit 'ldc (pool-string (file-namestring pathname))) 2192 2193 ; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" 2194 ; (list +java-string+) +lisp-object+) 2183 2195 (emit 'putstatic *this-class* g +lisp-object+) 2184 2196 (setf *static-code* *code*) … … 2331 2343 (let ((g (symbol-name (gensym "INSTANCE"))) 2332 2344 saved-code) 2345 (sys::%format t "OBJ = ~A ~S~%" (type-of obj) obj) 2333 2346 (let* ((s (with-output-to-string (stream) (dump-form obj stream))) 2334 2347 (*code* (if *declare-inline* *code* *static-code*))) … … 5316 5329 (emit 'getstatic *this-class* 5317 5330 g +lisp-object+))))) ; Stack: template-function 5318 ((member name *functions-defined-in-current-file* :test #'equal) 5331 ((and (member name *functions-defined-in-current-file* :test #'equal) 5332 (not (notinline-p name))) 5319 5333 (emit 'getstatic *this-class* 5320 5334 (declare-setf-function name) +lisp-object+) … … 7892 7906 (compile-function-call form target representation)))) 7893 7907 7908 #|(defknown p2-java-jcall (t t t) t) 7909 (define-inlined-function p2-java-jcall (form target representation) 7910 ((and (> *speed* *safety*) 7911 (< 1 (length form)) 7912 (eq 'jmethod (car (cadr form))) 7913 (every #'stringp (cdr (cadr form))))) 7914 (let ((m (ignore-errors (eval (cadr form))))) 7915 (if m 7916 (let ((must-clear-values nil) 7917 (arg-types (raw-arg-types (jmethod-params m)))) 7918 (declare (type boolean must-clear-values)) 7919 (dolist (arg (cddr form)) 7920 (compile-form arg 'stack nil) 7921 (unless must-clear-values 7922 (unless (single-valued-p arg) 7923 (setf must-clear-values t)))) 7924 (when must-clear-values 7925 (emit-clear-values)) 7926 (dotimes (i (jarray-length raw-arg-types)) 7927 (push (jarray-ref raw-arg-types i) arg-types)) 7928 (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) 7929 (jmethod-name m) 7930 (nreverse arg-types) 7931 (jmethod-return-type m))) 7932 ;; delay resolving the method to run-time; it's unavailable now 7933 (compile-function-call form target representation))))|# 7894 7934 7895 7935 (defknown p2-char= (t t t) t) … … 8862 8902 (install-p2-handler 'java:jconstructor 'p2-java-jconstructor) 8863 8903 (install-p2-handler 'java:jmethod 'p2-java-jmethod) 8904 ; (install-p2-handler 'java:jcall 'p2-java-jcall) 8864 8905 (install-p2-handler 'char= 'p2-char=) 8865 8906 (install-p2-handler 'characterp 'p2-characterp) -
branches/less-reflection/abcl/src/org/armedbear/lisp/gui.lisp
r12029 r12630 1 1 (in-package :extensions) 2 3 (require :java) 2 4 3 5 (defvar *gui-backend* :swing) -
branches/less-reflection/abcl/src/org/armedbear/lisp/java.lisp
r12583 r12630 337 337 class 338 338 (%register-java-class 339 jclass (mop::ensure-class (make-symbol (jclass-name jclass)) 340 :metaclass (find-class 'java-class) 341 :direct-superclasses (if (jclass-superclass-p jclass (jclass "java.lang.Object")) 342 (list (find-class 'java-object)) 343 (mapcar #'ensure-java-class 344 (delete nil 345 (concatenate 'list (list (jclass-superclass jclass)) 346 (jclass-interfaces jclass))))) 347 :java-class jclass))))) 348 339 jclass (mop::ensure-class 340 (make-symbol (jclass-name jclass)) 341 :metaclass (find-class 'java-class) 342 :direct-superclasses 343 (if (jclass-superclass-p jclass (jclass "java.lang.Object")) 344 (list (find-class 'java-object)) 345 (mapcar #'ensure-java-class 346 (delete nil 347 (concatenate 'list (list (jclass-superclass jclass)) 348 (jclass-interfaces jclass))))) 349 :java-class jclass))))) 350 349 351 (defmethod make-instance ((class java-class) &rest initargs &key &allow-other-keys) 350 352 (declare (ignore initargs)) -
branches/less-reflection/abcl/src/org/armedbear/lisp/load.lisp
r11856 r12630 39 39 (external-format :default)) 40 40 (declare (ignore external-format)) ; FIXME 41 (%load (if (streamp filespec) 42 filespec 43 (merge-pathnames (pathname filespec))) 44 verbose print if-does-not-exist)) 41 (let (*fasl-loader*) 42 (%load (if (streamp filespec) 43 filespec 44 (merge-pathnames (pathname filespec))) 45 verbose print if-does-not-exist))) 45 46 46 47 (defun load-returning-last-result (filespec … … 51 52 (external-format :default)) 52 53 (declare (ignore external-format)) ; FIXME 53 (%load-returning-last-result (if (streamp filespec) 54 filespec 55 (merge-pathnames (pathname filespec))) 56 verbose print if-does-not-exist)) 54 (let (*fasl-loader*) 55 (%load-returning-last-result (if (streamp filespec) 56 filespec 57 (merge-pathnames (pathname filespec))) 58 verbose print if-does-not-exist))) -
branches/less-reflection/abcl/src/org/armedbear/lisp/precompiler.lisp
r12340 r12630 33 33 34 34 35 (export '(*inline-declarations* 36 process-optimization-declarations 35 (export '(process-optimization-declarations 37 36 inline-p notinline-p inline-expansion expand-inline 38 37 *defined-functions* *undefined-functions* note-name-defined)) 39 40 (defvar *inline-declarations* nil)41 38 42 39 (declaim (ftype (function (t) t) process-optimization-declarations)) … … 87 84 (defun inline-p (name) 88 85 (declare (optimize speed)) 89 (let ((entry (assoc name *inline-declarations* )))86 (let ((entry (assoc name *inline-declarations* :test #'equal))) 90 87 (if entry 91 88 (eq (cdr entry) 'INLINE) … … 95 92 (defun notinline-p (name) 96 93 (declare (optimize speed)) 97 (let ((entry (assoc name *inline-declarations* )))94 (let ((entry (assoc name *inline-declarations* :test #'equal))) 98 95 (if entry 99 96 (eq (cdr entry) 'NOTINLINE) -
branches/less-reflection/abcl/src/org/armedbear/lisp/proclaim.lisp
r11391 r12630 32 32 (in-package #:system) 33 33 34 (export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type ))34 (export '(check-declaration-type proclaimed-type proclaimed-ftype ftype-result-type *inline-declarations*)) 35 35 36 36 (defmacro declaim (&rest decls) … … 44 44 :format-arguments (list name))) 45 45 46 (defvar *inline-declarations* nil) 46 47 (defvar *declaration-types* (make-hash-table :test 'eq)) 47 48 … … 92 93 ((INLINE NOTINLINE) 93 94 (dolist (name (cdr declaration-specifier)) 94 (when (symbolp name) ; FIXME Need to support non-symbol function names. 95 (setf (get name '%inline) (car declaration-specifier))))) 95 (if (symbolp name) 96 (setf (get name '%inline) (car declaration-specifier)) 97 (push (cons name (car declaration-specifier)) *inline-declarations*)))) 96 98 (DECLARATION 97 99 (dolist (name (cdr declaration-specifier)) -
branches/less-reflection/abcl/src/org/armedbear/lisp/subtypep.lisp
r11586 r12630 68 68 (HASH-TABLE) 69 69 (INTEGER RATIONAL) 70 (JAVA-CLASS STANDARD-CLASS) 70 71 (KEYWORD SYMBOL) 71 72 (LIST SEQUENCE)
Note: See TracChangeset
for help on using the changeset viewer.