Changeset 8390


Ignore:
Timestamp:
Feb 1, 2008, 8:51:22 AM (17 years ago)
Author:
marco baringer
Message:

Source-location tracking patch. Ready for working-0711 users testing

Location:
branches/source-tracking-0801/ccl
Files:
23 edited

Legend:

Unmodified
Added
Removed

  • branches/source-tracking-0801/ccl/compiler/PPC/ppc2.lisp

    r7715 r8390  
    471471                         (setq function-debugging-info (nconc (list 'function-symbol-map *ppc2-recorded-symbols*)
    472472                                                              function-debugging-info)))
    473                        (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
     473                       (setq bits (logior (ash 1 $lfbits-info-bit) bits))
    474474                       (backend-new-immediate function-debugging-info)))
    475475                   (if (or fname lambda-form *ppc2-recorded-symbols*)

  • branches/source-tracking-0801/ccl/compiler/X86/x86-disassemble.lisp

    r8005 r8390  
    27072707
    27082708
     2709(defun string-sans-most-whitespace (string &optional (max-length (length string)))
     2710  (with-output-to-string (sans-whitespace)
     2711    (loop
     2712      for count below max-length
     2713      for char across string
     2714      with just-saw-space = nil
     2715      if (member char '(#\Space #\Tab #\Newline #\Return #\Formfeed))
     2716        do (if just-saw-space
     2717               (decf count)
     2718               (write-char #\Space sans-whitespace))
     2719        and do (setf just-saw-space t)
     2720      else
     2721        do (setf just-saw-space nil)
     2722        and do (write-char char sans-whitespace))))   
    27092723   
    2710    
    2711 (defun x86-print-disassembled-instruction (ds instruction seq)
     2724(defun x86-print-disassembled-instruction (ds instruction seq function)
     2725  (declare (special *previous-instruction* *previous-block*))
    27122726  (let* ((addr (x86-di-address instruction))
    27132727         (entry (x86-ds-entry-point ds)))
    2714     (when (x86-di-labeled instruction)
    2715       (format t "~&L~d~&" (- addr entry))
    2716       (setq seq 0))
     2728    (let* ((pc (- addr entry)))
     2729      (let* ((source-note (getf (%lfun-info function) 'function-source-note))
     2730             (source-info (find-source-at-pc function pc))
     2731             (text (if source-info
     2732                       (string-sans-most-whitespace
     2733                        (subseq (getf source-note :text)
     2734                                (car (getf source-info :source-text-range))
     2735                                (cdr (getf source-info :source-text-range)))
     2736                        100)
     2737                       "#<no source text>")))
     2738        (declare (special *previous-source-note*))
     2739        (unless (string= text *previous-source-note*)
     2740          (format t "~&~%;;; ~A" text)
     2741          (setf *previous-source-note* text)))
     2742      (when (x86-di-labeled instruction)
     2743        (format t "~&L~d~%" pc)
     2744        (setq seq 0))
     2745      (format t "~&  [~D]~8T" pc))
    27172746    (dolist (p (x86-di-prefixes instruction))
    27182747      (format t "~&  (~a)~%" p))
    2719     (format t "~&  (~a" (x86-di-mnemonic instruction))
     2748    (format t "  (~a" (x86-di-mnemonic instruction))
    27202749    (let* ((op0 (x86-di-op0 instruction))
    27212750           (op1 (x86-di-op1 instruction))
    … …  
    27282757            (format t " ~a" (unparse-x86-lap-operand op2 ds))))))
    27292758    (format t ")")
    2730     (unless (zerop seq) ;(when (oddp seq)
    2731       (format t "~50t;[~d]" (- addr entry)))
    27322759    (format t "~%")
    27332760    (1+ seq)))
    27342761
    2735 
    2736 (defun x8664-disassemble-xfunction (xfunction &key (symbolic-names
    2737                                                          x8664::*x8664-symbolic-register-names*) (collect-function #'x86-print-disassembled-instruction))
     2762(defun x86-print-disassembled-function-header (function xfunction)
     2763  (declare (ignore xfunction))
     2764    (let ((source-note (getf (%lfun-info function) 'function-source-note)))
     2765    (when source-note
     2766      (format t ";; Source: ~S:~D-~D"
     2767              (getf source-note :file-name)
     2768              (getf source-note :start)
     2769              (getf source-note :end)))))
     2770
     2771(defun x8664-disassemble-xfunction (function xfunction
     2772                                    &key (symbolic-names x8664::*x8664-symbolic-register-names*)
     2773                                         (collect-function #'x86-print-disassembled-instruction)
     2774                                         (header-function #'x86-print-disassembled-function-header))
    27382775  (check-type xfunction xfunction)
    27392776  (check-type (uvref xfunction 0) (simple-array (unsigned-byte 8) (*)))
    … …  
    27532790        (or (x86-dis-find-label lab blocks)
    27542791            (x86-disassemble-new-block ds lab))))
    2755     (let* ((seq 0))
     2792    (when (and blocks (let ((something-to-disassemble nil))
     2793                        (do-dll-nodes (block blocks)
     2794                          (do-dll-nodes (instruction (x86-dis-block-instructions block))
     2795                            (setf something-to-disassemble t)))
     2796                        something-to-disassemble))
     2797      (funcall header-function function xfunction))
     2798    (let* ((seq 0)
     2799           (*previous-source-note* nil))
     2800      (declare (special *previous-source-note*))
    27562801      (do-dll-nodes (block blocks)
    27572802        (do-dll-nodes (instruction (x86-dis-block-instructions block))
    2758           (setq seq (funcall collect-function ds instruction seq)))))))
     2803          (setq seq (funcall collect-function ds instruction seq function)))))))
    27592804
    27602805#+x8664-target
    2761 (defun x8664-xdisassemble (function &optional (collect-function #'x86-print-disassembled-instruction ))
     2806(defun x8664-xdisassemble (function
     2807                           &optional (collect-function #'x86-print-disassembled-instruction)
     2808                                     (header-function #'x86-print-disassembled-function-header))
    27622809  (let* ((fv (%function-to-function-vector function))
    27632810         (function-size-in-words (uvsize fv))
    … …  
    27742821          (j 1 (1+ j)))
    27752822         ((= k function-size-in-words)
    2776           (x8664-disassemble-xfunction xfunction :collect-function collect-function))
     2823          (x8664-disassemble-xfunction function xfunction
     2824                                       :collect-function collect-function
     2825                                       :header-function header-function))
    27772826      (declare (fixnum j k))
    27782827      (setf (uvref xfunction j) (uvref fv k)))))

  • branches/source-tracking-0801/ccl/compiler/X86/x862.lisp

    r8019 r8390  
    175175(defvar *x862-record-symbols* nil)
    176176(defvar *x862-recorded-symbols* nil)
     177(defvar *x862-emitted-source-notes* '()
     178  "List of all the :source-location-begin notes we've emitted during this compile.")
     179(defvar *definition-source-note* nil
     180  "Represents the current 'toplevel' source note. Exists mainly so that (progn (defun a ..) (defun b
     181  ..)) can do the 'right' thing.")
    177182
    178183(defvar *x862-result-reg* x8664::arg_z)
    … …  
    428433    (min (- (ash ea (- x8664::word-shift)) count) #xff)))
    429434
    430 
    431435(defun x862-compile (afunc &optional lambda-form *x862-record-symbols*)
    432436  (progn
    … …  
    434438      (unless (afunc-lfun a)
    435439        (x862-compile a
    436                       (if lambda-form
    437                         (afunc-lambdaform a))
     440                      (if lambda-form (afunc-lambdaform a))
    438441                      *x862-record-symbols*))) ; always compile inner guys
    439442    (let* ((*x862-cur-afunc* afunc)
    … …  
    504507           (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
    505508           (*x862-fcells* (afunc-fcells afunc))
    506            *x862-recorded-symbols*)
     509           *x862-recorded-symbols*
     510           (*x862-emitted-source-notes* '()))
    507511      (set-fill-pointer
    508512       *backend-labels*
    … …  
    536540                   (make-x86-lap-label end-code-tag)
    537541                   (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
    538                                                              *x86-lap-entry-offset*) -3))
     542                                                               *x86-lap-entry-offset*) -3))
    539543                   (x86-lap-directive frag-list :byte 0) ;regsave PC
    540544                   (x86-lap-directive frag-list :byte 0) ;regsave ea
    … …  
    570574                 
    571575                   (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
    572                      (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
    573                    (let* ((function-debugging-info (afunc-lfun-info afunc)))
    574                      (when (or function-debugging-info lambda-form *x862-record-symbols*)
    575                        (if lambda-form (setq function-debugging-info
    576                                              (list* 'function-lambda-expression lambda-form function-debugging-info)))
    577                        (if *x862-record-symbols*
    578                          (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
    579                                                               function-debugging-info)))
    580                        (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
    581                        (setq debug-info function-debugging-info)))
    582                    (unless (or fname lambda-form *x862-recorded-symbols*)
    583                      (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
     576                       (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
     577                   
     578                   
     579                   
    584580                   (unless (afunc-parent afunc)
    585581                     (x862-fixup-fwd-refs afunc))
    586582                   (setf (afunc-all-vars afunc) nil)
    587                    (setf (afunc-argsword afunc) bits)
     583                   
    588584                   (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
    589                                            (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
     585                                             (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
    590586                          (regsave-mask (if regsave-label (x862-register-mask-byte
    591587                                                           *x862-register-restore-count*)))
    … …  
    593589                                                           *x862-register-restore-ea*
    594590                                                           *x862-register-restore-count*))))
    595                      (when debug-info
     591                     
     592                     (when (or lambda-form
     593                               (and *compiler-record-source* *definition-source-note*)
     594                               *x862-recorded-symbols*
     595                               (and *compiler-record-source* *x862-emitted-source-notes*))
    596596                       (x86-lap-directive frag-list :quad 0))
    597597                     (when fname
    … …  
    602602                     (fill-for-alignment frag-list)
    603603                     (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
     604                     (setf debug-info
     605                           (nconc (when lambda-form
     606                                    (list 'function-debugging-info lambda-form))
     607                                  (when (and *compiler-record-source* *definition-source-note*)
     608                                    (list 'function-source-note
     609                                          (source-note-to-list *definition-source-note* :form nil :children nil)))
     610                                  (when *x862-recorded-symbols*
     611                                    (list 'function-symbol-map (x862-digest-symbols)))
     612                                  (when (and *compiler-record-source*
     613                                             *x862-emitted-source-notes*
     614                                             *definition-source-note*)
     615                                    (list 'pc-source-map
     616                                          (x862-generate-pc-source-map *definition-source-note*
     617                                                                       *x862-emitted-source-notes*)))))
     618                     (when debug-info
     619                       (setq bits (logior (ash 1 $lfbits-info-bit) bits)))
     620                     (unless fname
     621                       (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
     622                     (setf (afunc-argsword afunc) bits)
    604623                     (setf (afunc-lfun afunc)
    605624                           #+x86-target
    606625                           (if (eq *host-backend* *target-backend*)
    607                              (create-x86-function fname frag-list *x862-constant-alist* bits debug-info)
    608                              (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
     626                               (create-x86-function fname frag-list *x862-constant-alist* bits debug-info)
     627                               (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
    609628                           #-x86-target
    610                            (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))
    611                    (x862-digest-symbols)))))
     629                           (cross-create-x86-function fname frag-list *x862-constant-alist* bits ())))
     630                   ))))
    612631          (backend-remove-labels))))
    613632    afunc))
    614 
    615 
    616      
    617633   
    618634(defun x862-make-stack (size &optional (subtype target::subtag-s16-vector))
    … …  
    644660                (setf (%svref v i) ref-fun)))))))))
    645661
     662(defun x862-generate-pc-source-map (definition-source-note emitted-source-notes)
     663  (when *compiler-record-source*
     664    (let ((def-start (source-note-start definition-source-note)))
     665      (mapcar (lambda (start)
     666                (list :pc-range (cons (x862-vinsn-note-label-address
     667                                       start
     668                                       t)
     669                                      (x862-vinsn-note-label-address
     670                                       (vinsn-note-peer start)
     671                                       nil))
     672                      :source-text-range (cons (- (source-note-start (aref (vinsn-note-info start) 0))
     673                                                  def-start)
     674                                               (- (source-note-end (aref (vinsn-note-info start) 0))
     675                                                  def-start))))
     676              emitted-source-notes))))
     677
     678(defun x862-vinsn-note-label-address (note &optional start-p sym)
     679  (-
     680   (let* ((label (vinsn-note-label note))
     681          (lap-label (if label (vinsn-label-info label))))
     682     (if lap-label
     683         (x86-lap-label-address lap-label)
     684         (compiler-bug "Missing or bad ~s label~@[: ~s~]"
     685                       (if start-p 'start 'end)
     686                       sym)))
     687   x8664::fulltag-function))
     688
    646689(defun x862-digest-symbols ()
    647690  (if *x862-recorded-symbols*
    648     (let* ((symlist *x862-recorded-symbols*)
    649            (len (length symlist))
    650            (syms (make-array len))
    651            (ptrs (make-array (%i+  (%i+ len len) len)))
    652            (i -1)
    653            (j -1))
    654       (declare (fixnum i j))
    655       (dolist (info symlist (progn (%rplaca symlist syms)
    656                                    (%rplacd symlist ptrs)))
    657         (flet ((label-address (note start-p sym)
    658                  (-
    659                   (let* ((label (vinsn-note-label note))
    660                          (lap-label (if label (vinsn-label-info label))))
    661                     (if lap-label
    662                       (x86-lap-label-address lap-label)
    663                       (compiler-bug "Missing or bad ~s label: ~s"
    664                                     (if start-p 'start 'end) sym)))
    665                   x8664::fulltag-function)))
     691      (let* ((symlist *x862-recorded-symbols*)
     692             (len (length symlist))
     693             (syms (make-array len))
     694             (ptrs (make-array (%i+  (%i+ len len) len)))
     695             (i -1)
     696             (j -1))
     697        (declare (fixnum i j))
     698        (dolist (info symlist (progn (%rplaca symlist syms)
     699                                     (%rplacd symlist ptrs)))
    666700          (destructuring-bind (var sym startlab endlab) info
    667701            (let* ((ea (var-ea var))
    668702                   (ea-val (ldb (byte 16 0) ea)))
    669703              (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
    670                                            (logior (ash ea-val 6) #o77)
    671                                            ea-val)))
     704                                             (logior (ash ea-val 6) #o77)
     705                                             ea-val)))
    672706            (setf (aref syms (incf j)) sym)
    673             (setf (aref ptrs (incf i)) (label-address startlab t sym))
    674             (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))
     707            (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address startlab t sym))
     708            (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address endlab nil sym))))
     709        *x862-recorded-symbols*)))
    675710
    676711(defun x862-decls (decls)
    … …  
    10881123    n))
    10891124
     1125(defun x862-emit-source-note (seg class nx1-form)
     1126  (check-type class (member :source-location-begin :source-location-end))
     1127  (when (nx1-source-note nx1-form)
     1128    (x862-emit-note seg class (nx1-source-note nx1-form))))
     1129
     1130(defmacro x862-wrap-in-source-notes ((seg form) &body body)
     1131  (let ((x862-wrap-in-source-notes-body (gensym "X862-WRAP-IN-SOURCE-NOTES-BODY-")))
     1132    `(flet ((,x862-wrap-in-source-notes-body () ,@body))
     1133       (call-with-x862-wrap-in-source-notes ,seg ,form #',x862-wrap-in-source-notes-body))))
     1134
     1135(defun call-with-x862-wrap-in-source-notes (seg form thunk)
     1136  (let (start end)
     1137    (setf start (x862-emit-source-note seg :source-location-begin form))
     1138    (multiple-value-prog1
     1139        (funcall thunk)
     1140      (setf end (x862-emit-source-note seg :source-location-end form))
     1141      (when (and start end)
     1142        (setf (vinsn-note-peer start) end
     1143              (vinsn-note-peer end) start
     1144              *x862-emitted-source-notes* (cons start *x862-emitted-source-notes*))))))
    10901145
    10911146(defun x862-form (seg vreg xfer form)
    1092   (if (nx-null form)
    1093     (x862-nil seg vreg xfer)
    1094     (if (nx-t form)
    1095       (x862-t seg vreg xfer)
    1096       (let* ((op nil)
    1097              (fn nil))
    1098         (if (and (consp form)
    1099                  (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1100           (if (and (null vreg)
    1101                    (%ilogbitp operator-acode-subforms-bit op)
    1102                    (%ilogbitp operator-assignment-free-bit op))
    1103             (dolist (f (%cdr form) (x862-branch seg xfer))
    1104               (x862-form seg nil nil f ))
    1105             (apply fn seg vreg xfer (%cdr form)))
    1106           (compiler-bug "x862-form ? ~s" form))))))
     1147  (x862-wrap-in-source-notes (seg form)
     1148     (if (nx-null form)
     1149         (x862-nil seg vreg xfer)
     1150         (if (nx-t form)
     1151             (x862-t seg vreg xfer)
     1152             (let* ((op nil)
     1153                    (fn nil))
     1154               (if (and (consp form)
     1155                        (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
     1156                   (if (and (null vreg)
     1157                            (%ilogbitp operator-acode-subforms-bit op)
     1158                            (%ilogbitp operator-assignment-free-bit op))
     1159                       (dolist (f (%cdr form) (x862-branch seg xfer))
     1160                         (x862-form seg nil nil f ))
     1161                       (apply fn seg vreg xfer (%cdr form)))
     1162                   (compiler-bug "x862-form ? ~s" form)))))))
    11071163
    11081164;;; dest is a float reg - form is acode
    … …  
    50795135  (let* ((lab (vinsn-note-label note)))
    50805136    (case (vinsn-note-class note)
    5081       ((:regsave :begin-variable-scope :end-variable-scope)
     5137      ((:regsave :begin-variable-scope :end-variable-scope
     5138        :source-location-begin :source-location-end)
    50825139       (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))))))
    50835140
    … …  
    91079164                         *target-ftd*)))
    91089165    (multiple-value-bind (xlfun warnings)
    9109         (compile-named-function def nil
    9110                                 nil
    9111                                 nil
    9112                                 nil
    9113                                 nil
    9114                                 nil
    9115                                 target)
     9166        (compile-named-function def :target target)
    91169167      (signal-or-defer-warnings warnings nil)
    91179168      (when disassemble

  • branches/source-tracking-0801/ccl/compiler/lambda-list.lisp

    r4020 r8390  
    2121;;; Compiler functions needed elsewhere
    2222
    23 ;;; used-by: backtrace, arglist
    24 (defun function-symbol-map (fn)
    25   (getf (%lfun-info fn) 'function-symbol-map))
     23;;; mb: HACK HACK HACKITY HACK
     24(defconstant $lfbits-info-bit 23)
    2625
    2726(defun %lfun-info-index (fn)
    … …  
    2928       (let ((bits (lfun-bits fn)))
    3029         (declare (fixnum bits))
    31          (and (logbitp $lfbits-symmap-bit bits)
     30         (and (logbitp $lfbits-info-bit bits)
    3231               (%i- (uvsize (function-to-function-vector fn))
    3332                              (if (logbitp $lfbits-noname-bit bits) 2 3))))))
    … …  
    3938  (getf (%lfun-info fn) 'function-lambda-expression ))
    4039
     40;;; used-by: backtrace, arglist
     41(defun function-symbol-map (fn)
     42  (getf (%lfun-info fn) 'function-symbol-map))
     43
     44(defun function-source-text (fn)
     45  (getf (%lfun-info fn) 'text))
    4146
    4247;;; Lambda-list utilities

  • branches/source-tracking-0801/ccl/compiler/nx.lisp

    r7719 r8390  
    8888                       (if (functionp def)
    8989                         def
    90                          (compile-named-function def spec nil *save-definitions* *save-local-symbols*))
     90                         (compile-named-function def
     91                                                 :name spec
     92                                                 :keep-lambda *save-definitions*
     93                                                 :keep-symbols *save-local-symbols*))
    9194    (let ((harsh nil) (some nil) (init t))
    9295      (dolist (w warnings)
    … …  
    121124         (*target-backend* (or backend *target-backend*)))
    122125    (multiple-value-bind (xlfun warnings)
    123         (compile-named-function def nil
    124                                 nil
    125                                 nil
    126                                 nil
    127                                 nil
    128                                 nil
    129                                 target)
     126        (compile-named-function def :target target)
    130127      (signal-or-defer-warnings warnings nil)
    131128      (ppc-xdisassemble xlfun :target target)
    132129      xlfun)))
    133  
    134 (defun compile-user-function (def name &optional env)
    135   (multiple-value-bind (lfun warnings)
    136                        (compile-named-function def name
    137                                                env
    138                                                *save-definitions*
    139                                                *save-local-symbols*)
    140     (signal-or-defer-warnings warnings env)
    141     lfun))
    142130
    143131(defun signal-or-defer-warnings (warnings env)
    … …  
    154142(defparameter *load-time-eval-token* nil)
    155143
    156 
    157 
    158 
    159144(eval-when (:compile-toplevel)
    160145  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
    … …  
    163148
    164149(defun compile-named-function
    165     (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target)
     150    (definition &key name env keep-lambda keep-symbols policy load-time-eval-token target)
    166151  (when (and name *nx-discard-xref-info-hook*)
    167152    (funcall *nx-discard-xref-info-hook* name))
    168153  (setq
    169    def
    170    (let ((env (new-lexical-environment env)))
     154   definition
     155   (let ((*load-time-eval-token* load-time-eval-token)
     156         (env (new-lexical-environment env)))
    171157     (setf (lexenv.variables env) 'barrier)
    172158       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
    173159              (afunc (nx1-compile-lambda
    174160                      name
    175                       def
     161                      definition
    176162                      (make-afunc)
    177163                      nil
    … …  
    180166                      *load-time-eval-token*)))
    181167         (if (afunc-lfun afunc)
    182            afunc
    183            (funcall (backend-p2-compile *target-backend*)
    184             afunc
    185             ; will also bind *nx-lexical-environment*
    186             (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
    187             keep-symbols)))))
    188   (values (afunc-lfun def) (afunc-warnings def)))
    189 
    190 
     168             afunc
     169             (funcall (backend-p2-compile *target-backend*)
     170                      afunc
     171                      ;; will also bind *nx-lexical-environment*
     172                      (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition))
     173                      keep-symbols)))))
     174  (values (afunc-lfun definition) (afunc-warnings definition)))
    191175 
    192 
    193 
    194 
     176(defun compile-user-function (def name &optional env)
     177  (multiple-value-bind (lfun warnings)
     178      (compile-named-function def
     179                              :name name
     180                              :env env
     181                              :keep-lambda *save-definitions*
     182                              :keep-symbols *save-local-symbols*)
     183    (signal-or-defer-warnings warnings env)
     184    lfun))
    195185
    196186(defparameter *compiler-whining-conditions*
    … …  
    213203(provide 'nx)
    214204
     205;;; mb: HACK HACK HACKITY HACK
     206
     207(defun %compile-time-eval (form env)
     208  (let* ((*target-backend* *host-backend*))
     209    ;; The HANDLER-BIND here is supposed to note WARNINGs that're
     210    ;; signaled during (eval-when (:compile-toplevel) processing; this
     211    ;; in turn is supposed to satisfy a pedantic interpretation of the
     212    ;; spec's requirement that COMPILE-FILE's second and third return
     213    ;; values reflect (all) conditions "detected by the compiler."
     214    ;; (It's kind of sad that CL language design is influenced so
     215    ;; strongly by the views of pedants these days.)
     216    (handler-bind ((warning (lambda (c)
     217                              (setq *fasl-warnings-signalled-p* t)
     218                              (unless (typep c 'style-warning)
     219                                (setq *fasl-non-style-warnings-signalled-p* t))
     220                              (signal c))))
     221      (funcall (compile-named-function
     222                `(lambda () ,form)
     223                :env env
     224                :policy *compile-time-evaluation-policy*)))))
     225
     226(defun define-compile-time-macro (name lambda-expression env)
     227  (let ((definition-env (definition-environment env)))
     228    (if definition-env
     229      (push (list* name
     230                   'macro
     231                   (compile-named-function lambda-expression :name name :env env))
     232            (defenv.functions definition-env)))
     233    name))
     234
     235(defun fcomp-named-function (def name env)
     236  (let* ((env (new-lexical-environment env)))
     237    (multiple-value-bind (lfun warnings)
     238                         (compile-named-function def
     239                                                 :name name
     240                                                 :env env
     241                                                 :keep-lambda *fasl-save-definitions*
     242                                                 :keep-symbols *fasl-save-local-symbols*
     243                                                 :policy *default-file-compilation-policy*
     244                                                 :load-time-eval-token cfasl-load-time-eval-sym
     245                                                 :target *fasl-target*)
     246      (fcomp-signal-or-defer-warnings warnings env)
     247      lfun)))

  • branches/source-tracking-0801/ccl/compiler/nx0.lisp

    r7939 r8390  
    208208    (let ((body (parse-macro-1 block-name arglist body env)))
    209209      `(eval-when (:compile-toplevel :load-toplevel :execute)
    210         (eval-when (:load-toplevel :execute)
    211           (record-source-file ',name 'compiler-macro))
    212         (setf (compiler-macro-function ',name)
    213          (nfunction (compiler-macro-function ,name)  ,body))
    214         ',name))))
     210         (record-source-file ',name 'compiler-macro)
     211         (setf (compiler-macro-function ',name)
     212               (nfunction (compiler-macro-function ,name)  ,body))
     213         ',name))))
    215214
    216215;;; This is silly (as may be the whole idea of actually -using-
    … …  
    12451244                      (%ilogand $vrefmask
    12461245                                (%i+ (%i- boundtocount 1) varcount)))))))))
     1246
     1247(defvar *compiler-record-source* t
     1248  "When T we record source location for compiled forms.")
     1249
     1250(defvar *nx1-source-note-map* nil
     1251  "Mapping between nx1-forms source locations.")
    12471252
    12481253(defun nx1-compile-lambda (name lambda-form &optional
    … …  
    15571562    (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
    15581563
     1564(defvar *fcomp-stream* nil
     1565  "The stream we're reading code to be compiled from.")
     1566
     1567(defvar *compile-file-original-truename* nil)
     1568
     1569(defvar *compile-file-original-buffer-offset* nil)
     1570
     1571(defun substream (stream start &optional end)
     1572  "like subseq, but on streams that support file-position. Leaves stream positioned where it was
     1573before calling substream."
     1574  (cond
     1575    ((stringp stream)
     1576     (subseq stream start end))
     1577    ((typep stream 'string-input-stream)
     1578     (subseq (slot-value stream 'string) start end))
     1579    ((not (open-stream-p stream))
     1580     (if (typep stream 'file-stream)
     1581          (if (probe-file (stream-pathname stream))
     1582              (with-open-file (f (stream-pathname stream)) ; I should really understand how this happens.
     1583                (substream f start end))
     1584              "")
     1585          ""))
     1586    (t
     1587     (let ((now (file-position stream)))
     1588       (file-position stream start)
     1589       (let ((string (make-string (- (or end now) start))))
     1590         (unwind-protect
     1591              (read-sequence string stream)
     1592           (file-position stream now))
     1593         string)))))
     1594
     1595(defun record-source-location (stream)
     1596  (if (and *compiler-record-source* *fcomp-stream*)
     1597      (if (eq *fcomp-stream* stream)
     1598          t
     1599          (progn
     1600            ;; if we don't set *compiler-record-source* to NIL here all subsequent calls to read in
     1601            ;; the debugger will fail. that would be bad.
     1602            (setf *compiler-record-source* nil)
     1603            (error "Attempting to record source on stream ~S but *fcomp-stream* is ~S."
     1604                   stream *fcomp-stream*)))
     1605      nil))
     1606
     1607(defstruct (source-note (:constructor %make-source-note))
     1608  file-name
     1609  start
     1610  end
     1611  text
     1612  form
     1613  children)
     1614
     1615(defun make-source-note (&key stream start end text form children)
     1616  (when (record-source-location stream)
     1617    (%make-source-note :file-name (or *compile-file-original-truename*
     1618                                      (truename stream))
     1619                       :start (+ start (or *compile-file-original-buffer-offset* 0))
     1620                       :end (+ end (or *compile-file-original-buffer-offset* 0))
     1621                       :text (or text (substream stream start end))
     1622                       :form form
     1623                       :children children)))
     1624
     1625;;; we don't actually store source-note structs in the fasl since that runs into problems dumping
     1626;;; the struct.
     1627
     1628(defun source-note-to-list (note &key (start t) (end t) (text t) (form t) (children t) (file-name t))
     1629  (append (when start (list :start (source-note-start note)))
     1630          (when end   (list :end   (source-note-end   note)))
     1631          (when text  (list :text  (source-note-text  note)))
     1632          (when form  (list :form  (source-note-form  note)))
     1633          (when children (list :children (source-note-children note)))
     1634          (when file-name (list :file-name (source-note-file-name note)))))
     1635
     1636(defvar *form-source-note-map* nil
     1637  "Hash table used when compiling a top level definition to map lists of source code to their
     1638  corresponding source notes.")
     1639
     1640(defun make-source-note-form-map (source-note &optional existing-map)
     1641  "Creates a mapping from lisp forms to source-notes based on SOURCE-NOTES. This should be bound to
     1642*form-source-note-map* or similar."
     1643  (let ((map (or existing-map (make-hash-table))))
     1644    (labels ((walk (note)
     1645               (cond
     1646                 ((consp note)
     1647                  (walk (car note))
     1648                  (walk (cdr note)))
     1649                 ((source-note-p note)
     1650                  (when (and note (not (gethash (source-note-form note) map)))
     1651                    (setf (gethash (source-note-form note) map) note)
     1652                    (walk (source-note-children note))
     1653                    (setf (source-note-children note) '())))
     1654                 ((null note) '())
     1655                 (t (error "Don't know how to deal with a source note like ~S."
     1656                           note)))))
     1657      (walk source-note))
     1658    map))
     1659
     1660(defun nx1-source-note (nx1-code)
     1661  "Return the source-note for the form which generated NX1-CODE."
     1662  (and *compiler-record-source*
     1663       *nx1-source-note-map*
     1664       (gethash nx1-code *nx1-source-note-map*)))
     1665
     1666(defun form-source-note (source-form)
     1667  (and *compiler-record-source*
     1668       *form-source-note-map*
     1669       (gethash source-form *form-source-note-map*)))
     1670
     1671(defun find-source-at-pc (function pc)
     1672  (let* ((function-source-note (getf (%lfun-info function) 'function-source-note))
     1673         (pc-source-map (getf (%lfun-info function) 'pc-source-map)))
     1674    (when pc-source-map
     1675      (let* ((best-guess nil)
     1676             (best-length nil))
     1677        (dolist (pc-map pc-source-map)
     1678          (let ((pc-start (car (getf pc-map :pc-range)))
     1679                (pc-end (cdr (getf pc-map :pc-range))))
     1680            (when (<= pc-start pc pc-end)
     1681              ;; possible match, see if it's the better than best-guess
     1682              (when (or (null best-guess)
     1683                        (< (- pc-end pc-start) best-length))
     1684                (setf best-guess pc-map
     1685                      best-length (- pc-end pc-start))))))
     1686       
     1687        (when best-guess
     1688          (list :pc-range (getf best-guess :pc-range)
     1689                :source-text-range (getf best-guess :source-text-range)
     1690                :file-name (getf function-source-note :file-name)
     1691                :text (getf function-source-note :text)))))))
     1692
    15591693(defun nx1-form (form &optional (*nx-lexical-environment* *nx-lexical-environment*))
    1560   (let* ((*nx-form-type* t))
    1561     (when (and (consp form)(eq (car form) 'the))
    1562       (setq *nx-form-type* (nx-target-type (cadr form))))
    1563     (prog1
    1564       (nx1-typed-form form *nx-lexical-environment*))))
     1694  (let* ((*nx-form-type* (if (and (consp form) (eq (car form) 'the))
     1695                             (nx-target-type (cadr form))
     1696                             t)))
     1697    (nx1-typed-form form *nx-lexical-environment*)))
    15651698
    15661699(defun nx1-typed-form (original env)
    … …  
    15681701
    15691702(defun nx1-transformed-form (form &optional (env *nx-lexical-environment*))
    1570   (if (consp form)
    1571     (nx1-combination form env)
    1572     (let* ((symbolp (non-nil-symbol-p form))
    1573            (constant-value (unless symbolp form))
    1574            (constant-symbol-p nil))
    1575       (if symbolp
    1576         (multiple-value-setq (constant-value constant-symbol-p)
    1577           (nx-transform-defined-constant form env)))
    1578       (if (and symbolp (not constant-symbol-p))
    1579         (nx1-symbol form env)
    1580         (nx1-immediate (nx-unquote constant-value))))))
    1581 
    1582 
     1703  (flet ((main ()
     1704           (if (consp form)
     1705               (nx1-combination form env)
     1706               (let* ((symbolp (non-nil-symbol-p form))
     1707                      (constant-value (unless symbolp form))
     1708                      (constant-symbol-p nil))
     1709                 (if symbolp
     1710                     (multiple-value-setq (constant-value constant-symbol-p)
     1711                       (nx-transform-defined-constant form env)))
     1712                 (if (and symbolp (not constant-symbol-p))
     1713                     (nx1-symbol form env)
     1714                     (nx1-immediate (nx-unquote constant-value)))))))
     1715    (if *compiler-record-source*
     1716        (destructuring-bind (nx1-form . values)
     1717            (multiple-value-list (main))
     1718          (record-form-to-nx1-transformation form nx1-form)
     1719          (values-list (cons nx1-form values)))
     1720        (main))))
    15831721
    15841722(defun nx1-prefer-areg (form env)
    … …  
    19852123)
    19862124
     2125(defun record-form-to-nx1-transformation (form nx1)
     2126  (when (and *compiler-record-source* (form-source-note form))
     2127    (setf (gethash nx1 *nx1-source-note-map*) (form-source-note form))))
     2128
     2129(defun record-nx1-source-equivalent (original new)
     2130  (when (and *compiler-record-source*
     2131             (nx1-source-note original)
     2132             (not (nx1-source-note new)))
     2133    (setf (gethash new *nx1-source-note-map*)
     2134          (gethash original *nx1-source-note-map*))))
     2135
     2136(defun record-form-source-equivalent (original new)
     2137  (when (and *compiler-record-source*
     2138             (form-source-note original)
     2139             (not (form-source-note new)))
     2140    (setf (gethash new *form-source-note-map*)
     2141          (gethash original *form-source-note-map*))))
     2142
    19872143(defun nx-transform (form &optional (environment *nx-lexical-environment*))
    1988   (let* (sym transforms lexdefs changed enabled macro-function compiler-macro)
     2144  (let* ((startform form) sym transforms lexdefs changed enabled macro-function compiler-macro)
    19892145    (tagbody
    19902146       (go START)
    … …  
    19992155         (multiple-value-bind (newform win) (nx-transform-symbol form environment)
    20002156           (unless win (go DONE))
    2001            (setq form newform changed (or changed win))
     2157           (setq form newform
     2158                 changed (or changed win))
    20022159           (go LOOP)))
    20032160       (when (atom form) (go DONE))
    … …  
    20652222         (go START))
    20662223     DONE)
     2224    (when (and changed *compiler-record-source*)
     2225      (record-form-source-equivalent startform form))
    20672226    (values form changed)))
    20682227

  • branches/source-tracking-0801/ccl/compiler/nx1.lisp

    r7624 r8390  
    8686          (cons
    8787           'macro
    88            (multiple-value-bind (function warnings) (compile-named-function (parse-macro name arglist mbody old-env) name  old-env)
     88           (multiple-value-bind (function warnings)
     89               (compile-named-function (parse-macro name arglist mbody old-env) :name name :env old-env)
    8990             (setq *nx-warnings* (append *nx-warnings* warnings))
    9091             function)))
    … …  
    10591060    (multiple-value-bind (function warnings)
    10601061                         (compile-named-function
    1061                           `(lambda () ,form) nil nil nil nil nil *nx-load-time-eval-token* (backend-name *target-backend*))
     1062                          `(lambda () ,form)
     1063                          :load-time-eval-token *nx-load-time-eval-token*
     1064                          :target (backend-name *target-backend*))
    10621065      (setq *nx-warnings* (append *nx-warnings* warnings))
    10631066      (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function))))

  • branches/source-tracking-0801/ccl/compiler/nxenv.lisp

    r6176 r8390  
    5555    afunc-fwd-refs
    5656    afunc-lfun-info
    57     afunc-linkmap
    58 ))
     57    afunc-linkmap))
    5958
    6059;

  • branches/source-tracking-0801/ccl/level-1/l1-files.lisp

    r8251 r8390  
    11401140        (source-file file-name)
    11411141        constructed-source-file
     1142        ;; we could call load, via an eval-when, when compiling a file so make sure we disable
     1143        ;; source code recording. if we subsequently call compile *fcomp-stream* will get rebound to
     1144        ;; the right value.
     1145        ;(*fcomp-stream* nil)
    11421146        ;; Don't bind these: let OPTIMIZE proclamations/declamations
    11431147        ;; persist, unless debugging.
    … …  
    12181222(defun load-from-stream (stream print &aux (eof-val (list ())) val)
    12191223  (with-compilation-unit (:override nil) ; try this for included files
    1220     (let ((env (new-lexical-environment (new-definition-environment 'eval))))
     1224    (let ((env (new-lexical-environment (new-definition-environment 'eval)))
     1225          ;; disable *compiler-record-source* in case we're loading a file while comiling another
     1226          ;; file.
     1227          (*compiler-record-source* nil))
    12211228      (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*)
    12221229      (while (neq eof-val (setq val (read stream nil eof-val)))

  • branches/source-tracking-0801/ccl/level-1/l1-init.lisp

    r7947 r8390  
    258258(defvar *warn-if-redefine* nil)         ; set in l1-utils.
    259259(defparameter *level-1-loaded* nil)     ; set t by l1-boot
    260 (defparameter *save-definitions* nil)
     260(defparameter *save-definitions* t)
    261261(defparameter *save-local-symbols* t)
    262262

  • branches/source-tracking-0801/ccl/level-1/l1-reader.lisp

    r7730 r8390  
    22242224      (setf (token.ipos token) (the fixnum (1+ ipos)))
    22252225      (%schar (token.string token) ipos))))
    2226 
    22272226     
    22282227(defun input-stream-arg (stream)
    … …  
    24562455|#
    24572456
     2457(defmacro with-read-source-tracking ((stream start end) &body body)
     2458  "Evalute BODY with START bound to the current (effective) offset in STREAM at the beginning of
     2459execution and END bound to final offset."
     2460  (let ((streamv (gensym)))
     2461    `(let* ((,streamv ,stream)
     2462            (,start (and (record-source-location ,streamv)
     2463                         (file-position ,streamv))))
     2464       (symbol-macrolet ((,end (file-position ,streamv)))
     2465         ,@body))))
     2466
    24582467;;; firstchar must not be whitespace.
    24592468;;; People who think that there's so much overhead in all of
    24602469;;; this (multiple-value-list, etc.) should probably consider
    24612470;;; rewriting those parts of the CLOS and I/O code that make
    2462 ;;; using things like READ-CHAR impractical ...
     2471;;; using things like READ-CHAR impractical...
     2472
     2473;;; mb: the reason multiple-value-list is used here is that we need to distunguish between the
     2474;;; recursive parse call returning (values nil) and (values).
    24632475(defun %parse-expression (stream firstchar dot-ok)
    24642476  (let* ((readtable *readtable*)
    2465          (attrtab (rdtab.ttab readtable)))
    2466     (let* ((attr (%character-attribute firstchar attrtab)))
    2467       (declare (fixnum attr))
    2468       (if (= attr $cht_ill)
    2469           (signal-reader-error stream "Illegal character ~S." firstchar))
     2477         (attrtab (rdtab.ttab readtable))
     2478         (attr (%character-attribute firstchar attrtab)))
     2479    (declare (fixnum attr))
     2480    (if (= attr $cht_ill)
     2481        (signal-reader-error stream "Illegal character ~S." firstchar))
     2482    (with-read-source-tracking (stream start end)
    24702483      (let* ((vals (multiple-value-list
    2471                     (if (not (logbitp $cht_macbit attr))
    2472                       (%parse-token stream firstchar dot-ok)
    2473                       (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
    2474                         (cond ((null def))
    2475                               ((atom def)
    2476                                (funcall def stream firstchar))
    2477                               #+no ; include if %initial-readtable% broken (see above)
    2478                               ((and (consp (car def))
    2479                                     (eq (caar def) 'function))
    2480                                (funcall (cadar def) stream firstchar))
    2481                               ((functionp (car def))
    2482                                (funcall (car def) stream firstchar))
    2483                               (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))))
     2484                       (if (not (logbitp $cht_macbit attr))
     2485                           (%parse-token stream firstchar dot-ok)
     2486                           (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
     2487                             (cond ((null def))
     2488                                   ((atom def)
     2489                                    (funcall def stream firstchar))
     2490                                   #+no ; include if %initial-readtable% broken (see above)
     2491                                   ((and (consp (car def))
     2492                                         (eq (caar def) 'function))
     2493                                    (funcall (cadar def) stream firstchar))
     2494                                   ((functionp (car def))
     2495                                    (funcall (car def) stream firstchar))
     2496                                   (t (error "Bogus default dispatch fn: ~S" (car def)) nil)))))))
    24842497        (declare (dynamic-extent vals)
    24852498                 (list vals))
    24862499        (if (null vals)
    2487             (values nil nil)
    2488             (values (car vals) t))))))
    2489 
     2500            (values nil nil nil)           
     2501            (destructuring-bind (form &optional nested-source-notes)
     2502                vals
     2503              (values form
     2504                      t
     2505                      (when (and (consp form) (record-source-location stream))
     2506                        (make-source-note :stream stream
     2507                                          :start (1- start)
     2508                                          :end end
     2509                                          :form (car vals)
     2510                                          :children (labels ((rec (note)
     2511                                                               ;; use this recursive function to
     2512                                                               ;; remove nils since
     2513                                                               ;; nested-source-notes can be a
     2514                                                               ;; dotted list or an atom
     2515                                                               (cond
     2516                                                                 ((consp note)
     2517                                                                  (if (null (car note))
     2518                                                                      (rec (cdr note))
     2519                                                                      (cons (car note) (rec (cdr note)))))
     2520                                                                 ((source-note-p note)
     2521                                                                  note)
     2522                                                                 #| ((null note) '())
     2523                                                                 (t (error "Don't know how to deal with a source note like ~S."
     2524                                                                           nested-source-notes)) |# )))
     2525                                                      (rec nested-source-notes)))))))))))
    24902526
    24912527#|
    … …  
    25042540      (let* ((firstch (%next-non-whitespace-char-and-attr-no-eof stream)))
    25052541        (if (eq firstch termch)
    2506             (return (values nil nil))
    2507             (multiple-value-bind (val val-p) (%parse-expression stream firstch dot-ok)
     2542            (return (values nil nil nil))
     2543            (multiple-value-bind (val val-p source-info)
     2544                (%parse-expression stream firstch dot-ok)
    25082545              (if val-p
    2509                   (return (values val t))))))))
    2510 
     2546                  (return (values val t source-info))))))))
    25112547
    25122548(defun read-list (stream &optional nodots (termch #\)))
    25132549  (let* ((dot-ok (cons nil nil))
    25142550         (head (cons nil nil))
    2515          (tail head))
     2551         (tail head)
     2552         (source-note-list-head (cons nil nil))
     2553         (source-note-list-tail source-note-list-head))
    25162554    (declare (dynamic-extent dot-ok head)
    25172555             (list head tail))
    25182556    (if nodots (setq dot-ok nil))
    2519     (multiple-value-bind (firstform firstform-p)
     2557    (multiple-value-bind (firstform firstform-p firstform-source-note)
    25202558        (%read-list-expression stream dot-ok termch)
    25212559      (when firstform-p
    25222560        (if (and dot-ok (eq firstform dot-ok))       ; just read a dot
    25232561            (signal-reader-error stream "Dot context error."))
     2562        (rplacd source-note-list-tail (setq source-note-list-tail (cons firstform-source-note nil)))
    25242563        (rplacd tail (setq tail (cons firstform nil)))
    25252564        (loop
    2526           (multiple-value-bind (nextform nextform-p)
     2565          (multiple-value-bind (nextform nextform-p nextform-source-note)
    25272566              (%read-list-expression stream dot-ok termch)
    25282567            (if (not nextform-p) (return))
    25292568            (if (and dot-ok (eq nextform dot-ok))    ; just read a dot
    2530                 (if (multiple-value-bind (lastform lastform-p)
     2569                (if (multiple-value-bind (lastform lastform-p lastform-source-note)
    25312570                        (%read-list-expression stream nil termch)
    25322571                      (and lastform-p
    2533                            (progn (rplacd tail lastform)
     2572                           (progn (rplacd tail lastform)
     2573                                  (rplacd source-note-list-tail lastform-source-note)
    25342574                                  (not (nth-value 1 (%read-list-expression stream nil termch))))))
    25352575                    (return)
    25362576                    (signal-reader-error stream "Dot context error."))
    2537                 (rplacd tail (setq tail (cons nextform nil))))))))
    2538     (cdr head)))
     2577                (progn
     2578                  (rplacd source-note-list-tail (setq source-note-list-tail (cons nextform-source-note nil)))
     2579                  (rplacd tail (setq tail (cons nextform nil)))))))))
     2580   
     2581    (if (record-source-location stream)
     2582        (values (cdr head) (cdr source-note-list-head))
     2583        (values (cdr head)))))
    25392584
    25402585#|
    … …  
    26232668    (declare (ignore subchar))
    26242669    (if (or (null numarg) *read-suppress*)
    2625       (let* ((lst (read-list stream t))
    2626              (len (length lst))
    2627              (vec (make-array len)))
    2628         (declare (list lst) (fixnum len) (simple-vector vec))
    2629         (dotimes (i len vec)
    2630           (setf (svref vec i) (pop lst))))
    2631       (locally
    2632         (declare (fixnum numarg))
    2633         (do* ((vec (make-array numarg))
    2634               (lastform)
    2635               (i 0 (1+ i)))
    2636              ((multiple-value-bind (form form-p) (%read-list-expression stream nil)
    2637                 (if form-p
    2638                   (setq lastform form)
    2639                   (unless (= i numarg)
    2640                       (if (= i 0)
    2641                         (%err-disp $XARROOB -1 vec)
    2642                         (do* ((j i (1+ j)))
    2643                              ((= j numarg))
    2644                           (declare (fixnum j))
    2645                           (setf (svref vec j) lastform)))))
    2646                 (not form-p))
    2647               vec)
    2648           (declare (fixnum i))
    2649           (setf (svref vec i) lastform)))))))
     2670        (let* ((lst (read-list stream t))
     2671               (len (length lst))
     2672               (vec (make-array len)))
     2673          (declare (list lst) (fixnum len) (simple-vector vec))
     2674          (dotimes (i len vec)
     2675            (setf (svref vec i) (pop lst))))
     2676        (locally
     2677            (declare (fixnum numarg))
     2678          (do* ((vec (make-array numarg))
     2679                (lastform)
     2680                (i 0 (1+ i)))
     2681              ((multiple-value-bind (form form-p)
     2682                   (%read-list-expression stream nil)
     2683                 (if form-p
     2684                     (setq lastform form)
     2685                     (unless (= i numarg)
     2686                       (if (= i 0)
     2687                           (%err-disp $XARROOB -1 vec)
     2688                           (do* ((j i (1+ j)))
     2689                               ((= j numarg))
     2690                             (declare (fixnum j))
     2691                             (setf (svref vec j) lastform)))))
     2692                 (not form-p))
     2693                 vec)
     2694            (declare (fixnum i))
     2695            (setf (svref vec i) lastform)))))))
    26502696
    26512697(defun %read-rational (stream subchar radix)
    … …  
    28372883;;;recursive reading.  So recursive reads always get done via tyi's, and streams
    28382884;;;only get to intercept toplevel reads.
    2839 
    28402885(defun read (&optional stream (eof-error-p t) eof-value recursive-p)
    28412886  (declare (resident))
     2887  ;; just return the first value of read-internal
     2888  (values (read-internal stream eof-error-p eof-value recursive-p)))
     2889
     2890(defun read-internal (stream eof-error-p eof-value recursive-p)
    28422891  (setq stream (input-stream-arg stream))
    28432892  (if recursive-p
    … …  
    28582907(defun read-delimited-list (char &optional stream recursive-p)
    28592908  "Read Lisp values from INPUT-STREAM until the next character after a
    2860    value's representation is ENDCHAR, and return the objects as a list."
     2909   value's representation is CHAR, and return the objects as a list."
    28612910  (setq char (require-type char 'character))
    28622911  (setq stream (input-stream-arg stream))
    … …  
    28942943(set-dispatch-macro-character #\# #\- #'read-conditional)
    28952944
    2896 
    2897 
    2898 
    2899 ;;;arg=0 : read form, error if eof
    2900 ;;;arg=nil : read form, eof-val if eof.
    2901 ;;;arg=char : read delimited list
    29022945(defun %read-form (stream arg eof-val)
    2903   (declare (resident))
     2946  "Read a lisp form from STREAM
     2947
     2948arg=0 : read form, error if eof
     2949arg=nil : read form, eof-val if eof.
     2950arg=char : read delimited list"
     2951  (declare (resident) (special *fcomp-stream*))
    29042952  (check-type *readtable* readtable)
    29052953  (check-type *package* package)
    … …  
    29072955      (read-list stream nil arg)
    29082956      (loop
    2909           (let* ((ch (%next-non-whitespace-char-and-attr stream)))
     2957        (let* ((ch (%next-non-whitespace-char-and-attr stream)))
    29102958          (if (null ch)
    2911             (if arg
    2912               (error 'end-of-file :stream stream)
    2913               (return eof-val))
    2914             (multiple-value-bind (form form-p) (%parse-expression stream ch nil)
    2915               (if form-p
    2916                  (if *read-suppress*
    2917                      (return nil)
    2918                      (return form)))))))))
    2919 
    2920 
    2921 
    2922 
    2923 
     2959              (if arg
     2960                  (error 'end-of-file :stream stream)
     2961                  (return eof-val))
     2962              (multiple-value-bind (form form-p source-note)
     2963                  (%parse-expression stream ch nil)
     2964                (when form-p
     2965                  (return
     2966                    (values (if *read-suppress* nil form)
     2967                            source-note)))))))))
    29242968
    29252969;;;Until load backquote...

  • branches/source-tracking-0801/ccl/level-1/l1-utils.lisp

    r7670 r8390  
    105105   (probe-file file)))
    106106
    107 (defun record-source-file (name def-type
    108                                 &optional (file-name *loading-file-source-file*)) 
     107#| (defmacro record-source-file (name type)
     108  `(%record-source-file ,name ,type #| (%source-file)|#)) |#
     109
     110(defun record-source-file (name def-type &optional (file-name *loading-file-source-file*)) 
    109111  (let (symbol setf-p method old-file)
    110112    (flet ((same-file (x y)

  • branches/source-tracking-0801/ccl/lib/arglist.lisp

    r8381 r8390  
    161161(defun arglist-from-map (lfun)
    162162  (multiple-value-bind (nreq nopt restp nkeys allow-other-keys
    163                              optinit lexprp
    164                              ncells nclosed)
     163                        optinit lexprp
     164                        ncells nclosed)
    165165      (function-args lfun)
    166166    (declare (ignore optinit))
    … …  
    188188                (when nkeys
    189189                  (when (> idx nkeys) (decf idx nkeys)))
    190                 (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res))                  (when nkeys
     190                (push (if (> idx 0) (elt map (decf idx)) 'the-rest) res))
     191              (when nkeys
    191192                (push '&key res)
    192193                (let ((keyvect (lfun-keyvect lfun)))
    … …  
    215216            (unless (zerop total)
    216217              (progn
    217                 (dotimes (x nreq)
    218                   (declare (fixnum x))
     218                (dotimes (x (the fixnum nreq))
    219219                  (req (if (> idx 0) (elt map (decf idx)) (make-arg "ARG" x))))
    220220                (when (neq nopt 0)
    … …  
    222222                    (opt (if (> idx 0) (elt map (decf idx)) (make-arg "OPT" x)))))
    223223                (when (or restp lexprp)
    224                   (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))                (when nkeys
    225                                                                                               (dotimes (i (the fixnum nkeys))
     224                  (setq rest (if (> idx 0) (elt map (decf idx)) 'the-rest)))
     225                (when nkeys
     226                  (dotimes (i (the fixnum nkeys))
    226227                    (keys (if (> idx 0) (elt map (decf idx)) (make-arg "KEY" i)))))))))
    227228        (values (not (null map)) (req) (opt) rest (keys))))))

  • branches/source-tracking-0801/ccl/lib/backquote.lisp

    r6992 r8390  
    306306)
    307307
    308 #-nil
    309 (progn
    310308(declaim (special *|`,|* *|`,.|* *|`,@|*))
    311309
    … …  
    389387             (untyi char stream)
    390388             (cons (%car stack) (read stream t nil t))))))))
    391 )
     389
    392390
    393391(provide 'backquote)

  • branches/source-tracking-0801/ccl/lib/db-io.lisp

    r7609 r8390  
    843843   (declare (ignore char arg))
    844844   (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
    845      (multiple-value-bind (sym query)
     845     (multiple-value-bind (sym source query)
    846846         (%read-symbol-preserving-case
    847847          stream
    … …  
    849849       (unless *read-suppress*
    850850         (let* ((fv (%load-var sym query)))
    851            (if query
    852              fv
    853              (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
    854                                    (fv.type fv)
    855                                    0
    856                                    nil))))))))
     851           (values (if query
     852                       fv
     853                       (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
     854                                             (fv.type fv)
     855                                             0
     856                                             nil))
     857                   source)))))))
    857858
    858859
    … …  
    985986(defun %read-symbol-preserving-case (stream package)
    986987  (let* ((case (readtable-case *readtable*))
    987          (query nil)
    988          (error nil)
    989          (sym nil))
    990     (let* ((*package* package))
    991       (unwind-protect
    992            (progn
    993              (setf (readtable-case *readtable*) :preserve)
    994              (when (eq #\? (peek-char t stream nil nil))
    995                (setq query t)
    996                (read-char stream))
    997              (multiple-value-setq (sym error)
    998                (handler-case (read stream nil nil)
    999                  (error (condition) (values nil condition)))))
    1000         (setf (readtable-case *readtable*) case)))
     988         query error sym source
     989         (*package* package))
     990    (unwind-protect
     991         (progn
     992           (setf (readtable-case *readtable*) :preserve)
     993           (when (eq #\? (peek-char t stream nil nil))
     994             (setq query t)
     995             (read-char stream))
     996           (multiple-value-setq (sym source error)
     997             (handler-case
     998                 (read-internal stream nil t nil)
     999               (error (condition) (values nil nil condition)))))
     1000      (setf (readtable-case *readtable*) case))
    10011001    (when error
    10021002      (error error))
    1003     (values sym query)))
     1003    (values sym source query)))
    10041004
    10051005(set-dispatch-macro-character
    … …  
    10081008   (declare (ignore char))
    10091009   (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
    1010      (multiple-value-bind (sym query)
     1010     (multiple-value-bind (sym source query)
    10111011         (%read-symbol-preserving-case
    10121012            stream
    … …  
    10151015         (etypecase sym
    10161016           (symbol
    1017             (if query
    1018               (load-os-constant sym query)
    1019               (progn
    1020                 (when (eq (symbol-package sym) package)
    1021                   (unless arg (setq arg 0))
    1022                   (ecase arg
    1023                     (0
    1024                      (unless (and (constant-symbol-p sym)
    1025                                   (not (eq (%sym-global-value sym)
    1026                                            (%unbound-marker-8))))
    1027                        (load-os-constant sym)))
    1028                     (1 (makunbound sym) (load-os-constant sym))))
    1029                 sym)))
     1017              (if query
     1018                  (values (load-os-constant sym query) source)
     1019                  (progn
     1020                    (when (eq (symbol-package sym) package)
     1021                      (unless arg (setq arg 0))
     1022                      (ecase arg
     1023                        (0
     1024                           (unless (and (constant-symbol-p sym)
     1025                                        (not (eq (%sym-global-value sym)
     1026                                                 (%unbound-marker-8))))
     1027                             (load-os-constant sym)))
     1028                        (1 (makunbound sym) (load-os-constant sym))))
     1029                    (values sym source))))
    10301030           (string
    1031             (let* ((val 0)
    1032                    (len (length sym)))
    1033               (dotimes (i 4 val)
    1034                 (let* ((ch (if (< i len) (char sym i) #\space)))
    1035                   (setq val (logior (ash val 8) (char-code ch)))))))))))))
     1031              (let* ((val 0)
     1032                     (len (length sym)))
     1033                (dotimes (i 4 (values val source))
     1034                  (let* ((ch (if (< i len) (char sym i) #\space)))
     1035                    (setq val (logior (ash val 8) (char-code ch)))))))))))))
    10361036
    10371037(set-dispatch-macro-character #\# #\_
    … …  
    10391039    (declare (ignore char))
    10401040    (unless arg (setq arg 0))
    1041     (multiple-value-bind (sym query)
     1041    (multiple-value-bind (sym source query)
    10421042        (%read-symbol-preserving-case
    10431043                 stream
    … …  
    10461046        (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol))
    10471047        (if query
    1048           (load-external-function sym t)
    1049           (let* ((def (if (eql arg 0)
    1050                         (gethash sym (ftd-external-function-definitions
    1051                                       *target-ftd*)))))
    1052             (if (and def (eq (macro-function sym) #'%external-call-expander))
    1053               sym
    1054               (load-external-function sym nil))))))))
     1048            (values (load-external-function sym t) source)
     1049            (let* ((def (if (eql arg 0)
     1050                            (gethash sym (ftd-external-function-definitions
     1051                                          *target-ftd*)))))
     1052              (values (if (and def (eq (macro-function sym) #'%external-call-expander))
     1053                          sym
     1054                          (load-external-function sym nil))
     1055                      source)))))))
    10551056
    10561057(set-dispatch-macro-character

  • branches/source-tracking-0801/ccl/lib/defstruct-lds.lisp

    r2325 r8390  
    257257         ,(if (and predicate (null (sd-type sd))) `',predicate)
    258258         ,.(if documentation (list documentation)))
     259        (record-source-file ',(sd-name sd) 'structure)
    259260        ,(%defstruct-compile sd refnames)
    260261       ;; Wait until slot accessors are defined, to avoid

  • branches/source-tracking-0801/ccl/lib/defstruct.lisp

    r5434 r8390  
    9797    (set-documentation name 'type doc)) 
    9898  (puthash name %defstructs% sd)
    99   (record-source-file name 'structure)
    10099  (when (and predicate (null (sd-type sd)))
    101100    (puthash predicate %structure-refs% name)) 

  • branches/source-tracking-0801/ccl/lib/encapsulate.lisp

    r6499 r8390  
    584584    res))
    585585
     586(defmacro with-traces (syms &body body)
     587  `(unwind-protect
     588        (progn
     589          (let ((*trace-output* (make-broadcast-stream)))
     590            ;; if you're tracing ccl internals you'll get trace output as it encapsulates the
     591            ;; functions so hide all the trace output while eval'ing teh trace form itself.
     592            (trace ,@syms))
     593          ,@body)
     594     (untrace ,@syms)))
    586595
    587596;; this week def is the name of an uninterned gensym whose fn-cell is original def
    … …  
    683692
    684693(defun compile-named-function-warn (fn name)
    685   (multiple-value-bind (result warnings)(compile-named-function fn name)   
     694  (multiple-value-bind (result warnings)
     695      (compile-named-function fn :name name)   
    686696    (when warnings
    687697      (let ((first t))

  • branches/source-tracking-0801/ccl/lib/misc.lisp

    r7954 r8390  
    704704        (setq fun (closure-function fun)))
    705705    (when (lambda-expression-p fun)
    706       (setq fun (compile-named-function fun nil)))
     706      (setq fun (compile-named-function fun)))
    707707    fun))
    708708

  • branches/source-tracking-0801/ccl/lib/nfcomp.lisp

    r8042 r8390  
    101101                   pathname))
    102102
    103 (defun compile-file (src &key output-file
    104                          (verbose *compile-verbose*)
    105                          (print *compile-print*)
    106                          load
    107                          features
    108                          (target *fasl-target* target-p)
    109                          (save-local-symbols *fasl-save-local-symbols*)
    110                          (save-doc-strings *fasl-save-doc-strings*)
    111                          (save-definitions *fasl-save-definitions*)
    112                          (external-format :default)
    113                          force)
    114   "Compile INPUT-FILE, producing a corresponding fasl file and returning
    115    its filename."
    116   (let* ((backend *target-backend*))
    117     (when (and target-p (not (setq backend (find-backend target))))
    118       (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
    119       (setq target *fasl-target*  backend *target-backend*))
    120     (loop
    121         (restart-case
    122          (return (%compile-file src output-file verbose print load features
    123                                 save-local-symbols save-doc-strings save-definitions force backend external-format))
    124          (retry-compile-file ()
    125                              :report (lambda (stream) (format stream "Retry compiling ~s" src))
    126                              nil)
    127          (skip-compile-file ()
    128                             :report (lambda (stream) (format stream "Skip compiling ~s" src))
    129                             (return))))))
    130 
    131 
    132103(defun %compile-file (src output-file verbose print load features
    133104                          save-local-symbols save-doc-strings save-definitions force target-backend external-format
     105                          compile-file-original-truename compile-file-original-buffer-offset
    134106                          &aux orig-src)
    135 
    136107  (setq orig-src (merge-pathnames src))
    137108  (let* ((output-default-type (backend-target-fasl-pathname target-backend)))
    … …  
    169140             (*compile-file-pathname* orig-src)
    170141             (*compile-file-truename* (truename src))
     142             (*compile-file-original-truename* compile-file-original-truename)
     143             (*compile-file-original-buffer-offset* compile-file-original-buffer-offset)
    171144             (*package* *package*)
    172145             (*readtable* *readtable*)
    … …  
    199172              *fasl-non-style-warnings-signalled-p*))))
    200173
     174(defun compile-file (src &key output-file
     175                         (verbose *compile-verbose*)
     176                         (print *compile-print*)
     177                         load
     178                         features
     179                         (target *fasl-target* target-p)
     180                         (save-local-symbols *fasl-save-local-symbols*)
     181                         (save-doc-strings *fasl-save-doc-strings*)
     182                         (save-definitions *fasl-save-definitions*)
     183                         (external-format :default)
     184                         force
     185                         compile-file-original-truename
     186                         (compile-file-original-buffer-offset 0))
     187  "Compile INPUT-FILE, producing a corresponding fasl file and returning
     188   its filename."
     189  (let* ((backend *target-backend*))
     190    (when (and target-p (not (setq backend (find-backend target))))
     191      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
     192      (setq target *fasl-target*  backend *target-backend*))
     193    (loop
     194        (restart-case
     195         (return (%compile-file src output-file verbose print load features
     196                                save-local-symbols save-doc-strings save-definitions force backend external-format
     197                                compile-file-original-truename compile-file-original-buffer-offset))
     198         (retry-compile-file ()
     199                             :report (lambda (stream) (format stream "Retry compiling ~s" src))
     200                             nil)
     201         (skip-compile-file ()
     202                            :report (lambda (stream) (format stream "Skip compiling ~s" src))
     203                            (return))))))
     204
    201205(defvar *fcomp-locked-hash-tables*)
    202206(defvar *fcomp-load-forms-environment* nil)
    … …  
    246250                              (signal c))))
    247251      (funcall (compile-named-function
    248                 `(lambda () ,form) nil env nil nil
    249                 *compile-time-evaluation-policy*)))))
     252                `(lambda () ,form)
     253                :env env
     254                :policy *compile-time-evaluation-policy*)))))
    250255
    251256
    … …  
    281286;;;;          Produces a list of (opcode . args) to run on loading, intermixed
    282287;;;;          with read packages.
    283 
    284 (defparameter *fasl-eof-forms* nil)
    285288
    286289(defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL"))
    … …  
    374377  (namestring path))
    375378
     379;;; mb: HACK HACK HACKITY HACK
     380(defun read-internal (stream eof-error-p eof-value recursive-p)
     381  (setq stream (input-stream-arg stream))
     382  (if recursive-p
     383    (%read-form stream 0 nil)
     384    (let ((%read-objects% nil) (%keep-whitespace% nil))
     385      (%read-form stream (if eof-error-p 0) eof-value))))
     386
    376387;;; orig-file is back-translated when from fcomp-file
    377388;;; when from fcomp-include it's included filename merged with *compiling-file*
    … …  
    382393            (if (eq filename *compiling-file*) "Compiling" " Including")
    383394            filename))
    384   (with-open-file (stream filename
    385                           :element-type 'base-char
    386                           :external-format *fcomp-external-format*)
     395  (with-open-file (*fcomp-stream* filename
     396                                  :element-type 'base-char
     397                                  :external-format *fcomp-external-format*)
    387398    (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))           
    388399           (*fasl-source-file* filename)
    389            (*fcomp-toplevel-forms* nil)
    390            (*fasl-eof-forms* nil)
     400           (*fcomp-toplevel-forms* '())
    391401           (*loading-file-source-file* (namestring orig-file)) ; why orig-file???
    392402           (eofval (cons nil nil))
    393403           (read-package nil)
    394            form)
    395       (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*))
     404           *form-source-note-map*
     405           (*nx1-source-note-map* (make-hash-table)))
     406      (declare (special *fcomp-toplevel-forms* *fasl-source-file*))
    396407      ;;This should really be something like `(set-loading-source
    397408      ;;,filename) but then couldn't compile level-1 with this...  ->
    … …  
    403414      (let* ((*fcomp-previous-position* nil))
    404415        (loop
    405           (let* ((*fcomp-stream-position* (file-position stream)))
     416          (let* ((*fcomp-stream-position* (file-position *fcomp-stream*))
     417                 (*definition-source-note* *definition-source-note*)
     418                 form)
    406419            (unless (eq read-package *package*)
    407420              (fcomp-compile-toplevel-forms env)
    … …  
    410423                   (and *fcomp-load-time* cfasl-load-time-eval-sym)))
    411424              (declare (special *reading-for-cfasl*))
    412               (let ((pos (file-position stream)))
     425              (let ((pos (file-position *fcomp-stream*)))
    413426                (handler-bind
    414427                    ((error #'(lambda (c) ; we should distinguish read errors from others?
    415                                 (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
     428                                (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position *fcomp-stream*) filename)
    416429                                (signal c))))
    417                   (setq form (read stream nil eofval)))))
    418             (when (eq eofval form) (return))
     430                  (multiple-value-bind (-form source-note)
     431                      (read-internal *fcomp-stream* nil eofval nil)
     432                    (when (eq -form eofval)
     433                      (return))
     434                    (setf form -form
     435                          *definition-source-note* source-note
     436                          *form-source-note-map* (make-source-note-form-map source-note
     437                                                                            *form-source-note-map*))))))
    419438            (fcomp-form form env processing-mode)
    420439            (setq *fcomp-previous-position* *fcomp-stream-position*))))
    421       (while (setq form *fasl-eof-forms*)
    422         (setq *fasl-eof-forms* nil)
    423         (fcomp-form-list form env processing-mode))
    424440      (when old-file
    425441        (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
    426442      (fcomp-compile-toplevel-forms env))))
    427 
    428 
    429443
    430444(defun fcomp-form (form env processing-mode
    … …  
    468482                             "")))))))
    469483    (fcomp-form-1 form env processing-mode)))
    470            
     484
     485(defun record-form-source-equivalent/list (form list)
     486  (dolist (f list)
     487    (record-form-source-equivalent form f)))
     488
    471489(defun fcomp-form-1 (form env processing-mode &aux sym body)
    472490  (if (consp form) (setq sym (%car form) body (%cdr form)))
    473491  (case sym
    474     (progn (fcomp-form-list body env processing-mode))
    475     (eval-when (fcomp-eval-when body env processing-mode))
    476     (compiler-let (fcomp-compiler-let body env processing-mode))
    477     (locally (fcomp-locally body env processing-mode))
    478     (macrolet (fcomp-macrolet body env processing-mode))
     492    (progn
     493      (record-form-source-equivalent/list form body)
     494      (fcomp-form-list body env processing-mode))
     495    (eval-when
     496      (record-form-source-equivalent/list form body)
     497      (fcomp-eval-when body env processing-mode))
     498    (compiler-let
     499      (record-form-source-equivalent/list form body)
     500      (fcomp-compiler-let body env processing-mode))
     501    (locally
     502      (record-form-source-equivalent/list form body)
     503      (fcomp-locally body env processing-mode))
     504    (macrolet
     505      (record-form-source-equivalent/list form body)
     506      (fcomp-macrolet body env processing-mode))
     507    ;; special case for passing around source-location info
     508    (%source-note (fcomp-form (list 'quote (source-note-to-list *definition-source-note*))
     509                              env processing-mode))
    479510    ((%include include) (fcomp-include form env processing-mode))
    480511    (t
    … …  
    488519             (not (compiler-macro-function sym env))
    489520             (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
    490              (multiple-value-bind (new win) (macroexpand-1 form env)
    491                (if win (setq form new))
     521             (multiple-value-bind (new win)
     522                 (macroexpand-1 form env)
     523               (if win
     524                   (progn
     525                    (record-form-source-equivalent form new)
     526                    (setf form new)))
    492527               win))
    493528        (fcomp-form form env processing-mode))
    494529       ((and (not *fcomp-inside-eval-always*)
    495530             (memq sym *fcomp-eval-always-functions*))
    496         (let* ((*fcomp-inside-eval-always* t))
    497           (fcomp-form-1 `(eval-when (:execute :compile-toplevel :load-toplevel) ,form) env processing-mode)))
     531        (let* ((*fcomp-inside-eval-always* t)
     532               (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form)))
     533          (record-form-source-equivalent form new)
     534          (fcomp-form-1 new env processing-mode)))
    498535       (t
    499536        (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
    … …  
    504541            ((%defparameter) (fcomp-load-%defparameter form env))
    505542            ((%defvar %defvar-init) (fcomp-load-defvar form env))
    506             ((%defun) (fcomp-load-%defun form env))
     543            ((%defun)
     544               (let ((*definition-source-note* (gethash form *form-source-note-map*)))
     545                 (fcomp-load-%defun form env)))
    507546            ((set-package %define-package)
    508547             (fcomp-random-toplevel-form form env)
    … …  
    514553
    515554(defun fcomp-form-list (forms env processing-mode)
    516   (dolist (form forms) (fcomp-form form env processing-mode)))
     555  (dolist (form forms)
     556    (fcomp-form form env processing-mode)))
    517557
    518558(defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
    … …  
    522562    (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
    523563  (progv (nreverse vars) (nreverse varinits)
    524                  (fcomp-form-list form env processing-mode)
    525                  (fcomp-compile-toplevel-forms env)))
     564    (fcomp-form-list form env processing-mode)
     565    (fcomp-compile-toplevel-forms env)))
    526566
    527567(defun fcomp-locally (body env processing-mode)
    … …  
    654694      (push (list* name
    655695                   'macro
    656                    (compile-named-function lambda-expression name env))
     696                   (compile-named-function lambda-expression :name name :env env))
    657697            (defenv.functions definition-env)))
    658698    name))
    … …  
    729769          (setf (car (cadr doc)) nil))
    730770        (setq doc nil)))
     771    (record-form-source-equivalent form fn)
    731772    (if (and (constantp doc)
    732773             (setq fn (fcomp-function-arg fn env)))
    … …  
    738779(defun fcomp-load-%macro (form env &aux fn doc)
    739780  (verify-arg-count form 1 2)
     781  (record-form-source-equivalent form (cadr form))
    740782  (if (and (constantp (setq doc (caddr form)))
    741783           (setq fn (fcomp-function-arg (cadr form) env)))
    … …  
    777819      (let (lfun (args (%cdr form)))
    778820        (while args
     821          (record-form-source-equivalent form (first args))
    779822          (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
    780823            (when (or (setq lfun (fcomp-function-arg arg env))
    … …  
    790833(defun fcomp-function-arg (expr env)
    791834  (when (consp expr)
    792     (if (and (eq (%car expr) 'nfunction)
    793              (symbolp (car (%cdr expr)))
    794              (lambda-expression-p (car (%cddr expr))))
    795       (fcomp-named-function (%caddr expr) (%cadr expr) env)
    796       (if (and (eq (%car expr) 'function)
    797                (lambda-expression-p (car (%cdr expr))))
    798         (fcomp-named-function (%cadr expr) nil env)))))
     835    (cond
     836      ((and (eq (%car expr) 'nfunction)
     837            (symbolp (%cadr expr))
     838            (lambda-expression-p (%caddr expr)))
     839       (record-form-source-equivalent expr (%caddr expr))
     840       (fcomp-named-function (%caddr expr) (%cadr expr) env))
     841      ((and (eq (%car expr) 'function)
     842            (lambda-expression-p (%cadr expr)))
     843       (record-form-source-equivalent expr (%cadr expr))
     844       (fcomp-named-function (%cadr expr) nil env)))))
    799845
    800846(defun fcomp-compile-toplevel-forms (env)
    … …  
    809855                                     (compiler-function-overflow)))
    810856                          ,@forms)))))
    811       (setq *fcomp-toplevel-forms* nil)
     857      (record-form-source-equivalent/list lambda forms)
     858      (setq *fcomp-toplevel-forms* '())
    812859      ;(format t "~& Random toplevel form: ~s" lambda)
    813860      (handler-case (fcomp-output-form
    … …  
    838885  (let* ((env (new-lexical-environment env)))
    839886    (multiple-value-bind (lfun warnings)
    840                          (compile-named-function
    841                           def name
    842                           env
    843                           *fasl-save-definitions*
    844                           *fasl-save-local-symbols*
    845                           *default-file-compilation-policy*
    846                           cfasl-load-time-eval-sym
    847                           *fasl-target*)
     887        (compile-named-function def
     888                                :name name
     889                                :env env
     890                                :keep-lambda *fasl-save-definitions*
     891                                :keep-symbols *fasl-save-local-symbols*
     892                                :policy *default-file-compilation-policy*
     893                                :load-time-eval-token cfasl-load-time-eval-sym
     894                                :target *fasl-target*)
    848895      (fcomp-signal-or-defer-warnings warnings env)
    849896      lfun)))

  • branches/source-tracking-0801/ccl/lib/read.lisp

    r6921 r8390  
    4646               (cons form (read-file-to-list-aux stream))))))
    4747|#
    48 
    49 (defun read-internal (input-stream)
    50   (read input-stream t nil t))
    51 
    5248
    5349(set-dispatch-macro-character #\# #\*
    … …  
    9692          (signal-reader-error stream "reader macro #A used without a rank integer"))
    9793         ((eql dimensions 0) ;0 dimensional array
    98           (make-array nil :initial-contents (read-internal stream)))
     94          (make-array nil :initial-contents (read-internal stream t nil t)))
    9995         ((and (integerp dimensions) (> dimensions 0))
    100           (let ((init-list (read-internal stream)))
     96          (let ((init-list (read-internal stream t nil t)))
    10197            (cond ((not (typep init-list 'sequence))
    10298                   (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list))
    … …  
    130126  (qlfun |#S-reader| (input-stream sub-char int &aux list sd)
    131127     (declare (ignore sub-char int))
    132      (setq list (read-internal input-stream))
     128     (setq list (read-internal input-stream t nil t))
    133129     (unless *read-suppress*
    134130       (unless (and (consp list)

  • branches/source-tracking-0801/ccl/lib/source-files.lisp

    r6922 r8390  
    1616
    1717(in-package "CCL")
     18
     19#| (defun definition-source (object &object environment)
     20 
     21  (flet ((definition-note (lfun)
     22             (getf (getf lfun 'code-source-map) :definition-source-note)))
     23    (etypecase object
     24      (symbol (append (when (find-class object nil environment)
     25                        (definition-source (find-class object) environment))
     26                      (when (fboundp object)
     27                        (definition-source (symbol-function object) environment))
     28                      (when (boundp object)
     29                        (variable-definition-source object environment))))
     30      (standard-generic-function
     31         (append (list :generic-function (definition-note ))))))) |#
     32
     33#| (defun variable-definition-source (var-name)
     34  (gethash var-name %source-notes-for-varibales-and-constants%))
     35
     36(defvar %source-notes-for-varibales-and-constants%
     37  (make-hash-table :test #'eq :weak t :size 7000 :rehash-threshold .9)) |#
    1838
    1939(defvar %source-files% (let ((a (make-hash-table :test #'eq

  • branches/source-tracking-0801/ccl/library/lispequ.lisp

    r7958 r8390  
    139139(defconstant $lfbits-aok-bit 16)
    140140(defconstant $lfbits-numinh (byte 6 17))
    141 (defconstant $lfbits-symmap-bit 23)
     141(defconstant $lfbits-info-bit 23)
    142142(defconstant $lfbits-trampoline-bit 24)
    143143(defconstant $lfbits-evaluated-bit 25)
Note: See TracChangeset for help on using the changeset viewer.