Index: /branches/source-tracking-0801/ccl/compiler/lambda-list.lisp =================================================================== --- /branches/source-tracking-0801/ccl/compiler/lambda-list.lisp (revision 8393) +++ /branches/source-tracking-0801/ccl/compiler/lambda-list.lisp (revision 8394) @@ -20,7 +20,4 @@ ;;; Compiler functions needed elsewhere - -;;; mb: HACK HACK HACKITY HACK -(defconstant $lfbits-info-bit 23) (defun %lfun-info-index (fn) Index: /branches/source-tracking-0801/ccl/compiler/nx.lisp =================================================================== --- /branches/source-tracking-0801/ccl/compiler/nx.lisp (revision 8393) +++ /branches/source-tracking-0801/ccl/compiler/nx.lisp (revision 8394) @@ -203,25 +203,4 @@ (provide 'nx) -;;; mb: HACK HACK HACKITY HACK - -(defun %compile-time-eval (form env) - (let* ((*target-backend* *host-backend*)) - ;; The HANDLER-BIND here is supposed to note WARNINGs that're - ;; signaled during (eval-when (:compile-toplevel) processing; this - ;; in turn is supposed to satisfy a pedantic interpretation of the - ;; spec's requirement that COMPILE-FILE's second and third return - ;; values reflect (all) conditions "detected by the compiler." - ;; (It's kind of sad that CL language design is influenced so - ;; strongly by the views of pedants these days.) - (handler-bind ((warning (lambda (c) - (setq *fasl-warnings-signalled-p* t) - (unless (typep c 'style-warning) - (setq *fasl-non-style-warnings-signalled-p* t)) - (signal c)))) - (funcall (compile-named-function - `(lambda () ,form) - :env env - :policy *compile-time-evaluation-policy*))))) - (defun define-compile-time-macro (name lambda-expression env) (let ((definition-env (definition-environment env))) Index: /branches/source-tracking-0801/ccl/compiler/nx0.lisp =================================================================== --- /branches/source-tracking-0801/ccl/compiler/nx0.lisp (revision 8393) +++ /branches/source-tracking-0801/ccl/compiler/nx0.lisp (revision 8394) @@ -1594,14 +1594,7 @@ (defun record-source-location (stream) - (if (and *compiler-record-source* *fcomp-stream*) - (if (eq *fcomp-stream* stream) - t - (progn - ;; if we don't set *compiler-record-source* to NIL here all subsequent calls to read in - ;; the debugger will fail. that would be bad. - (setf *compiler-record-source* nil) - (error "Attempting to record source on stream ~S but *fcomp-stream* is ~S." - stream *fcomp-stream*))) - nil)) + (and *compiler-record-source* + *fcomp-stream* + (eq *fcomp-stream* stream))) (defstruct (source-note (:constructor %make-source-note)) Index: /branches/source-tracking-0801/ccl/level-1/l1-clos-boot.lisp =================================================================== --- /branches/source-tracking-0801/ccl/level-1/l1-clos-boot.lisp (revision 8393) +++ /branches/source-tracking-0801/ccl/level-1/l1-clos-boot.lisp (revision 8394) @@ -835,4 +835,9 @@ (%add-standard-method-to-standard-gf gf method)) +;; Redefined in l1-clos.lisp +(defun maybe-remove-make-instance-optimization (gfn method) + (declare (ignore gfn method)) + nil) + (defun %add-standard-method-to-standard-gf (gfn method) (when (%method-gf method) @@ -844,4 +849,5 @@ (qualifiers (%method-qualifiers method))) (remove-obsoleted-combined-methods method dt specializers) + (maybe-remove-make-instance-optimization gfn method) (apply #'invalidate-initargs-vector-for-gf gfn specializers) (dolist (m methods) @@ -962,23 +968,24 @@ (when dt (if specializers - (let* ((argnum (%gf-dispatch-table-argnum dt)) - (class (nth argnum specializers)) - (size (%gf-dispatch-table-size dt)) - (index 0)) - (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method) - (if (typep class 'eql-specializer) - (setq class (class-of (eql-specializer-object class)))) - (while (%i< index size) - (let* ((wrapper (%gf-dispatch-table-ref dt index)) - hash-index-0? - (cpl (and wrapper - (not (setq hash-index-0? - (eql 0 (%wrapper-hash-index wrapper)))) - (%inited-class-cpl - (require-type (%wrapper-class wrapper) 'class))))) - (when (or hash-index-0? (and cpl (cpl-index class cpl))) - (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper* - (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*)) - (setq index (%i+ index 2))))) + (let* ((argnum (%gf-dispatch-table-argnum dt))) + (when (>= argnum 0) + (let ((class (nth argnum specializers)) + (size (%gf-dispatch-table-size dt)) + (index 0)) + (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method) + (if (typep class 'eql-specializer) + (setq class (class-of (eql-specializer-object class)))) + (while (%i< index size) + (let* ((wrapper (%gf-dispatch-table-ref dt index)) + hash-index-0? + (cpl (and wrapper + (not (setq hash-index-0? + (eql 0 (%wrapper-hash-index wrapper)))) + (%inited-class-cpl + (require-type (%wrapper-class wrapper) 'class))))) + (when (or hash-index-0? (and cpl (cpl-index class cpl))) + (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper* + (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*)) + (setq index (%i+ index 2))))))) (setf (%gf-dispatch-table-ref dt 1) nil))))) ; clear 0-arg gf cm Index: /branches/source-tracking-0801/ccl/level-1/l1-clos.lisp =================================================================== --- /branches/source-tracking-0801/ccl/level-1/l1-clos.lisp (revision 8393) +++ /branches/source-tracking-0801/ccl/level-1/l1-clos.lisp (revision 8394) @@ -1910,4 +1910,5 @@ (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist) (clear-gf-dispatch-table dt) + (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard (cond ((null (cdr alist)) ;; Method is only applicable to a single class. @@ -2244,4 +2245,17 @@ %find-classes%)) +;; Redefined from bootstrapping verison in l1-clos-boot.lisp +;; Remove the make-instance optimization if the user is adding +;; a method on initialize-instance, allocate-instance, or shared-initialize +(defun maybe-remove-make-instance-optimization (gfn method) + (when (or (eq gfn #'allocate-instance) + (eq gfn #'initialize-instance) + (eq gfn #'shared-initialize)) + (let* ((specializer (car (method-specializers method))) + (cell (and (typep specializer 'class) + (gethash (class-name specializer) %find-classes%)))) + (when cell + (setf (class-cell-instantiate cell) '%make-instance))))) + ;;; Iterate over all known GFs; try to optimize their dcode in cases ;;; involving reader methods. Index: /branches/source-tracking-0801/ccl/lib/nfcomp.lisp =================================================================== --- /branches/source-tracking-0801/ccl/lib/nfcomp.lisp (revision 8393) +++ /branches/source-tracking-0801/ccl/lib/nfcomp.lisp (revision 8394) @@ -376,12 +376,4 @@ (error 'file-error :pathname file :error-type "File ~S not found")) (namestring path)) - -;;; mb: HACK HACK HACKITY HACK -(defun read-internal (stream eof-error-p eof-value recursive-p) - (setq stream (input-stream-arg stream)) - (if recursive-p - (%read-form stream 0 nil) - (let ((%read-objects% nil) (%keep-whitespace% nil)) - (%read-form stream (if eof-error-p 0) eof-value)))) ;;; orig-file is back-translated when from fcomp-file