Changeset 12742
- Timestamp:
- 06/07/10 18:30:36 (13 years ago)
- Location:
- trunk/abcl/src/org/armedbear/lisp
- Files:
-
- 12 edited
- 1 copied
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/Autoload.java
r12715 r12742 98 98 "org.armedbear.lisp.".concat(className))); 99 99 } 100 100 101 101 public void load() 102 102 { … … 685 685 autoload(Symbol.COPY_LIST, "copy_list"); 686 686 687 autoload(PACKAGE_SYS, "make-fasl-class-loader", "FaslClassLoader", false); 688 autoload(PACKAGE_SYS, "get-fasl-function", "FaslClassLoader", false); 689 687 690 autoload(Symbol.SET_CHAR, "StringFunctions"); 688 691 autoload(Symbol.SET_SCHAR, "StringFunctions"); -
trunk/abcl/src/org/armedbear/lisp/FaslClassLoader.java
r12739 r12742 71 71 public byte[] getFunctionClassBytes(String name) { 72 72 Pathname pathname = new Pathname(name.substring("org/armedbear/lisp/".length()) + ".cls"); 73 return readFunctionBytes(pathname); 73 final LispThread thread = LispThread.currentThread(); 74 SpecialBindingsMark mark = thread.markSpecialBindings(); 75 try { 76 //thread.bindSpecial(Symbol.LOAD_TRUENAME_FASL, NIL); 77 thread.bindSpecial(Symbol.LOAD_TRUENAME, NIL); 78 return readFunctionBytes(pathname); 79 } finally { 80 thread.resetSpecialBindings(mark); 81 } 74 82 } 75 83 -
trunk/abcl/src/org/armedbear/lisp/Function.java
r12288 r12742 176 176 } 177 177 178 public final LispObject getClassBytes() { 179 LispObject o = getf(propertyList, Symbol.CLASS_BYTES, NIL); 180 if(o != NIL) { 181 return o; 182 } else { 183 ClassLoader c = getClass().getClassLoader(); 184 if(c instanceof FaslClassLoader) { 185 return new JavaObject(((FaslClassLoader) c).getFunctionClassBytes(this)); 186 } else { 187 return NIL; 188 } 189 } 190 } 191 192 public static final Primitive FUNCTION_CLASS_BYTES = new pf_function_class_bytes(); 193 public static final class pf_function_class_bytes extends Primitive { 194 public pf_function_class_bytes() { 195 super("function-class-bytes", PACKAGE_SYS, false, "function"); 196 } 197 @Override 198 public LispObject execute(LispObject arg) { 199 if (arg instanceof Function) { 200 return ((Function) arg).getClassBytes(); 201 } 202 return type_error(arg, Symbol.FUNCTION); 203 } 204 } 205 178 206 @Override 179 207 public LispObject execute() 180 208 { 181 return error(new WrongNumberOfArgumentsException(this ));209 return error(new WrongNumberOfArgumentsException(this, 0)); 182 210 } 183 211 … … 185 213 public LispObject execute(LispObject arg) 186 214 { 187 return error(new WrongNumberOfArgumentsException(this ));215 return error(new WrongNumberOfArgumentsException(this, 1)); 188 216 } 189 217 … … 192 220 193 221 { 194 return error(new WrongNumberOfArgumentsException(this ));222 return error(new WrongNumberOfArgumentsException(this, 2)); 195 223 } 196 224 … … 200 228 201 229 { 202 return error(new WrongNumberOfArgumentsException(this ));230 return error(new WrongNumberOfArgumentsException(this, 3)); 203 231 } 204 232 … … 208 236 209 237 { 210 return error(new WrongNumberOfArgumentsException(this ));238 return error(new WrongNumberOfArgumentsException(this, 4)); 211 239 } 212 240 … … 217 245 218 246 { 219 return error(new WrongNumberOfArgumentsException(this ));247 return error(new WrongNumberOfArgumentsException(this, 5)); 220 248 } 221 249 … … 226 254 227 255 { 228 return error(new WrongNumberOfArgumentsException(this ));256 return error(new WrongNumberOfArgumentsException(this, 6)); 229 257 } 230 258 … … 236 264 237 265 { 238 return error(new WrongNumberOfArgumentsException(this ));266 return error(new WrongNumberOfArgumentsException(this, 7)); 239 267 } 240 268 … … 246 274 247 275 { 248 return error(new WrongNumberOfArgumentsException(this ));276 return error(new WrongNumberOfArgumentsException(this, 8)); 249 277 } 250 278 -
trunk/abcl/src/org/armedbear/lisp/Lisp.java
r12724 r12742 44 44 import java.net.URLDecoder; 45 45 import java.util.Hashtable; 46 import java.util.zip.ZipEntry;47 import java.util.zip.ZipFile;48 46 49 47 public final class Lisp … … 1267 1265 input = url.openStream(); 1268 1266 } catch (IOException e) { 1267 System.err.println("Failed to read class bytes from boot class " + url); 1269 1268 error(new LispError("Failed to read class bytes from boot class " + url)); 1270 1269 } … … 2386 2385 internSpecial("*LOAD-STREAM*", PACKAGE_SYS, NIL); 2387 2386 2387 // ### *fasl-loader* 2388 public static final Symbol _FASL_LOADER_ = 2389 exportSpecial("*FASL-LOADER*", PACKAGE_SYS, NIL); 2390 2388 2391 // ### *source* 2389 2392 // internal symbol … … 2759 2762 } 2760 2763 2764 private static final SpecialOperator WITH_INLINE_CODE = new with_inline_code(); 2765 private static class with_inline_code extends SpecialOperator { 2766 with_inline_code() { 2767 super("with-inline-code", PACKAGE_JVM, true, "(&optional target repr) &body body"); 2768 } 2769 @Override 2770 public LispObject execute(LispObject args, Environment env) 2771 { 2772 return error(new SimpleError("This is a placeholder. It should only be called in compiled code, and tranformed by the compiler using special form handlers.")); 2773 } 2774 } 2775 2761 2776 } -
trunk/abcl/src/org/armedbear/lisp/Load.java
r12723 r12742 243 243 } 244 244 245 private static final Symbol FASL_LOADER = PACKAGE_SYS.intern("*FASL-LOADER*"); 245 246 static final LispObject COMPILE_FILE_INIT_FASL_TYPE = new SimpleString("_"); 246 247 … … 269 270 url = Lisp.class.getResource(path); 270 271 if (url == null || url.toString().endsWith("/")) { 271 url = Lisp.class.getResource(path + ".abcl");272 url = Lisp.class.getResource(path.replace('-', '_') + ".abcl"); 272 273 if (url == null) { 273 274 url = Lisp.class.getResource(path + ".lisp"); … … 323 324 final SpecialBindingsMark mark = thread.markSpecialBindings(); 324 325 thread.bindSpecial(_WARN_ON_REDEFINITION_, NIL); 326 thread.bindSpecial(FASL_LOADER, NIL); 325 327 try { 326 328 Stream stream = new Stream(Symbol.SYSTEM_STREAM, in, Symbol.CHARACTER); … … 568 570 if (obj == EOF) 569 571 break; 570 572 result = eval(obj, env, thread); 571 573 if (print) { 572 574 Stream out = -
trunk/abcl/src/org/armedbear/lisp/compile-file.lisp
r12650 r12742 41 41 (defvar *output-file-pathname*) 42 42 43 (defun base-classname (&optional (output-file-pathname *output-file-pathname*)) 44 (sanitize-class-name (pathname-name output-file-pathname))) 45 46 (defun fasl-loader-classname (&optional (output-file-pathname *output-file-pathname*)) 47 (%format nil "~A_0" (base-classname output-file-pathname))) 48 43 49 (declaim (ftype (function (t) t) compute-classfile-name)) 44 50 (defun compute-classfile-name (n &optional (output-file-pathname … … 46 52 "Computes the name of the class file associated with number `n'." 47 53 (let ((name 48 (%format nil "~A-~D" 49 (substitute #\_ #\. 50 (pathname-name output-file-pathname)) n))) 54 (sanitize-class-name 55 (%format nil "~A_~D" (pathname-name output-file-pathname) n)))) 51 56 (namestring (merge-pathnames (make-pathname :name name :type "cls") 52 57 output-file-pathname)))) 58 59 (defun sanitize-class-name (name) 60 (let ((name (copy-seq name))) 61 (dotimes (i (length name)) 62 (declare (type fixnum i)) 63 (when (or (char= (char name i) #\-) 64 (char= (char name i) #\.) 65 (char= (char name i) #\Space)) 66 (setf (char name i) #\_))) 67 name)) 68 53 69 54 70 (declaim (ftype (function () t) next-classfile-name)) … … 70 86 (declaim (ftype (function (t) t) verify-load)) 71 87 (defun verify-load (classfile) 72 (if (> *safety* 0)73 (and classfile88 #|(if (> *safety* 0) 89 (and classfile 74 90 (let ((*load-truename* *output-file-pathname*)) 75 91 (report-error 76 92 (load-compiled-function classfile)))) 77 t)) 93 t)|# 94 (declare (ignore classfile)) 95 t) 78 96 79 97 (declaim (ftype (function (t) t) process-defconstant)) … … 145 163 (let* ((expr `(lambda ,lambda-list 146 164 ,@decls (block ,block-name ,@body))) 165 (saved-class-number *class-number*) 147 166 (classfile (next-classfile-name)) 148 167 (internal-compiler-errors nil) … … 169 188 (setf form 170 189 `(fset ',name 171 (proxy-preloaded-function ',name ,(file-namestring classfile)) 190 (sys::get-fasl-function *fasl-loader* 191 ,saved-class-number) 172 192 ,*source-position* 173 193 ',lambda-list … … 226 246 (eval form) 227 247 (let* ((expr (function-lambda-expression (macro-function name))) 248 (saved-class-number *class-number*) 228 249 (classfile (next-classfile-name))) 229 250 (with-open-file … … 242 263 `(put ',name 'macroexpand-macro 243 264 (make-macro ',name 244 (proxy-preloaded-function 245 '(macro-function ,name) 246 ,(file-namestring classfile)))) 265 (sys::get-fasl-function *fasl-loader* ,saved-class-number))) 247 266 `(fset ',name 248 267 (make-macro ',name 249 (proxy-preloaded-function 250 '(macro-function ,name) 251 ,(file-namestring classfile))) 268 (sys::get-fasl-function *fasl-loader* ,saved-class-number)) 252 269 ,*source-position* 253 270 ',(third form))))))))) … … 349 366 ;; was already used in verify-load before I used it, 350 367 ;; however, binding *load-truename* isn't fully compliant, I think. 351 (let ((*load-truename* *output-file-pathname*)) 352 (when compile-time-too 368 (when compile-time-too 369 (let ((*load-truename* *output-file-pathname*) 370 (*fasl-loader* (make-fasl-class-loader 371 *class-number* 372 (concatenate 'string "org.armedbear.lisp." (base-classname)) 373 nil))) 353 374 (eval form)))) 354 375 … … 367 388 (let ((lambda-expression (cadr function-form))) 368 389 (jvm::with-saved-compiler-policy 369 (let* ((classfile (next-classfile-name)) 390 (let* ((saved-class-number *class-number*) 391 (classfile (next-classfile-name)) 370 392 (result 371 393 (with-open-file … … 380 402 (cond (compiled-function 381 403 (setf (getf tail key) 382 `(load-compiled-function ,(file-namestring classfile)))) 404 `(sys::get-fasl-function *fasl-loader* ,saved-class-number))) 405 ;; `(load-compiled-function ,(file-namestring classfile)))) 383 406 (t 384 407 ;; FIXME This should be a warning or error of some sort... … … 413 436 (precompiler:precompile-form form nil *compile-file-environment*))) 414 437 (let* ((expr `(lambda () ,form)) 438 (saved-class-number *class-number*) 415 439 (classfile (next-classfile-name)) 416 440 (result … … 426 450 (setf form 427 451 (if compiled-function 428 `(funcall ( load-compiled-function ,(file-namestring classfile)))452 `(funcall (sys::get-fasl-function *fasl-loader* ,saved-class-number)) 429 453 (precompiler:precompile-form form nil *compile-file-environment*))))) 430 454 … … 573 597 :stream out) 574 598 (%stream-terpri out) 575 ;; Note: Beyond this point, you can't use DUMP-FORM, 576 ;; because the list of uninterned symbols has been fixed now. 577 (when *fasl-uninterned-symbols* 578 (write (list 'setq '*fasl-uninterned-symbols* 579 (coerce (mapcar #'car 580 (nreverse *fasl-uninterned-symbols*)) 581 'vector)) 582 :stream out)) 583 (%stream-terpri out) 584 ;; we work with a fixed variable name here to work around the 585 ;; lack of availability of the circle reader in the fasl reader 586 ;; but it's a toplevel form anyway 587 (write `(dotimes (i ,*class-number*) 588 (function-preload 589 (%format nil "~A-~D.cls" 590 ,(substitute #\_ #\. (pathname-name output-file)) 591 (1+ i)))) 592 :stream out 593 :circle t) 599 ;; Note: Beyond this point, you can't use DUMP-FORM, 600 ;; because the list of uninterned symbols has been fixed now. 601 (when *fasl-uninterned-symbols* 602 (write (list 'setq '*fasl-uninterned-symbols* 603 (coerce (mapcar #'car 604 (nreverse *fasl-uninterned-symbols*)) 605 'vector)) 606 :stream out)) 607 (%stream-terpri out) 608 609 (when (> *class-number* 0) 610 (generate-loader-function) 611 (write (list 'setq '*fasl-loader* 612 `(sys::make-fasl-class-loader 613 ,*class-number* 614 ,(concatenate 'string "org.armedbear.lisp." (base-classname)))) :stream out)) 594 615 (%stream-terpri out)) 595 616 … … 610 631 (merge-pathnames (make-pathname :type type) 611 632 output-file))) 612 (pathnames ())) 633 (pathnames nil) 634 (fasl-loader (namestring (merge-pathnames (make-pathname :name (fasl-loader-classname) :type "cls") 635 output-file)))) 636 (when (probe-file fasl-loader) 637 (push fasl-loader pathnames)) 613 638 (dotimes (i *class-number*) 614 639 (let* ((pathname (compute-classfile-name (1+ i)))) … … 632 657 (namestring output-file) elapsed)))) 633 658 (values (truename output-file) warnings-p failure-p))) 659 660 (defmacro ncase (expr min max &rest clauses) 661 "A CASE where all test clauses are numbers ranging from a minimum to a maximum." 662 ;;Expr is subject to multiple evaluation, but since we only use ncase for 663 ;;fn-index below, let's ignore it. 664 (let* ((half (floor (/ (- max min) 2))) 665 (middle (+ min half))) 666 (if (> (- max min) 10) 667 `(if (< ,expr ,middle) 668 (ncase ,expr ,min ,middle ,@(subseq clauses 0 half)) 669 (ncase ,expr ,middle ,max ,@(subseq clauses half))) 670 `(case ,expr ,@clauses)))) 671 672 (defun generate-loader-function () 673 (let* ((basename (base-classname)) 674 (expr `(lambda (fasl-loader fn-index) 675 (identity fasl-loader) ;;to avoid unused arg 676 (ncase fn-index 0 ,(1- *class-number*) 677 ,@(loop 678 :for i :from 1 :to *class-number* 679 :collect 680 (let ((class (%format nil "org/armedbear/lisp/~A_~A" basename i))) 681 `(,(1- i) 682 (jvm::with-inline-code () 683 (jvm::emit 'jvm::aload 1) 684 (jvm::emit-invokevirtual jvm::+lisp-object-class+ "javaInstance" 685 nil jvm::+java-object+) 686 (jvm::emit 'jvm::checkcast "org/armedbear/lisp/FaslClassLoader") 687 (jvm::emit 'jvm::dup) 688 (jvm::emit-push-constant-int ,(1- i)) 689 (jvm::emit 'jvm::new ,class) 690 (jvm::emit 'jvm::dup) 691 (jvm::emit-invokespecial-init ,class '()) 692 (jvm::emit-invokevirtual "org/armedbear/lisp/FaslClassLoader" "putFunction" 693 (list "I" jvm::+lisp-object+) jvm::+lisp-object+) 694 (jvm::emit 'jvm::pop)) 695 t)))))) 696 (classname (fasl-loader-classname)) 697 (classfile (namestring (merge-pathnames (make-pathname :name classname :type "cls") 698 *output-file-pathname*)))) 699 (jvm::with-saved-compiler-policy 700 (jvm::with-file-compilation 701 (with-open-file 702 (f classfile 703 :direction :output 704 :element-type '(unsigned-byte 8) 705 :if-exists :supersede) 706 (jvm:compile-defun nil expr nil 707 classfile f nil)))))) 634 708 635 709 (defun compile-file-if-needed (input-file &rest allargs &key force-compile -
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
r12562 r12742 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 … … 1433 1433 (UNWIND-PROTECT p1-unwind-protect) 1434 1434 (THREADS:SYNCHRONIZED-ON 1435 p1-threads-synchronized-on))) 1435 p1-threads-synchronized-on) 1436 (JVM::WITH-INLINE-CODE identity))) 1436 1437 (install-p1-handler (%car pair) (%cadr pair)))) 1437 1438 -
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
r12739 r12742 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;") … … 2268 2270 (setf g (symbol-name (gensym "LFUN"))) 2269 2271 (let* ((pathname (abcl-class-file-pathname (local-function-class-file local-function))) 2272 (class-name (concatenate 'string "org/armedbear/lisp/" (pathname-name pathname))) 2270 2273 (*code* *static-code*)) 2271 2274 ;; fixme *declare-inline* 2272 (declare-field g +lisp-object+ +field-access-default+) 2273 (emit 'ldc (pool-string (file-namestring pathname))) 2274 (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" 2275 (list +java-string+) +lisp-object+) 2275 (declare-field g +lisp-object+ +field-access-private+) 2276 (emit 'new class-name) 2277 (emit 'dup) 2278 (emit-invokespecial-init class-name '()) 2279 2280 ;(emit 'ldc (pool-string (pathname-name pathname))) 2281 ;(emit-invokestatic +fasl-loader-class+ "faslLoadFunction" 2282 ;(list +java-string+) +lisp-object+) 2283 2284 ; (emit 'ldc (pool-string (file-namestring pathname))) 2285 2286 ; (emit-invokestatic +lisp-function-proxy-class+ "loadPreloadedFunction" 2287 ; (list +java-string+) +lisp-object+) 2276 2288 (emit 'putstatic *this-class* g +lisp-object+) 2277 2289 (setf *static-code* *code*) … … 5095 5107 (emit 'getstatic *this-class* 5096 5108 g +lisp-object+))))) ; Stack: template-function 5097 ((member name *functions-defined-in-current-file* :test #'equal) 5109 ((and (member name *functions-defined-in-current-file* :test #'equal) 5110 (not (notinline-p name))) 5098 5111 (emit 'getstatic *this-class* 5099 5112 (declare-setf-function name) +lisp-object+) … … 7545 7558 (compile-function-call form target representation)))) 7546 7559 7560 #|(defknown p2-java-jcall (t t t) t) 7561 (define-inlined-function p2-java-jcall (form target representation) 7562 ((and (> *speed* *safety*) 7563 (< 1 (length form)) 7564 (eq 'jmethod (car (cadr form))) 7565 (every #'stringp (cdr (cadr form))))) 7566 (let ((m (ignore-errors (eval (cadr form))))) 7567 (if m 7568 (let ((must-clear-values nil) 7569 (arg-types (raw-arg-types (jmethod-params m)))) 7570 (declare (type boolean must-clear-values)) 7571 (dolist (arg (cddr form)) 7572 (compile-form arg 'stack nil) 7573 (unless must-clear-values 7574 (unless (single-valued-p arg) 7575 (setf must-clear-values t)))) 7576 (when must-clear-values 7577 (emit-clear-values)) 7578 (dotimes (i (jarray-length raw-arg-types)) 7579 (push (jarray-ref raw-arg-types i) arg-types)) 7580 (emit-invokevirtual (jclass-name (jmethod-declaring-class m)) 7581 (jmethod-name m) 7582 (nreverse arg-types) 7583 (jmethod-return-type m))) 7584 ;; delay resolving the method to run-time; it's unavailable now 7585 (compile-function-call form target representation))))|# 7547 7586 7548 7587 (defknown p2-char= (t t t) t) … … 8221 8260 t) 8222 8261 8262 (defun p2-with-inline-code (form target representation) 8263 ;;form = (with-inline-code (&optional target-var repr-var) ...body...) 8264 (destructuring-bind (&optional target-var repr-var) (cadr form) 8265 (eval `(let (,@(when target-var `((,target-var ,target))) 8266 ,@(when repr-var `((,repr-var ,representation)))) 8267 ,@(cddr form))))) 8268 8223 8269 (defun compile-1 (compiland stream) 8224 8270 (let ((*all-variables* nil) … … 8513 8559 (install-p2-handler 'java:jconstructor 'p2-java-jconstructor) 8514 8560 (install-p2-handler 'java:jmethod 'p2-java-jmethod) 8561 ; (install-p2-handler 'java:jcall 'p2-java-jcall) 8515 8562 (install-p2-handler 'char= 'p2-char=) 8516 8563 (install-p2-handler 'characterp 'p2-characterp) … … 8597 8644 (install-p2-handler 'write-8-bits 'p2-write-8-bits) 8598 8645 (install-p2-handler 'zerop 'p2-zerop) 8646 (install-p2-handler 'with-inline-code 'p2-with-inline-code) 8599 8647 t) 8600 8648 -
trunk/abcl/src/org/armedbear/lisp/disassemble.lisp
r11391 r12742 48 48 (unless (compiled-function-p function) 49 49 (setf function (compile nil function))) 50 (when (getf (function-plist function) 'class-bytes) 51 (with-input-from-string 52 (stream (disassemble-class-bytes (getf (function-plist function) 'class-bytes))) 53 (loop 54 (let ((line (read-line stream nil))) 55 (unless line (return)) 56 (write-string "; ") 57 (write-string line) 58 (terpri)))) 59 (return-from disassemble))) 60 (%format t "; Disassembly is not available.~%"))) 50 (let ((class-bytes (function-class-bytes function))) 51 (when class-bytes 52 (with-input-from-string 53 (stream (disassemble-class-bytes class-bytes)) 54 (loop 55 (let ((line (read-line stream nil))) 56 (unless line (return)) 57 (write-string "; ") 58 (write-string line) 59 (terpri)))) 60 (return-from disassemble))) 61 (%format t "; Disassembly is not available.~%")))) -
trunk/abcl/src/org/armedbear/lisp/gui.lisp
r12029 r12742 1 1 (in-package :extensions) 2 3 (require :java) 2 4 3 5 (defvar *gui-backend* :swing) -
trunk/abcl/src/org/armedbear/lisp/load.lisp
r11856 r12742 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))) -
trunk/abcl/src/org/armedbear/lisp/precompiler.lisp
r12340 r12742 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) … … 962 959 'precompiler)))) 963 960 (unless (and handler (fboundp handler)) 964 (error "No handler for ~S." symbol)) 961 (error "No handler for ~S." (let ((*package* (find-package :keyword))) 962 (format nil "~S" symbol)))) 965 963 (setf (get symbol 'precompile-handler) handler))) 966 964 … … 1025 1023 1026 1024 (THREADS:SYNCHRONIZED-ON 1027 precompile-threads-synchronized-on))) 1025 precompile-threads-synchronized-on) 1026 1027 (JVM::WITH-INLINE-CODE precompile-identity))) 1028 1028 (install-handler (first pair) (second pair)))) 1029 1029 -
trunk/abcl/src/org/armedbear/lisp/proclaim.lisp
r11391 r12742 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))
Note: See TracChangeset
for help on using the changeset viewer.