Index: /branches/working-0711/ccl/compiler/PPC/ppc2.lisp =================================================================== --- /branches/working-0711/ccl/compiler/PPC/ppc2.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/PPC/ppc2.lisp (revision 8421) @@ -471,5 +471,5 @@ (setq function-debugging-info (nconc (list 'function-symbol-map *ppc2-recorded-symbols*) function-debugging-info))) - (setq bits (logior (ash 1 $lfbits-symmap-bit) bits)) + (setq bits (logior (ash 1 $lfbits-info-bit) bits)) (backend-new-immediate function-debugging-info))) (if (or fname lambda-form *ppc2-recorded-symbols*) Index: /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp (revision 8421) @@ -2707,15 +2707,44 @@ +(defun string-sans-most-whitespace (string &optional (max-length (length string))) + (with-output-to-string (sans-whitespace) + (loop + for count below max-length + for char across string + with just-saw-space = nil + if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed)) + do (if just-saw-space + (decf count) + (write-char #\Space sans-whitespace)) + and do (setf just-saw-space t) + else + do (setf just-saw-space nil) + and do (write-char char sans-whitespace)))) - -(defun x86-print-disassembled-instruction (ds instruction seq) +(defun x86-print-disassembled-instruction (ds instruction seq function) + (declare (special *previous-instruction* *previous-block*)) (let* ((addr (x86-di-address instruction)) (entry (x86-ds-entry-point ds))) - (when (x86-di-labeled instruction) - (format t "~&L~d~&" (- addr entry)) - (setq seq 0)) + (let* ((pc (- addr entry))) + (let* ((source-note (getf (%lfun-info function) 'function-source-note)) + (source-info (find-source-at-pc function pc)) + (text (if source-info + (string-sans-most-whitespace + (subseq (getf source-note :text) + (car (getf source-info :source-text-range)) + (cdr (getf source-info :source-text-range))) + 100) + "#"))) + (declare (special *previous-source-note*)) + (unless (string= text *previous-source-note*) + (format t "~&~%;;; ~A" text) + (setf *previous-source-note* text))) + (when (x86-di-labeled instruction) + (format t "~&L~d~%" pc) + (setq seq 0)) + (format t "~& [~D]~8T" pc)) (dolist (p (x86-di-prefixes instruction)) (format t "~& (~a)~%" p)) - (format t "~& (~a" (x86-di-mnemonic instruction)) + (format t " (~a" (x86-di-mnemonic instruction)) (let* ((op0 (x86-di-op0 instruction)) (op1 (x86-di-op1 instruction)) @@ -2728,12 +2757,20 @@ (format t " ~a" (unparse-x86-lap-operand op2 ds)))))) (format t ")") - (unless (zerop seq) ;(when (oddp seq) - (format t "~50t;[~d]" (- addr entry))) (format t "~%") (1+ seq))) - -(defun x8664-disassemble-xfunction (xfunction &key (symbolic-names - x8664::*x8664-symbolic-register-names*) (collect-function #'x86-print-disassembled-instruction)) +(defun x86-print-disassembled-function-header (function xfunction) + (declare (ignore xfunction)) + (let ((source-note (getf (%lfun-info function) 'function-source-note))) + (when source-note + (format t ";; Source: ~S:~D-~D" + (getf source-note :file-name) + (getf source-note :start) + (getf source-note :end))))) + +(defun x8664-disassemble-xfunction (function xfunction + &key (symbolic-names x8664::*x8664-symbolic-register-names*) + (collect-function #'x86-print-disassembled-instruction) + (header-function #'x86-print-disassembled-function-header)) (check-type xfunction xfunction) (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*))) @@ -2753,11 +2790,21 @@ (or (x86-dis-find-label lab blocks) (x86-disassemble-new-block ds lab)))) - (let* ((seq 0)) + (when (and blocks (let ((something-to-disassemble nil)) + (do-dll-nodes (block blocks) + (do-dll-nodes (instruction (x86-dis-block-instructions block)) + (setf something-to-disassemble t))) + something-to-disassemble)) + (funcall header-function function xfunction)) + (let* ((seq 0) + (*previous-source-note* nil)) + (declare (special *previous-source-note*)) (do-dll-nodes (block blocks) (do-dll-nodes (instruction (x86-dis-block-instructions block)) - (setq seq (funcall collect-function ds instruction seq))))))) + (setq seq (funcall collect-function ds instruction seq function))))))) #+x8664-target -(defun x8664-xdisassemble (function &optional (collect-function #'x86-print-disassembled-instruction )) +(defun x8664-xdisassemble (function + &optional (collect-function #'x86-print-disassembled-instruction) + (header-function #'x86-print-disassembled-function-header)) (let* ((fv (%function-to-function-vector function)) (function-size-in-words (uvsize fv)) @@ -2774,5 +2821,7 @@ (j 1 (1+ j))) ((= k function-size-in-words) - (x8664-disassemble-xfunction xfunction :collect-function collect-function)) + (x8664-disassemble-xfunction function xfunction + :collect-function collect-function + :header-function header-function)) (declare (fixnum j k)) (setf (uvref xfunction j) (uvref fv k))))) Index: /branches/working-0711/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 8421) @@ -175,4 +175,9 @@ (defvar *x862-record-symbols* nil) (defvar *x862-recorded-symbols* nil) +(defvar *x862-emitted-source-notes* '() + "List of all the :source-location-begin notes we've emitted during this compile.") +(defvar *definition-source-note* nil + "Represents the current 'toplevel' source note. Exists mainly so that (progn (defun a ..) (defun b + ..)) can do the 'right' thing.") (defvar *x862-result-reg* x8664::arg_z) @@ -427,6 +432,4 @@ 0 (min (- (ash ea (- x8664::word-shift)) count) #xff))) - - (defun x862-compile (afunc &optional lambda-form *x862-record-symbols*) (progn @@ -434,6 +437,5 @@ (unless (afunc-lfun a) (x862-compile a - (if lambda-form - (afunc-lambdaform a)) + (if lambda-form (afunc-lambdaform a)) *x862-record-symbols*))) ; always compile inner guys (let* ((*x862-cur-afunc* afunc) @@ -504,5 +506,6 @@ (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc))) (*x862-fcells* (afunc-fcells afunc)) - *x862-recorded-symbols*) + *x862-recorded-symbols* + (*x862-emitted-source-notes* '())) (set-fill-pointer *backend-labels* @@ -530,89 +533,101 @@ (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*) (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*) - (let* ((*x86-lap-labels* nil) - (instruction (x86::make-x86-instruction)) - (end-code-tag (gensym)) - debug-info) - (make-x86-lap-label end-code-tag) - (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8) - *x86-lap-entry-offset*) -3)) - (x86-lap-directive frag-list :byte 0) ;regsave PC - (x86-lap-directive frag-list :byte 0) ;regsave ea - (x86-lap-directive frag-list :byte 0) ;regsave mask - - (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list) - (when (or *x862-double-float-constant-alist* - *x862-single-float-constant-alist*) + (let* ((*x86-lap-labels* nil) + (instruction (x86::make-x86-instruction)) + (end-code-tag (gensym)) + debug-info) + (make-x86-lap-label end-code-tag) + (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8) + *x86-lap-entry-offset*) + -3)) + (x86-lap-directive frag-list :byte 0) ;regsave PC + (x86-lap-directive frag-list :byte 0) ;regsave ea + (x86-lap-directive frag-list :byte 0) ;regsave mask + + (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list) + (when (or *x862-double-float-constant-alist* + *x862-single-float-constant-alist*) + (x86-lap-directive frag-list :align 3) + (dolist (double-pair *x862-double-float-constant-alist*) + (destructuring-bind (dfloat . lab) double-pair + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) + (multiple-value-bind (high low) + (x862-double-float-bits dfloat) + (x86-lap-directive frag-list :long low) + (x86-lap-directive frag-list :long high)))) + (dolist (single-pair *x862-single-float-constant-alist*) + (destructuring-bind (sfloat . lab) single-pair + (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) + (let* ((val (single-float-bits sfloat))) + (x86-lap-directive frag-list :long val))))) (x86-lap-directive frag-list :align 3) - (dolist (double-pair *x862-double-float-constant-alist*) - (destructuring-bind (dfloat . lab) double-pair - (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) - (multiple-value-bind (high low) - (x862-double-float-bits dfloat) - (x86-lap-directive frag-list :long low) - (x86-lap-directive frag-list :long high)))) - (dolist (single-pair *x862-single-float-constant-alist*) - (destructuring-bind (sfloat . lab) single-pair - (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)) - (let* ((val (single-float-bits sfloat))) - (x86-lap-directive frag-list :long val))))) - (x86-lap-directive frag-list :align 3) - (x86-lap-directive frag-list :quad x8664::function-boundary-marker) - (emit-x86-lap-label frag-list end-code-tag) - (dolist (c (reverse *x862-constant-alist*)) - (let* ((vinsn-label (cdr c))) - (or (vinsn-label-info vinsn-label) - (setf (vinsn-label-info vinsn-label) - (find-or-create-x86-lap-label - vinsn-label))) - (emit-x86-lap-label frag-list vinsn-label) - (x86-lap-directive frag-list :quad 0))) + (x86-lap-directive frag-list :quad x8664::function-boundary-marker) + (emit-x86-lap-label frag-list end-code-tag) + (dolist (c (reverse *x862-constant-alist*)) + (let* ((vinsn-label (cdr c))) + (or (vinsn-label-info vinsn-label) + (setf (vinsn-label-info vinsn-label) + (find-or-create-x86-lap-label + vinsn-label))) + (emit-x86-lap-label frag-list vinsn-label) + (x86-lap-directive frag-list :quad 1))) - (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) - (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) - (let* ((function-debugging-info (afunc-lfun-info afunc))) - (when (or function-debugging-info lambda-form *x862-record-symbols*) - (if lambda-form (setq function-debugging-info - (list* 'function-lambda-expression lambda-form function-debugging-info))) - (if *x862-record-symbols* - (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*) - function-debugging-info))) - (setq bits (logior (ash 1 $lfbits-symmap-bit) bits)) - (setq debug-info function-debugging-info))) - (unless (or fname lambda-form *x862-recorded-symbols*) - (setq bits (logior (ash 1 $lfbits-noname-bit) bits))) - (unless (afunc-parent afunc) - (x862-fixup-fwd-refs afunc)) - (setf (afunc-all-vars afunc) nil) - (setf (afunc-argsword afunc) bits) - (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note) - (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*)))) - (regsave-mask (if regsave-label (x862-register-mask-byte - *x862-register-restore-count*))) - (regsave-addr (if regsave-label (x862-encode-register-save-ea - *x862-register-restore-ea* - *x862-register-restore-count*)))) - (when debug-info - (x86-lap-directive frag-list :quad 0)) - (when fname - (x86-lap-directive frag-list :quad 0)) - (x86-lap-directive frag-list :quad 0) - (relax-frag-list frag-list) - (apply-relocs frag-list) - (fill-for-alignment frag-list) - (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) - (setf (afunc-lfun afunc) - #+x86-target - (if (eq *host-backend* *target-backend*) - (create-x86-function fname frag-list *x862-constant-alist* bits debug-info) + (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc))) + (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit)))) + (unless (afunc-parent afunc) + (x862-fixup-fwd-refs afunc)) + (setf (afunc-all-vars afunc) nil) + (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note) + (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*)))) + (regsave-mask (if regsave-label (x862-register-mask-byte + *x862-register-restore-count*))) + (regsave-addr (if regsave-label (x862-encode-register-save-ea + *x862-register-restore-ea* + *x862-register-restore-count*)))) + + + (when (or (afunc-lfun-info afunc) + lambda-form + (and *compiler-record-source* *definition-source-note*) + *x862-recorded-symbols* + (and *compiler-record-source* *x862-emitted-source-notes* *definition-source-note*)) + (x86-lap-directive frag-list :quad 0)) + (when fname + (x86-lap-directive frag-list :quad 0)) + (x86-lap-directive frag-list :quad 0) + (relax-frag-list frag-list) + (apply-relocs frag-list) + (fill-for-alignment frag-list) + (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr) + (setf debug-info + (nconc (copy-list (afunc-lfun-info afunc)) + (when lambda-form + (list 'function-debugging-info lambda-form)) + (when (and *compiler-record-source* *definition-source-note*) + (list 'function-source-note + (source-note-to-list *definition-source-note* :form nil :children nil))) + (when *x862-recorded-symbols* + (list 'function-symbol-map *x862-recorded-symbols*)) + (when (and *compiler-record-source* + *x862-emitted-source-notes* + *definition-source-note*) + (list 'pc-source-map + (x862-generate-pc-source-map *definition-source-note* + *x862-emitted-source-notes*))))) + (when debug-info + (setq bits (logior (ash 1 $lfbits-info-bit) bits))) + (unless (or fname lambda-form *x862-recorded-symbols*) + (setq bits (logior (ash 1 $lfbits-noname-bit) bits))) + (setf (afunc-argsword afunc) bits) + (setf (afunc-lfun afunc) + #+x86-target + (if (eq *host-backend* *target-backend*) + (create-x86-function fname frag-list *x862-constant-alist* bits debug-info) + (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)) + #-x86-target (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)) - #-x86-target - (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))) - (x862-digest-symbols))))) + (x862-digest-symbols)))))) (backend-remove-labels)))) afunc)) - - - (defun x862-make-stack (size &optional (subtype target::subtag-s16-vector)) @@ -644,33 +659,52 @@ (setf (%svref v i) ref-fun))))))))) +(defun x862-generate-pc-source-map (definition-source-note emitted-source-notes) + (when *compiler-record-source* + (let ((def-start (source-note-start definition-source-note))) + (mapcar (lambda (start) + (list :pc-range (cons (x862-vinsn-note-label-address + start + t) + (x862-vinsn-note-label-address + (vinsn-note-peer start) + nil)) + :source-text-range (cons (- (source-note-start (aref (vinsn-note-info start) 0)) + def-start) + (- (source-note-end (aref (vinsn-note-info start) 0)) + def-start)))) + emitted-source-notes)))) + +(defun x862-vinsn-note-label-address (note &optional start-p sym) + (- + (let* ((label (vinsn-note-label note)) + (lap-label (if label (vinsn-label-info label)))) + (if lap-label + (x86-lap-label-address lap-label) + (compiler-bug "Missing or bad ~s label~@[: ~s~]" + (if start-p 'start 'end) + sym))) + x8664::fulltag-function)) + (defun x862-digest-symbols () (if *x862-recorded-symbols* - (let* ((symlist *x862-recorded-symbols*) - (len (length symlist)) - (syms (make-array len)) - (ptrs (make-array (%i+ (%i+ len len) len))) - (i -1) - (j -1)) - (declare (fixnum i j)) - (dolist (info symlist (progn (%rplaca symlist syms) - (%rplacd symlist ptrs))) - (flet ((label-address (note start-p sym) - (- - (let* ((label (vinsn-note-label note)) - (lap-label (if label (vinsn-label-info label)))) - (if lap-label - (x86-lap-label-address lap-label) - (compiler-bug "Missing or bad ~s label: ~s" - (if start-p 'start 'end) sym))) - x8664::fulltag-function))) + (let* ((symlist *x862-recorded-symbols*) + (len (length symlist)) + (syms (make-array len)) + (ptrs (make-array (%i+ (%i+ len len) len))) + (i -1) + (j -1)) + (declare (fixnum i j)) + (dolist (info symlist (progn (%rplaca symlist syms) + (%rplacd symlist ptrs))) (destructuring-bind (var sym startlab endlab) info (let* ((ea (var-ea var)) (ea-val (ldb (byte 16 0) ea))) (setf (aref ptrs (incf i)) (if (memory-spec-p ea) - (logior (ash ea-val 6) #o77) - ea-val))) + (logior (ash ea-val 6) #o77) + ea-val))) (setf (aref syms (incf j)) sym) - (setf (aref ptrs (incf i)) (label-address startlab t sym)) - (setf (aref ptrs (incf i)) (label-address endlab nil sym)))))))) + (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address startlab t sym)) + (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address endlab nil sym)))) + *x862-recorded-symbols*))) (defun x862-decls (decls) @@ -1088,21 +1122,42 @@ n)) +(defun x862-emit-source-note (seg class nx1-form) + (check-type class (member :source-location-begin :source-location-end)) + (when (nx1-source-note nx1-form) + (x862-emit-note seg class (nx1-source-note nx1-form)))) + +(defmacro x862-wrap-in-source-notes ((seg form) &body body) + (let ((x862-wrap-in-source-notes-body (gensym "X862-WRAP-IN-SOURCE-NOTES-BODY-"))) + `(flet ((,x862-wrap-in-source-notes-body () ,@body)) + (call-with-x862-wrap-in-source-notes ,seg ,form #',x862-wrap-in-source-notes-body)))) + +(defun call-with-x862-wrap-in-source-notes (seg form thunk) + (let (start end) + (setf start (x862-emit-source-note seg :source-location-begin form)) + (multiple-value-prog1 + (funcall thunk) + (setf end (x862-emit-source-note seg :source-location-end form)) + (when (and start end) + (setf (vinsn-note-peer start) end + (vinsn-note-peer end) start + *x862-emitted-source-notes* (cons start *x862-emitted-source-notes*)))))) (defun x862-form (seg vreg xfer form) - (if (nx-null form) - (x862-nil seg vreg xfer) - (if (nx-t form) - (x862-t seg vreg xfer) - (let* ((op nil) - (fn nil)) - (if (and (consp form) - (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form)))))) - (if (and (null vreg) - (%ilogbitp operator-acode-subforms-bit op) - (%ilogbitp operator-assignment-free-bit op)) - (dolist (f (%cdr form) (x862-branch seg xfer)) - (x862-form seg nil nil f )) - (apply fn seg vreg xfer (%cdr form))) - (compiler-bug "x862-form ? ~s" form)))))) + (x862-wrap-in-source-notes (seg form) + (if (nx-null form) + (x862-nil seg vreg xfer) + (if (nx-t form) + (x862-t seg vreg xfer) + (let* ((op nil) + (fn nil)) + (if (and (consp form) + (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form)))))) + (if (and (null vreg) + (%ilogbitp operator-acode-subforms-bit op) + (%ilogbitp operator-assignment-free-bit op)) + (dolist (f (%cdr form) (x862-branch seg xfer)) + (x862-form seg nil nil f )) + (apply fn seg vreg xfer (%cdr form))) + (compiler-bug "x862-form ? ~s" form))))))) ;;; dest is a float reg - form is acode @@ -5079,5 +5134,6 @@ (let* ((lab (vinsn-note-label note))) (case (vinsn-note-class note) - ((:regsave :begin-variable-scope :end-variable-scope) + ((:regsave :begin-variable-scope :end-variable-scope + :source-location-begin :source-location-end) (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab)))))) @@ -9107,11 +9163,5 @@ *target-ftd*))) (multiple-value-bind (xlfun warnings) - (compile-named-function def nil - nil - nil - nil - nil - nil - target) + (compile-named-function def :target target) (signal-or-defer-warnings warnings nil) (when disassemble Index: /branches/working-0711/ccl/compiler/lambda-list.lisp =================================================================== --- /branches/working-0711/ccl/compiler/lambda-list.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/lambda-list.lisp (revision 8421) @@ -21,13 +21,9 @@ ;;; Compiler functions needed elsewhere -;;; used-by: backtrace, arglist -(defun function-symbol-map (fn) - (getf (%lfun-info fn) 'function-symbol-map)) - (defun %lfun-info-index (fn) (and (compiled-function-p fn) (let ((bits (lfun-bits fn))) (declare (fixnum bits)) - (and (logbitp $lfbits-symmap-bit bits) + (and (logbitp $lfbits-info-bit bits) (%i- (uvsize (function-to-function-vector fn)) (if (logbitp $lfbits-noname-bit bits) 2 3)))))) @@ -39,4 +35,19 @@ (getf (%lfun-info fn) 'function-lambda-expression )) +;;; used-by: backtrace, arglist +(defun function-symbol-map (fn) + (getf (%lfun-info fn) 'function-symbol-map)) + +(defun function-source-text (fn) + (getf (%lfun-info fn) 'text)) + +(defun show-function-constants (f) + (dotimes (i (- (uvsize (function-to-function-vector f)) + (%function-code-words f))) + (format t "~&~d: ~s" i (nth-immediate f (1+ i))))) + +(defun show-uvector-contents (uvector) + (dotimes (i (uvsize uvector)) + (format t "~&~D: ~S" i (uvref uvector i)))) ;;; Lambda-list utilities Index: /branches/working-0711/ccl/compiler/nx.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nx.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/nx.lisp (revision 8421) @@ -88,5 +88,8 @@ (if (functionp def) def - (compile-named-function def spec nil *save-definitions* *save-local-symbols*)) + (compile-named-function def + :name spec + :keep-lambda *save-definitions* + :keep-symbols *save-local-symbols*)) (let ((harsh nil) (some nil) (init t)) (dolist (w warnings) @@ -121,23 +124,8 @@ (*target-backend* (or backend *target-backend*))) (multiple-value-bind (xlfun warnings) - (compile-named-function def nil - nil - nil - nil - nil - nil - target) + (compile-named-function def :target target) (signal-or-defer-warnings warnings nil) (ppc-xdisassemble xlfun :target target) xlfun))) - -(defun compile-user-function (def name &optional env) - (multiple-value-bind (lfun warnings) - (compile-named-function def name - env - *save-definitions* - *save-local-symbols*) - (signal-or-defer-warnings warnings env) - lfun)) (defun signal-or-defer-warnings (warnings env) @@ -154,7 +142,4 @@ (defparameter *load-time-eval-token* nil) - - - (eval-when (:compile-toplevel) (declaim (ftype (function (&rest ignore) t) ppc-compile))) @@ -163,15 +148,16 @@ (defun compile-named-function - (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target) + (definition &key name env keep-lambda keep-symbols policy load-time-eval-token target) (when (and name *nx-discard-xref-info-hook*) (funcall *nx-discard-xref-info-hook* name)) (setq - def - (let ((env (new-lexical-environment env))) + definition + (let ((*load-time-eval-token* load-time-eval-token) + (env (new-lexical-environment env))) (setf (lexenv.variables env) 'barrier) (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*)) (afunc (nx1-compile-lambda name - def + definition (make-afunc) nil @@ -180,17 +166,21 @@ *load-time-eval-token*))) (if (afunc-lfun afunc) - afunc - (funcall (backend-p2-compile *target-backend*) - afunc - ; will also bind *nx-lexical-environment* - (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def)) - keep-symbols))))) - (values (afunc-lfun def) (afunc-warnings def))) - - + afunc + (funcall (backend-p2-compile *target-backend*) + afunc + ;; will also bind *nx-lexical-environment* + (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition)) + keep-symbols))))) + (values (afunc-lfun definition) (afunc-warnings definition))) - - - +(defun compile-user-function (def name &optional env) + (multiple-value-bind (lfun warnings) + (compile-named-function def + :name name + :env env + :keep-lambda *save-definitions* + :keep-symbols *save-local-symbols*) + (signal-or-defer-warnings warnings env) + lfun)) (defparameter *compiler-whining-conditions* @@ -213,2 +203,24 @@ (provide 'nx) +(defun define-compile-time-macro (name lambda-expression env) + (let ((definition-env (definition-environment env))) + (if definition-env + (push (list* name + 'macro + (compile-named-function lambda-expression :name name :env env)) + (defenv.functions definition-env))) + name)) + +(defun fcomp-named-function (def name env) + (let* ((env (new-lexical-environment env))) + (multiple-value-bind (lfun warnings) + (compile-named-function def + :name name + :env env + :keep-lambda *fasl-save-definitions* + :keep-symbols *fasl-save-local-symbols* + :policy *default-file-compilation-policy* + :load-time-eval-token cfasl-load-time-eval-sym + :target *fasl-target*) + (fcomp-signal-or-defer-warnings warnings env) + lfun))) Index: /branches/working-0711/ccl/compiler/nx0.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nx0.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/nx0.lisp (revision 8421) @@ -208,9 +208,8 @@ (let ((body (parse-macro-1 block-name arglist body env))) `(eval-when (:compile-toplevel :load-toplevel :execute) - (eval-when (:load-toplevel :execute) - (record-source-file ',name 'compiler-macro)) - (setf (compiler-macro-function ',name) - (nfunction (compiler-macro-function ,name) ,body)) - ',name)))) + (record-source-file ',name 'compiler-macro) + (setf (compiler-macro-function ',name) + (nfunction (compiler-macro-function ,name) ,body)) + ',name)))) ;;; This is silly (as may be the whole idea of actually -using- @@ -1245,4 +1244,10 @@ (%ilogand $vrefmask (%i+ (%i- boundtocount 1) varcount))))))))) + +(defvar *compiler-record-source* t + "When T we record source location for compiled forms.") + +(defvar *nx1-source-note-map* nil + "Mapping between nx1-forms source locations.") (defun nx1-compile-lambda (name lambda-form &optional @@ -1557,10 +1562,131 @@ (list (%nx1-operator lambda-list) whole req opt rest keys auxen))) +(defvar *fcomp-stream* nil + "The stream we're reading code to be compiled from.") + +(defvar *compile-file-original-truename* nil) + +(defvar *compile-file-original-buffer-offset* nil) + +(defun substream (stream start &optional end) + "like subseq, but on streams that support file-position. Leaves stream positioned where it was +before calling substream." + (cond + ((stringp stream) + (subseq stream start end)) + ((typep stream 'string-input-stream) + (subseq (slot-value stream 'string) start end)) + ((not (open-stream-p stream)) + (if (typep stream 'file-stream) + (if (probe-file (stream-pathname stream)) + (with-open-file (f (stream-pathname stream)) ; I should really understand how this happens. + (substream f start end)) + "") + "")) + (t + (let ((now (file-position stream))) + (file-position stream start) + (let ((string (make-string (- (or end now) start)))) + (unwind-protect + (read-sequence string stream) + (file-position stream now)) + string))))) + +(defun record-source-location (stream) + (and *compiler-record-source* + *fcomp-stream* + (eq *fcomp-stream* stream))) + +(defstruct (source-note (:constructor %make-source-note)) + file-name + start + end + text + form + children) + +(defun make-source-note (&key stream start end text form children) + (when (record-source-location stream) + (%make-source-note :file-name (or *compile-file-original-truename* + (truename stream)) + :start (+ start (or *compile-file-original-buffer-offset* 0)) + :end (+ end (or *compile-file-original-buffer-offset* 0)) + :text (or text (substream stream start end)) + :form form + :children children))) + +;;; we don't actually store source-note structs in the fasl since that runs into problems dumping +;;; the struct. + +(defun source-note-to-list (note &key (start t) (end t) (text t) (form t) (children t) (file-name t)) + (append (when start (list :start (source-note-start note))) + (when end (list :end (source-note-end note))) + (when text (list :text (source-note-text note))) + (when form (list :form (source-note-form note))) + (when children (list :children (source-note-children note))) + (when file-name (list :file-name (source-note-file-name note))))) + +(defvar *form-source-note-map* nil + "Hash table used when compiling a top level definition to map lists of source code to their + corresponding source notes.") + +(defun make-source-note-form-map (source-note &optional existing-map) + "Creates a mapping from lisp forms to source-notes based on SOURCE-NOTES. This should be bound to +*form-source-note-map* or similar." + (let ((map (or existing-map (make-hash-table)))) + (labels ((walk (note) + (cond + ((consp note) + (walk (car note)) + (walk (cdr note))) + ((source-note-p note) + (when (and note (not (gethash (source-note-form note) map))) + (setf (gethash (source-note-form note) map) note) + (walk (source-note-children note)) + (setf (source-note-children note) '()))) + ((null note) '()) + (t (error "Don't know how to deal with a source note like ~S." + note))))) + (walk source-note)) + map)) + +(defun nx1-source-note (nx1-code) + "Return the source-note for the form which generated NX1-CODE." + (and *compiler-record-source* + *nx1-source-note-map* + (gethash nx1-code *nx1-source-note-map*))) + +(defun form-source-note (source-form) + (and *compiler-record-source* + *form-source-note-map* + (gethash source-form *form-source-note-map*))) + +(defun find-source-at-pc (function pc) + (let* ((function-source-note (getf (%lfun-info function) 'function-source-note)) + (pc-source-map (getf (%lfun-info function) 'pc-source-map))) + (when pc-source-map + (let* ((best-guess nil) + (best-length nil)) + (dolist (pc-map pc-source-map) + (let ((pc-start (car (getf pc-map :pc-range))) + (pc-end (cdr (getf pc-map :pc-range)))) + (when (<= pc-start pc pc-end) + ;; possible match, see if it's the better than best-guess + (when (or (null best-guess) + (< (- pc-end pc-start) best-length)) + (setf best-guess pc-map + best-length (- pc-end pc-start)))))) + + (when best-guess + (list :pc-range (getf best-guess :pc-range) + :source-text-range (getf best-guess :source-text-range) + :file-name (getf function-source-note :file-name) + :text (getf function-source-note :text))))))) + (defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*)) - (let* ((*nx-form-type* t)) - (when (and (consp form)(eq (car form) 'the)) - (setq *nx-form-type* (nx-target-type (cadr form)))) - (prog1 - (nx1-typed-form form *nx-lexical-environment*)))) + (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the)) + (nx-target-type (cadr form)) + t))) + (nx1-typed-form form *nx-lexical-environment*))) (defun nx1-typed-form (original env) @@ -1568,17 +1694,22 @@ (defun nx1-transformed-form (form &optional (env *nx-lexical-environment*)) - (if (consp form) - (nx1-combination form env) - (let* ((symbolp (non-nil-symbol-p form)) - (constant-value (unless symbolp form)) - (constant-symbol-p nil)) - (if symbolp - (multiple-value-setq (constant-value constant-symbol-p) - (nx-transform-defined-constant form env))) - (if (and symbolp (not constant-symbol-p)) - (nx1-symbol form env) - (nx1-immediate (nx-unquote constant-value)))))) - - + (flet ((main () + (if (consp form) + (nx1-combination form env) + (let* ((symbolp (non-nil-symbol-p form)) + (constant-value (unless symbolp form)) + (constant-symbol-p nil)) + (if symbolp + (multiple-value-setq (constant-value constant-symbol-p) + (nx-transform-defined-constant form env))) + (if (and symbolp (not constant-symbol-p)) + (nx1-symbol form env) + (nx1-immediate (nx-unquote constant-value))))))) + (if *compiler-record-source* + (destructuring-bind (nx1-form . values) + (multiple-value-list (main)) + (record-form-to-nx1-transformation form nx1-form) + (values-list (cons nx1-form values))) + (main)))) (defun nx1-prefer-areg (form env) @@ -1985,6 +2116,24 @@ ) +(defun record-form-to-nx1-transformation (form nx1) + (when (and *compiler-record-source* (form-source-note form)) + (setf (gethash nx1 *nx1-source-note-map*) (form-source-note form)))) + +(defun record-nx1-source-equivalent (original new) + (when (and *compiler-record-source* + (nx1-source-note original) + (not (nx1-source-note new))) + (setf (gethash new *nx1-source-note-map*) + (gethash original *nx1-source-note-map*)))) + +(defun record-form-source-equivalent (original new) + (when (and *compiler-record-source* + (form-source-note original) + (not (form-source-note new))) + (setf (gethash new *form-source-note-map*) + (gethash original *form-source-note-map*)))) + (defun nx-transform (form &optional (environment *nx-lexical-environment*)) - (let* (sym transforms lexdefs changed enabled macro-function compiler-macro) + (let* ((startform form) sym transforms lexdefs changed enabled macro-function compiler-macro) (tagbody (go START) @@ -1999,5 +2148,6 @@ (multiple-value-bind (newform win) (nx-transform-symbol form environment) (unless win (go DONE)) - (setq form newform changed (or changed win)) + (setq form newform + changed (or changed win)) (go LOOP))) (when (atom form) (go DONE)) @@ -2065,4 +2215,6 @@ (go START)) DONE) + (when (and changed *compiler-record-source*) + (record-form-source-equivalent startform form)) (values form changed))) Index: /branches/working-0711/ccl/compiler/nx1.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nx1.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/nx1.lisp (revision 8421) @@ -86,5 +86,6 @@ (cons 'macro - (multiple-value-bind (function warnings) (compile-named-function (parse-macro name arglist mbody old-env) name old-env) + (multiple-value-bind (function warnings) + (compile-named-function (parse-macro name arglist mbody old-env) :name name :env old-env) (setq *nx-warnings* (append *nx-warnings* warnings)) function))) @@ -1059,5 +1060,7 @@ (multiple-value-bind (function warnings) (compile-named-function - `(lambda () ,form) nil nil nil nil nil *nx-load-time-eval-token* (backend-name *target-backend*)) + `(lambda () ,form) + :load-time-eval-token *nx-load-time-eval-token* + :target (backend-name *target-backend*)) (setq *nx-warnings* (append *nx-warnings* warnings)) (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function)))) Index: /branches/working-0711/ccl/compiler/nxenv.lisp =================================================================== --- /branches/working-0711/ccl/compiler/nxenv.lisp (revision 8420) +++ /branches/working-0711/ccl/compiler/nxenv.lisp (revision 8421) @@ -55,6 +55,5 @@ afunc-fwd-refs afunc-lfun-info - afunc-linkmap -)) + afunc-linkmap)) ; Index: /branches/working-0711/ccl/level-1/l1-clos-boot.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-clos-boot.lisp (revision 8420) +++ /branches/working-0711/ccl/level-1/l1-clos-boot.lisp (revision 8421) @@ -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/working-0711/ccl/level-1/l1-clos.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-clos.lisp (revision 8420) +++ /branches/working-0711/ccl/level-1/l1-clos.lisp (revision 8421) @@ -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/working-0711/ccl/level-1/l1-files.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-files.lisp (revision 8420) +++ /branches/working-0711/ccl/level-1/l1-files.lisp (revision 8421) @@ -1140,4 +1140,8 @@ (source-file file-name) constructed-source-file + ;; we could call load, via an eval-when, when compiling a file so make sure we disable + ;; source code recording. if we subsequently call compile *fcomp-stream* will get rebound to + ;; the right value. + ;(*fcomp-stream* nil) ;; Don't bind these: let OPTIMIZE proclamations/declamations ;; persist, unless debugging. @@ -1218,5 +1222,8 @@ (defun load-from-stream (stream print &aux (eof-val (list ())) val) (with-compilation-unit (:override nil) ; try this for included files - (let ((env (new-lexical-environment (new-definition-environment 'eval)))) + (let ((env (new-lexical-environment (new-definition-environment 'eval))) + ;; disable *compiler-record-source* in case we're loading a file while comiling another + ;; file. + (*compiler-record-source* nil)) (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*) (while (neq eof-val (setq val (read stream nil eof-val))) Index: /branches/working-0711/ccl/level-1/l1-init.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-init.lisp (revision 8420) +++ /branches/working-0711/ccl/level-1/l1-init.lisp (revision 8421) @@ -258,5 +258,5 @@ (defvar *warn-if-redefine* nil) ; set in l1-utils. (defparameter *level-1-loaded* nil) ; set t by l1-boot -(defparameter *save-definitions* nil) +(defparameter *save-definitions* t) (defparameter *save-local-symbols* t) Index: /branches/working-0711/ccl/level-1/l1-reader.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 8420) +++ /branches/working-0711/ccl/level-1/l1-reader.lisp (revision 8421) @@ -2224,5 +2224,4 @@ (setf (token.ipos token) (the fixnum (1+ ipos))) (%schar (token.string token) ipos)))) - (defun input-stream-arg (stream) @@ -2456,36 +2455,73 @@ |# +(defmacro with-read-source-tracking ((stream start end) &body body) + "Evalute BODY with START bound to the current (effective) offset in STREAM at the beginning of +execution and END bound to final offset." + (let ((streamv (gensym))) + `(let* ((,streamv ,stream) + (,start (and (record-source-location ,streamv) + (file-position ,streamv)))) + (symbol-macrolet ((,end (file-position ,streamv))) + ,@body)))) + ;;; firstchar must not be whitespace. ;;; People who think that there's so much overhead in all of ;;; this (multiple-value-list, etc.) should probably consider ;;; rewriting those parts of the CLOS and I/O code that make -;;; using things like READ-CHAR impractical ... +;;; using things like READ-CHAR impractical... + +;;; mb: the reason multiple-value-list is used here is that we need to distunguish between the +;;; recursive parse call returning (values nil) and (values). (defun %parse-expression (stream firstchar dot-ok) (let* ((readtable *readtable*) - (attrtab (rdtab.ttab readtable))) - (let* ((attr (%character-attribute firstchar attrtab))) - (declare (fixnum attr)) - (if (= attr $cht_ill) - (signal-reader-error stream "Illegal character ~S." firstchar)) + (attrtab (rdtab.ttab readtable)) + (attr (%character-attribute firstchar attrtab))) + (declare (fixnum attr)) + (if (= attr $cht_ill) + (signal-reader-error stream "Illegal character ~S." firstchar)) + (with-read-source-tracking (stream start end) (let* ((vals (multiple-value-list - (if (not (logbitp $cht_macbit attr)) - (%parse-token stream firstchar dot-ok) - (let* ((def (cdr (assq firstchar (rdtab.alist readtable))))) - (cond ((null def)) - ((atom def) - (funcall def stream firstchar)) - #+no ; include if %initial-readtable% broken (see above) - ((and (consp (car def)) - (eq (caar def) 'function)) - (funcall (cadar def) stream firstchar)) - ((functionp (car def)) - (funcall (car def) stream firstchar)) - (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))) + (if (not (logbitp $cht_macbit attr)) + (%parse-token stream firstchar dot-ok) + (let* ((def (cdr (assq firstchar (rdtab.alist readtable))))) + (cond ((null def)) + ((atom def) + (funcall def stream firstchar)) + #+no ; include if %initial-readtable% broken (see above) + ((and (consp (car def)) + (eq (caar def) 'function)) + (funcall (cadar def) stream firstchar)) + ((functionp (car def)) + (funcall (car def) stream firstchar)) + (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))) (declare (dynamic-extent vals) (list vals)) (if (null vals) - (values nil nil) - (values (car vals) t)))))) - + (values nil nil nil) + (destructuring-bind (form &optional nested-source-notes) + vals + (values form + t + (when (and (consp form) (record-source-location stream)) + (make-source-note :stream stream + :start (1- start) + :end end + :form (car vals) + :children (labels ((rec (note) + ;; use this recursive function to + ;; remove nils since + ;; nested-source-notes can be a + ;; dotted list or an atom + (cond + ((consp note) + (if (null (car note)) + (rec (cdr note)) + (cons (car note) (rec (cdr note))))) + ((source-note-p note) + note) + #| ((null note) '()) + (t (error "Don't know how to deal with a source note like ~S." + nested-source-notes)) |# ))) + (rec nested-source-notes))))))))))) #| @@ -2504,37 +2540,46 @@ (let* ((firstch (%next-non-whitespace-char-and-attr-no-eof stream))) (if (eq firstch termch) - (return (values nil nil)) - (multiple-value-bind (val val-p) (%parse-expression stream firstch dot-ok) + (return (values nil nil nil)) + (multiple-value-bind (val val-p source-info) + (%parse-expression stream firstch dot-ok) (if val-p - (return (values val t)))))))) - + (return (values val t source-info)))))))) (defun read-list (stream &optional nodots (termch #\))) (let* ((dot-ok (cons nil nil)) (head (cons nil nil)) - (tail head)) + (tail head) + (source-note-list-head (cons nil nil)) + (source-note-list-tail source-note-list-head)) (declare (dynamic-extent dot-ok head) (list head tail)) (if nodots (setq dot-ok nil)) - (multiple-value-bind (firstform firstform-p) + (multiple-value-bind (firstform firstform-p firstform-source-note) (%read-list-expression stream dot-ok termch) (when firstform-p (if (and dot-ok (eq firstform dot-ok)) ; just read a dot (signal-reader-error stream "Dot context error.")) + (rplacd source-note-list-tail (setq source-note-list-tail (cons firstform-source-note nil))) (rplacd tail (setq tail (cons firstform nil))) (loop - (multiple-value-bind (nextform nextform-p) + (multiple-value-bind (nextform nextform-p nextform-source-note) (%read-list-expression stream dot-ok termch) (if (not nextform-p) (return)) (if (and dot-ok (eq nextform dot-ok)) ; just read a dot - (if (multiple-value-bind (lastform lastform-p) + (if (multiple-value-bind (lastform lastform-p lastform-source-note) (%read-list-expression stream nil termch) (and lastform-p - (progn (rplacd tail lastform) + (progn (rplacd tail lastform) + (rplacd source-note-list-tail lastform-source-note) (not (nth-value 1 (%read-list-expression stream nil termch)))))) (return) (signal-reader-error stream "Dot context error.")) - (rplacd tail (setq tail (cons nextform nil)))))))) - (cdr head))) + (progn + (rplacd source-note-list-tail (setq source-note-list-tail (cons nextform-source-note nil))) + (rplacd tail (setq tail (cons nextform nil))))))))) + + (if (record-source-location stream) + (values (cdr head) (cdr source-note-list-head)) + (values (cdr head))))) #| @@ -2623,29 +2668,30 @@ (declare (ignore subchar)) (if (or (null numarg) *read-suppress*) - (let* ((lst (read-list stream t)) - (len (length lst)) - (vec (make-array len))) - (declare (list lst) (fixnum len) (simple-vector vec)) - (dotimes (i len vec) - (setf (svref vec i) (pop lst)))) - (locally - (declare (fixnum numarg)) - (do* ((vec (make-array numarg)) - (lastform) - (i 0 (1+ i))) - ((multiple-value-bind (form form-p) (%read-list-expression stream nil) - (if form-p - (setq lastform form) - (unless (= i numarg) - (if (= i 0) - (%err-disp $XARROOB -1 vec) - (do* ((j i (1+ j))) - ((= j numarg)) - (declare (fixnum j)) - (setf (svref vec j) lastform))))) - (not form-p)) - vec) - (declare (fixnum i)) - (setf (svref vec i) lastform))))))) + (let* ((lst (read-list stream t)) + (len (length lst)) + (vec (make-array len))) + (declare (list lst) (fixnum len) (simple-vector vec)) + (dotimes (i len vec) + (setf (svref vec i) (pop lst)))) + (locally + (declare (fixnum numarg)) + (do* ((vec (make-array numarg)) + (lastform) + (i 0 (1+ i))) + ((multiple-value-bind (form form-p) + (%read-list-expression stream nil) + (if form-p + (setq lastform form) + (unless (= i numarg) + (if (= i 0) + (%err-disp $XARROOB -1 vec) + (do* ((j i (1+ j))) + ((= j numarg)) + (declare (fixnum j)) + (setf (svref vec j) lastform))))) + (not form-p)) + vec) + (declare (fixnum i)) + (setf (svref vec i) lastform))))))) (defun %read-rational (stream subchar radix) @@ -2837,7 +2883,10 @@ ;;;recursive reading. So recursive reads always get done via tyi's, and streams ;;;only get to intercept toplevel reads. - (defun read (&optional stream (eof-error-p t) eof-value recursive-p) (declare (resident)) + ;; just return the first value of read-internal + (values (read-internal stream eof-error-p eof-value recursive-p))) + +(defun read-internal (stream eof-error-p eof-value recursive-p) (setq stream (input-stream-arg stream)) (if recursive-p @@ -2858,5 +2907,5 @@ (defun read-delimited-list (char &optional stream recursive-p) "Read Lisp values from INPUT-STREAM until the next character after a - value's representation is ENDCHAR, and return the objects as a list." + value's representation is CHAR, and return the objects as a list." (setq char (require-type char 'character)) (setq stream (input-stream-arg stream)) @@ -2894,12 +2943,11 @@ (set-dispatch-macro-character #\# #\- #'read-conditional) - - - -;;;arg=0 : read form, error if eof -;;;arg=nil : read form, eof-val if eof. -;;;arg=char : read delimited list (defun %read-form (stream arg eof-val) - (declare (resident)) + "Read a lisp form from STREAM + +arg=0 : read form, error if eof +arg=nil : read form, eof-val if eof. +arg=char : read delimited list" + (declare (resident) (special *fcomp-stream*)) (check-type *readtable* readtable) (check-type *package* package) @@ -2907,19 +2955,15 @@ (read-list stream nil arg) (loop - (let* ((ch (%next-non-whitespace-char-and-attr stream))) + (let* ((ch (%next-non-whitespace-char-and-attr stream))) (if (null ch) - (if arg - (error 'end-of-file :stream stream) - (return eof-val)) - (multiple-value-bind (form form-p) (%parse-expression stream ch nil) - (if form-p - (if *read-suppress* - (return nil) - (return form))))))))) - - - - - + (if arg + (error 'end-of-file :stream stream) + (return eof-val)) + (multiple-value-bind (form form-p source-note) + (%parse-expression stream ch nil) + (when form-p + (return + (values (if *read-suppress* nil form) + source-note))))))))) ;;;Until load backquote... Index: /branches/working-0711/ccl/level-1/l1-utils.lisp =================================================================== --- /branches/working-0711/ccl/level-1/l1-utils.lisp (revision 8420) +++ /branches/working-0711/ccl/level-1/l1-utils.lisp (revision 8421) @@ -105,6 +105,8 @@ (probe-file file))) -(defun record-source-file (name def-type - &optional (file-name *loading-file-source-file*)) +#| (defmacro record-source-file (name type) + `(%record-source-file ,name ,type #| (%source-file)|#)) |# + +(defun record-source-file (name def-type &optional (file-name *loading-file-source-file*)) (let (symbol setf-p method old-file) (flet ((same-file (x y) Index: /branches/working-0711/ccl/lib/arglist.lisp =================================================================== --- /branches/working-0711/ccl/lib/arglist.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/arglist.lisp (revision 8421) @@ -161,6 +161,6 @@ (defun arglist-from-map (lfun) (multiple-value-bind (nreq nopt restp nkeys allow-other-keys - optinit lexprp - ncells nclosed) + optinit lexprp + ncells nclosed) (function-args lfun) (declare (ignore optinit)) @@ -188,5 +188,6 @@ (when nkeys (when (> idx nkeys) (decf idx nkeys))) - (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res)) (when nkeys + (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res)) + (when nkeys (push '&key res) (let ((keyvect (lfun-keyvect lfun))) @@ -215,6 +216,5 @@ (unless (zerop total) (progn - (dotimes (x nreq) - (declare (fixnum x)) + (dotimes (x (the fixnum nreq)) (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x)))) (when (neq nopt 0) @@ -222,6 +222,7 @@ (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x))))) (when (or restp lexprp) - (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest))) (when nkeys - (dotimes (i (the fixnum nkeys)) + (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest))) + (when nkeys + (dotimes (i (the fixnum nkeys)) (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i))))))))) (values (not (null map)) (req) (opt) rest (keys)))))) Index: /branches/working-0711/ccl/lib/backquote.lisp =================================================================== --- /branches/working-0711/ccl/lib/backquote.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/backquote.lisp (revision 8421) @@ -306,6 +306,4 @@ ) -#-nil -(progn (declaim (special *|`,|* *|`,.|* *|`,@|*)) @@ -389,5 +387,5 @@ (untyi char stream) (cons (%car stack) (read stream t nil t)))))))) -) + (provide 'backquote) Index: /branches/working-0711/ccl/lib/db-io.lisp =================================================================== --- /branches/working-0711/ccl/lib/db-io.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/db-io.lisp (revision 8421) @@ -843,5 +843,5 @@ (declare (ignore char arg)) (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))) - (multiple-value-bind (sym query) + (multiple-value-bind (sym source query) (%read-symbol-preserving-case stream @@ -849,10 +849,11 @@ (unless *read-suppress* (let* ((fv (%load-var sym query))) - (if query - fv - (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) - (fv.type fv) - 0 - nil)))))))) + (values (if query + fv + (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv)) + (fv.type fv) + 0 + nil)) + source))))))) @@ -985,21 +986,20 @@ (defun %read-symbol-preserving-case (stream package) (let* ((case (readtable-case *readtable*)) - (query nil) - (error nil) - (sym nil)) - (let* ((*package* package)) - (unwind-protect - (progn - (setf (readtable-case *readtable*) :preserve) - (when (eq #\? (peek-char t stream nil nil)) - (setq query t) - (read-char stream)) - (multiple-value-setq (sym error) - (handler-case (read stream nil nil) - (error (condition) (values nil condition))))) - (setf (readtable-case *readtable*) case))) + query error sym source + (*package* package)) + (unwind-protect + (progn + (setf (readtable-case *readtable*) :preserve) + (when (eq #\? (peek-char t stream nil nil)) + (setq query t) + (read-char stream)) + (multiple-value-setq (sym source error) + (handler-case + (read-internal stream nil t nil) + (error (condition) (values nil nil condition))))) + (setf (readtable-case *readtable*) case)) (when error (error error)) - (values sym query))) + (values sym source query))) (set-dispatch-macro-character @@ -1008,5 +1008,5 @@ (declare (ignore char)) (let* ((package (find-package (ftd-interface-package-name *target-ftd*)))) - (multiple-value-bind (sym query) + (multiple-value-bind (sym source query) (%read-symbol-preserving-case stream @@ -1015,23 +1015,23 @@ (etypecase sym (symbol - (if query - (load-os-constant sym query) - (progn - (when (eq (symbol-package sym) package) - (unless arg (setq arg 0)) - (ecase arg - (0 - (unless (and (constant-symbol-p sym) - (not (eq (%sym-global-value sym) - (%unbound-marker-8)))) - (load-os-constant sym))) - (1 (makunbound sym) (load-os-constant sym)))) - sym))) + (if query + (values (load-os-constant sym query) source) + (progn + (when (eq (symbol-package sym) package) + (unless arg (setq arg 0)) + (ecase arg + (0 + (unless (and (constant-symbol-p sym) + (not (eq (%sym-global-value sym) + (%unbound-marker-8)))) + (load-os-constant sym))) + (1 (makunbound sym) (load-os-constant sym)))) + (values sym source)))) (string - (let* ((val 0) - (len (length sym))) - (dotimes (i 4 val) - (let* ((ch (if (< i len) (char sym i) #\space))) - (setq val (logior (ash val 8) (char-code ch))))))))))))) + (let* ((val 0) + (len (length sym))) + (dotimes (i 4 (values val source)) + (let* ((ch (if (< i len) (char sym i) #\space))) + (setq val (logior (ash val 8) (char-code ch))))))))))))) (set-dispatch-macro-character #\# #\_ @@ -1039,5 +1039,5 @@ (declare (ignore char)) (unless arg (setq arg 0)) - (multiple-value-bind (sym query) + (multiple-value-bind (sym source query) (%read-symbol-preserving-case stream @@ -1046,11 +1046,12 @@ (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol)) (if query - (load-external-function sym t) - (let* ((def (if (eql arg 0) - (gethash sym (ftd-external-function-definitions - *target-ftd*))))) - (if (and def (eq (macro-function sym) #'%external-call-expander)) - sym - (load-external-function sym nil)))))))) + (values (load-external-function sym t) source) + (let* ((def (if (eql arg 0) + (gethash sym (ftd-external-function-definitions + *target-ftd*))))) + (values (if (and def (eq (macro-function sym) #'%external-call-expander)) + sym + (load-external-function sym nil)) + source))))))) (set-dispatch-macro-character Index: /branches/working-0711/ccl/lib/defstruct-lds.lisp =================================================================== --- /branches/working-0711/ccl/lib/defstruct-lds.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/defstruct-lds.lisp (revision 8421) @@ -257,4 +257,5 @@ ,(if (and predicate (null (sd-type sd))) `',predicate) ,.(if documentation (list documentation))) + (record-source-file ',(sd-name sd) 'structure) ,(%defstruct-compile sd refnames) ;; Wait until slot accessors are defined, to avoid Index: /branches/working-0711/ccl/lib/defstruct.lisp =================================================================== --- /branches/working-0711/ccl/lib/defstruct.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/defstruct.lisp (revision 8421) @@ -97,5 +97,4 @@ (set-documentation name 'type doc)) (puthash name %defstructs% sd) - (record-source-file name 'structure) (when (and predicate (null (sd-type sd))) (puthash predicate %structure-refs% name)) Index: /branches/working-0711/ccl/lib/encapsulate.lisp =================================================================== --- /branches/working-0711/ccl/lib/encapsulate.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/encapsulate.lisp (revision 8421) @@ -584,4 +584,13 @@ res)) +(defmacro with-traces (syms &body body) + `(unwind-protect + (progn + (let ((*trace-output* (make-broadcast-stream))) + ;; if you're tracing ccl internals you'll get trace output as it encapsulates the + ;; functions so hide all the trace output while eval'ing teh trace form itself. + (trace ,@syms)) + ,@body) + (untrace ,@syms))) ;; this week def is the name of an uninterned gensym whose fn-cell is original def @@ -683,5 +692,6 @@ (defun compile-named-function-warn (fn name) - (multiple-value-bind (result warnings)(compile-named-function fn name) + (multiple-value-bind (result warnings) + (compile-named-function fn :name name) (when warnings (let ((first t)) Index: /branches/working-0711/ccl/lib/misc.lisp =================================================================== --- /branches/working-0711/ccl/lib/misc.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/misc.lisp (revision 8421) @@ -704,5 +704,5 @@ (setq fun (closure-function fun))) (when (lambda-expression-p fun) - (setq fun (compile-named-function fun nil))) + (setq fun (compile-named-function fun))) fun)) Index: /branches/working-0711/ccl/lib/nfcomp.lisp =================================================================== --- /branches/working-0711/ccl/lib/nfcomp.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/nfcomp.lisp (revision 8421) @@ -101,37 +101,8 @@ pathname)) -(defun compile-file (src &key output-file - (verbose *compile-verbose*) - (print *compile-print*) - load - features - (target *fasl-target* target-p) - (save-local-symbols *fasl-save-local-symbols*) - (save-doc-strings *fasl-save-doc-strings*) - (save-definitions *fasl-save-definitions*) - (external-format :default) - force) - "Compile INPUT-FILE, producing a corresponding fasl file and returning - its filename." - (let* ((backend *target-backend*)) - (when (and target-p (not (setq backend (find-backend target)))) - (warn "Unknown :TARGET : ~S. Reverting to ~s ..." target *fasl-target*) - (setq target *fasl-target* backend *target-backend*)) - (loop - (restart-case - (return (%compile-file src output-file verbose print load features - save-local-symbols save-doc-strings save-definitions force backend external-format)) - (retry-compile-file () - :report (lambda (stream) (format stream "Retry compiling ~s" src)) - nil) - (skip-compile-file () - :report (lambda (stream) (format stream "Skip compiling ~s" src)) - (return)))))) - - (defun %compile-file (src output-file verbose print load features save-local-symbols save-doc-strings save-definitions force target-backend external-format + compile-file-original-truename compile-file-original-buffer-offset &aux orig-src) - (setq orig-src (merge-pathnames src)) (let* ((output-default-type (backend-target-fasl-pathname target-backend))) @@ -169,4 +140,6 @@ (*compile-file-pathname* orig-src) (*compile-file-truename* (truename src)) + (*compile-file-original-truename* compile-file-original-truename) + (*compile-file-original-buffer-offset* compile-file-original-buffer-offset) (*package* *package*) (*readtable* *readtable*) @@ -199,4 +172,35 @@ *fasl-non-style-warnings-signalled-p*)))) +(defun compile-file (src &key output-file + (verbose *compile-verbose*) + (print *compile-print*) + load + features + (target *fasl-target* target-p) + (save-local-symbols *fasl-save-local-symbols*) + (save-doc-strings *fasl-save-doc-strings*) + (save-definitions *fasl-save-definitions*) + (external-format :default) + force + compile-file-original-truename + (compile-file-original-buffer-offset 0)) + "Compile INPUT-FILE, producing a corresponding fasl file and returning + its filename." + (let* ((backend *target-backend*)) + (when (and target-p (not (setq backend (find-backend target)))) + (warn "Unknown :TARGET : ~S. Reverting to ~s ..." target *fasl-target*) + (setq target *fasl-target* backend *target-backend*)) + (loop + (restart-case + (return (%compile-file src output-file verbose print load features + save-local-symbols save-doc-strings save-definitions force backend external-format + compile-file-original-truename compile-file-original-buffer-offset)) + (retry-compile-file () + :report (lambda (stream) (format stream "Retry compiling ~s" src)) + nil) + (skip-compile-file () + :report (lambda (stream) (format stream "Skip compiling ~s" src)) + (return)))))) + (defvar *fcomp-locked-hash-tables*) (defvar *fcomp-load-forms-environment* nil) @@ -246,6 +250,7 @@ (signal c)))) (funcall (compile-named-function - `(lambda () ,form) nil env nil nil - *compile-time-evaluation-policy*))))) + `(lambda () ,form) + :env env + :policy *compile-time-evaluation-policy*))))) @@ -281,6 +286,4 @@ ;;;; Produces a list of (opcode . args) to run on loading, intermixed ;;;; with read packages. - -(defparameter *fasl-eof-forms* nil) (defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL")) @@ -382,16 +385,16 @@ (if (eq filename *compiling-file*) "Compiling" " Including") filename)) - (with-open-file (stream filename - :element-type 'base-char - :external-format *fcomp-external-format*) + (with-open-file (*fcomp-stream* filename + :element-type 'base-char + :external-format *fcomp-external-format*) (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*)) (*fasl-source-file* filename) - (*fcomp-toplevel-forms* nil) - (*fasl-eof-forms* nil) + (*fcomp-toplevel-forms* '()) (*loading-file-source-file* (namestring orig-file)) ; why orig-file??? (eofval (cons nil nil)) (read-package nil) - form) - (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*)) + *form-source-note-map* + (*nx1-source-note-map* (make-hash-table))) + (declare (special *fcomp-toplevel-forms* *fasl-source-file*)) ;;This should really be something like `(set-loading-source ;;,filename) but then couldn't compile level-1 with this... -> @@ -403,5 +406,7 @@ (let* ((*fcomp-previous-position* nil)) (loop - (let* ((*fcomp-stream-position* (file-position stream))) + (let* ((*fcomp-stream-position* (file-position *fcomp-stream*)) + (*definition-source-note* *definition-source-note*) + form) (unless (eq read-package *package*) (fcomp-compile-toplevel-forms env) @@ -410,21 +415,22 @@ (and *fcomp-load-time* cfasl-load-time-eval-sym))) (declare (special *reading-for-cfasl*)) - (let ((pos (file-position stream))) + (let ((pos (file-position *fcomp-stream*))) (handler-bind ((error #'(lambda (c) ; we should distinguish read errors from others? - (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename) + (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position *fcomp-stream*) filename) (signal c)))) - (setq form (read stream nil eofval))))) - (when (eq eofval form) (return)) + (multiple-value-bind (-form source-note) + (read-internal *fcomp-stream* nil eofval nil) + (when (eq -form eofval) + (return)) + (setf form -form + *definition-source-note* source-note + *form-source-note-map* (make-source-note-form-map source-note + *form-source-note-map*)))))) (fcomp-form form env processing-mode) (setq *fcomp-previous-position* *fcomp-stream-position*)))) - (while (setq form *fasl-eof-forms*) - (setq *fasl-eof-forms* nil) - (fcomp-form-list form env processing-mode)) (when old-file (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*))) (fcomp-compile-toplevel-forms env)))) - - (defun fcomp-form (form env processing-mode @@ -468,13 +474,30 @@ ""))))))) (fcomp-form-1 form env processing-mode))) - + +(defun record-form-source-equivalent/list (form list) + (dolist (f list) + (record-form-source-equivalent form f))) + (defun fcomp-form-1 (form env processing-mode &aux sym body) (if (consp form) (setq sym (%car form) body (%cdr form))) (case sym - (progn (fcomp-form-list body env processing-mode)) - (eval-when (fcomp-eval-when body env processing-mode)) - (compiler-let (fcomp-compiler-let body env processing-mode)) - (locally (fcomp-locally body env processing-mode)) - (macrolet (fcomp-macrolet body env processing-mode)) + (progn + (record-form-source-equivalent/list form body) + (fcomp-form-list body env processing-mode)) + (eval-when + (record-form-source-equivalent/list form body) + (fcomp-eval-when body env processing-mode)) + (compiler-let + (record-form-source-equivalent/list form body) + (fcomp-compiler-let body env processing-mode)) + (locally + (record-form-source-equivalent/list form body) + (fcomp-locally body env processing-mode)) + (macrolet + (record-form-source-equivalent/list form body) + (fcomp-macrolet body env processing-mode)) + ;; special case for passing around source-location info + (%source-note (fcomp-form (list 'quote (source-note-to-list *definition-source-note*)) + env processing-mode)) ((%include include) (fcomp-include form env processing-mode)) (t @@ -488,12 +511,18 @@ (not (compiler-macro-function sym env)) (not (eq sym '%defvar-init)) ; a macro that we want to special-case - (multiple-value-bind (new win) (macroexpand-1 form env) - (if win (setq form new)) + (multiple-value-bind (new win) + (macroexpand-1 form env) + (if win + (progn + (record-form-source-equivalent form new) + (setf form new))) win)) (fcomp-form form env processing-mode)) ((and (not *fcomp-inside-eval-always*) (memq sym *fcomp-eval-always-functions*)) - (let* ((*fcomp-inside-eval-always* t)) - (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-toplevel) ,form) env processing-mode))) + (let* ((*fcomp-inside-eval-always* t) + (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form))) + (record-form-source-equivalent form new) + (fcomp-form-1 new env processing-mode))) (t (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too)) @@ -504,5 +533,7 @@ ((%defparameter) (fcomp-load-%defparameter form env)) ((%defvar %defvar-init) (fcomp-load-defvar form env)) - ((%defun) (fcomp-load-%defun form env)) + ((%defun) + (let ((*definition-source-note* (gethash form *form-source-note-map*))) + (fcomp-load-%defun form env))) ((set-package %define-package) (fcomp-random-toplevel-form form env) @@ -514,5 +545,6 @@ (defun fcomp-form-list (forms env processing-mode) - (dolist (form forms) (fcomp-form form env processing-mode))) + (dolist (form forms) + (fcomp-form form env processing-mode))) (defun fcomp-compiler-let (form env processing-mode &aux vars varinits) @@ -522,6 +554,6 @@ (push (%compile-time-eval (nx-pair-initform pair) env) varinits)) (progv (nreverse vars) (nreverse varinits) - (fcomp-form-list form env processing-mode) - (fcomp-compile-toplevel-forms env))) + (fcomp-form-list form env processing-mode) + (fcomp-compile-toplevel-forms env))) (defun fcomp-locally (body env processing-mode) @@ -654,5 +686,5 @@ (push (list* name 'macro - (compile-named-function lambda-expression name env)) + (compile-named-function lambda-expression :name name :env env)) (defenv.functions definition-env))) name)) @@ -729,4 +761,5 @@ (setf (car (cadr doc)) nil)) (setq doc nil))) + (record-form-source-equivalent form fn) (if (and (constantp doc) (setq fn (fcomp-function-arg fn env))) @@ -738,4 +771,5 @@ (defun fcomp-load-%macro (form env &aux fn doc) (verify-arg-count form 1 2) + (record-form-source-equivalent form (cadr form)) (if (and (constantp (setq doc (caddr form))) (setq fn (fcomp-function-arg (cadr form) env))) @@ -777,4 +811,5 @@ (let (lfun (args (%cdr form))) (while args + (record-form-source-equivalent form (first args)) (multiple-value-bind (arg win) (fcomp-transform (%car args) env) (when (or (setq lfun (fcomp-function-arg arg env)) @@ -790,11 +825,14 @@ (defun fcomp-function-arg (expr env) (when (consp expr) - (if (and (eq (%car expr) 'nfunction) - (symbolp (car (%cdr expr))) - (lambda-expression-p (car (%cddr expr)))) - (fcomp-named-function (%caddr expr) (%cadr expr) env) - (if (and (eq (%car expr) 'function) - (lambda-expression-p (car (%cdr expr)))) - (fcomp-named-function (%cadr expr) nil env))))) + (cond + ((and (eq (%car expr) 'nfunction) + (symbolp (%cadr expr)) + (lambda-expression-p (%caddr expr))) + (record-form-source-equivalent expr (%caddr expr)) + (fcomp-named-function (%caddr expr) (%cadr expr) env)) + ((and (eq (%car expr) 'function) + (lambda-expression-p (%cadr expr))) + (record-form-source-equivalent expr (%cadr expr)) + (fcomp-named-function (%cadr expr) nil env))))) (defun fcomp-compile-toplevel-forms (env) @@ -809,5 +847,6 @@ (compiler-function-overflow))) ,@forms))))) - (setq *fcomp-toplevel-forms* nil) + (record-form-source-equivalent/list lambda forms) + (setq *fcomp-toplevel-forms* '()) ;(format t "~& Random toplevel form: ~s" lambda) (handler-case (fcomp-output-form @@ -838,12 +877,12 @@ (let* ((env (new-lexical-environment env))) (multiple-value-bind (lfun warnings) - (compile-named-function - def name - env - *fasl-save-definitions* - *fasl-save-local-symbols* - *default-file-compilation-policy* - cfasl-load-time-eval-sym - *fasl-target*) + (compile-named-function def + :name name + :env env + :keep-lambda *fasl-save-definitions* + :keep-symbols *fasl-save-local-symbols* + :policy *default-file-compilation-policy* + :load-time-eval-token cfasl-load-time-eval-sym + :target *fasl-target*) (fcomp-signal-or-defer-warnings warnings env) lfun))) Index: /branches/working-0711/ccl/lib/read.lisp =================================================================== --- /branches/working-0711/ccl/lib/read.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/read.lisp (revision 8421) @@ -46,8 +46,4 @@ (cons form (read-file-to-list-aux stream)))))) |# - -(defun read-internal (input-stream) - (read input-stream t nil t)) - (set-dispatch-macro-character #\# #\* @@ -96,7 +92,7 @@ (signal-reader-error stream "reader macro #A used without a rank integer")) ((eql dimensions 0) ;0 dimensional array - (make-array nil :initial-contents (read-internal stream))) + (make-array nil :initial-contents (read-internal stream t nil t))) ((and (integerp dimensions) (> dimensions 0)) - (let ((init-list (read-internal stream))) + (let ((init-list (read-internal stream t nil t))) (cond ((not (typep init-list 'sequence)) (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list)) @@ -130,5 +126,5 @@ (qlfun |#S-reader| (input-stream sub-char int &aux list sd) (declare (ignore sub-char int)) - (setq list (read-internal input-stream)) + (setq list (read-internal input-stream t nil t)) (unless *read-suppress* (unless (and (consp list) Index: /branches/working-0711/ccl/lib/source-files.lisp =================================================================== --- /branches/working-0711/ccl/lib/source-files.lisp (revision 8420) +++ /branches/working-0711/ccl/lib/source-files.lisp (revision 8421) @@ -16,4 +16,24 @@ (in-package "CCL") + +#| (defun definition-source (object &object environment) + + (flet ((definition-note (lfun) + (getf (getf lfun 'code-source-map) :definition-source-note))) + (etypecase object + (symbol (append (when (find-class object nil environment) + (definition-source (find-class object) environment)) + (when (fboundp object) + (definition-source (symbol-function object) environment)) + (when (boundp object) + (variable-definition-source object environment)))) + (standard-generic-function + (append (list :generic-function (definition-note ))))))) |# + +#| (defun variable-definition-source (var-name) + (gethash var-name %source-notes-for-varibales-and-constants%)) + +(defvar %source-notes-for-varibales-and-constants% + (make-hash-table :test #'eq :weak t :size 7000 :rehash-threshold .9)) |# (defvar %source-files% (let ((a (make-hash-table :test #'eq Index: /branches/working-0711/ccl/library/lispequ.lisp =================================================================== --- /branches/working-0711/ccl/library/lispequ.lisp (revision 8420) +++ /branches/working-0711/ccl/library/lispequ.lisp (revision 8421) @@ -139,5 +139,5 @@ (defconstant $lfbits-aok-bit 16) (defconstant $lfbits-numinh (byte 6 17)) -(defconstant $lfbits-symmap-bit 23) +(defconstant $lfbits-info-bit 23) (defconstant $lfbits-trampoline-bit 24) (defconstant $lfbits-evaluated-bit 25)