Changeset 8438


Ignore:
Timestamp:
Feb 7, 2008, 8:13:17 AM (17 years ago)
Author:
gz
Message:

checkpoint work on code coverage + merge of marco's source location

Location:
branches/gz-working
Files:
2 added
17 edited

Legend:

Unmodified
Added
Removed

  • branches/gz-working/compiler/PPC/ppc2.lisp

    r8402 r8438  
    170170(defvar *ppc2-record-symbols* nil)
    171171(defvar *ppc2-recorded-symbols* nil)
     172(defvar *ppc2-emitted-source-notes* ())
    172173
    173174(defvar *ppc2-result-reg* ppc::arg_z)
    … …  
    471472                         (setq function-debugging-info (nconc (list 'function-symbol-map *ppc2-recorded-symbols*)
    472473                                                              function-debugging-info)))
    473                        (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
     474                       (setq bits (logior (ash 1 $lfbits-info-bit) bits))
    474475                       (backend-new-immediate function-debugging-info)))
    475476                   (if (or fname lambda-form *ppc2-recorded-symbols*)
    … …  
    494495                            regsave-addr
    495496                            (if (and fname (symbolp fname)) (symbol-name fname)))))
    496                    (ppc2-digest-symbols))))
     497                   (ppc2-digest-symbols)
     498                   (ppc2-digest-source-notes))))
     499          (ppc2-reset-source-notes)
    497500          (backend-remove-labels))))
    498501    afunc))
    … …  
    21402143      (when (and vreg val-reg) (<- val-reg))
    21412144      (^))))
    2142                    
     2145
     2146(defun ppc2-code-coverage-entry (seg)
     2147  (let ((note (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note)))
     2148    (when note
     2149      (with-ppc-local-vinsn-macros (seg)
     2150        (! vpush-register ppc::arg_x)
     2151        (! misc-ref-c-node ppc::arg_x ppc::nfn (1+ (backend-immediate-index note)))
     2152        (! misc-set-c-node ppc::rzero ppc::arg_x 1)
     2153        (! vpop-register ppc::arg_x)))))
     2154
     2155(defppc2 ppc2-with-source-note with-source-note (seg vreg xfer note form &aux val)
     2156  (when *record-pc-mapping*
     2157    (append-dll-node (setq (setf (source-note-start note) (make-vinsn-label nil)) seg)))
     2158  (when *compile-code-coverage*
     2159    (with-ppc-local-vinsn-macros (seg)
     2160      (ppc2-store-immediate seg note ($ ppc::arg_x))
     2161      (! misc-set-c-node ($ ppc::rzero) ($ ppc::arg_x) 1)))
     2162  (setq val (ppc2-form seg vreg xfer form))
     2163  (when *record-pc-mapping*
     2164    (append-dll-node (setf (source-note-end-pc note) (make-vinsn-label nil)) seg))
     2165  val)
     2166
     2167(defun ppc2-digest-source-notes ()
     2168  (when (or *compile-code-coverage* *record-pc-mapping*)
     2169    (flet ((address (label)
     2170             (when (typep label 'vinsn-label)
     2171               (let ((lap-label (or (vinsn-label-info label)
     2172                                    (compiler-bug "Missing source note label: ~s" label))))
     2173                 (lap-label-address lap-label)))))
     2174      (labels ((rec (note)
     2175                 (when note
     2176                   (setf (source-note-start-pc note) (address (source-note-start-pc note)))
     2177                   (setf (source-note-end-pc note) (address (source-note-end-pc note)))
     2178                   (dolist (subnote (source-note-subform-notes note)) (rec subnote)))))
     2179        (rec (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))))))
     2180
     2181(defun ppc2-reset-source-notes ()
     2182  (when (or *compile-code-coverage* *record-pc-mapping*)
     2183    (flet ((clear (label) (if (typep label 'vinsn-label) nil label)))
     2184      (labels ((rec (note)
     2185                 (when note
     2186                   (setf (source-note-start-pc note) (clear (source-note-start-pc note)))
     2187                   (setf (source-note-end-pc note) (clear (source-note-end-pc note)))
     2188                   (dolist (subnote (source-note-subform-notes note)) (rec subnote)))))
     2189        (rec (getf (afunc-lfun-info *ppc2-cur-afunc*) 'function-source-note))))))
    21432190
    21442191(defun ppc2-vset (seg vreg xfer type-keyword vector index value safe)
    … …  
    50645111    (if (%vinsn-label-p v)
    50655112      (let* ((id (vinsn-label-id v)))
    5066         (if (typep id 'fixnum)
     5113        (if (or (typep id 'fixnum) (null id))
    50675114          (when (or t (vinsn-label-refs v))
    50685115            (setf (vinsn-label-info v) (emit-lap-label v)))
    … …  
    52605307          (ppc2-allocate-global-registers *ppc2-fcells* *ppc2-vcells* (afunc-all-vars afunc) no-regs))
    52615308        (@ (backend-get-next-label)) ; generic self-reference label, should be label #1
     5309        (when *compile-code-coverage*
     5310          (ppc2-code-coverage-entry seg))
     5311
    52625312        (unless next-method-p
    52635313          (setq method-var nil))
    … …  
    90599109                             (list nil (list arg))))))))
    90609110
    9061 (defun show-function-constants (f)
    9062   (cond ((typep f 'function)
    9063          (do* ((i 0 j)
    9064                (n (uvsize f))
    9065                (j 1 (1+ j)))
    9066               ((= j n))
    9067            (format t "~&~d: ~s" i (uvref f j))))
    9068         (t (report-bad-arg f 'function))))
    9069 
    9070        
    90719111;------
    90729112

  • branches/gz-working/compiler/X86/x862.lisp

    r8355 r8438  
    578578                         (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
    579579                                                              function-debugging-info)))
    580                        (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
     580                       (setq bits (logior (ash 1 $lfbits-info-bit) bits))
    581581                       (setq debug-info function-debugging-info)))
    582582                   (unless (or fname lambda-form *x862-recorded-symbols*)
    … …  
    22802280      (^))))
    22812281         
    2282          
     2282(defx862 x862-code-coverage code-coverage (seg vreg xfer ccrec form)
     2283  (with-x86-local-vinsn-macros (seg)
     2284    (x862-store-immediate seg ccrec x8664::arg_x)
     2285    (! load-t x8664::arg_y)
     2286    (! misc-set-c-node x8664::arg_y x8664::arg_x 1))
     2287  (x862-form seg vreg xfer form))
     2288
     2289(defun x862-code-coverage-entry (seg)
     2290 (let ((ccrec (getf (afunc-lfun-info *x862-cur-afunc*) 'function-code-coverage)))
     2291   (when ccrec
     2292     (with-x86-local-vinsn-macros (seg)
     2293       (let* ((ccreg ($ x8664::arg_x))
     2294              (valreg ($ x8664::arg_z)))
     2295         (! vpush-register ccreg)
     2296         (! vpush-register valreg)
     2297         (! ref-constant x8664::arg_x  (x86-immediate-label ccrec))
     2298         (! load-t valreg)
     2299         (! misc-set-c-node valreg ccreg 1)
     2300         (! vpop-register valreg)
     2301         (! vpop-register ccreg))))))
    22832302
    22842303(defun x862-vset (seg vreg xfer type-keyword vector index value safe)
    … …  
    52585277      (if (%vinsn-label-p v)
    52595278        (let* ((id (vinsn-label-id v)))
    5260           (if (typep id 'fixnum)
     5279          (if (or (typep id 'fixnum) (null id))
    52615280            (when (or t (vinsn-label-refs v))
    52625281              (setf (vinsn-label-info v) (emit-x86-lap-label frag-list v)))
    … …  
    55295548        (! establish-fn)
    55305549        (@ (backend-get-next-label)) ; self-call label
     5550        (x862-code-coverage-entry seg)
     5551
    55315552        (unless next-method-p
    55325553          (setq method-var nil))
    … …  
    91489169                         *target-ftd*)))
    91499170    (multiple-value-bind (xlfun warnings)
    9150         (compile-named-function def nil
    9151                                 nil
    9152                                 nil
    9153                                 nil
    9154                                 nil
    9155                                 nil
    9156                                 target)
     9171        (compile-named-function def :target target)
    91579172      (signal-or-defer-warnings warnings nil)
    91589173      (when disassemble

  • branches/gz-working/compiler/lambda-list.lisp

    r4020 r8438  
    2525  (getf (%lfun-info fn) 'function-symbol-map))
    2626
     27(defun function-source-text (fn)
     28  (get (%lfun-info fn) 'text))
     29
    2730(defun %lfun-info-index (fn)
    2831  (and (compiled-function-p fn)
    2932       (let ((bits (lfun-bits fn)))
    3033         (declare (fixnum bits))
    31          (and (logbitp $lfbits-symmap-bit bits)
     34         (and (logbitp $lfbits-info-bit bits)
    3235               (%i- (uvsize (function-to-function-vector fn))
    3336                              (if (logbitp $lfbits-noname-bit bits) 2 3))))))

  • branches/gz-working/compiler/nx-basic.lisp

    r6471 r8438  
    489489      (cdr (assq name (defenv.structrefs defenv))))))
    490490
    491 ; end
     491;end

  • branches/gz-working/compiler/nx.lisp

    r7719 r8438  
    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)
    … …  
    134131(defun compile-user-function (def name &optional env)
    135132  (multiple-value-bind (lfun warnings)
    136                        (compile-named-function def name
    137                                                env
    138                                                *save-definitions*
    139                                                *save-local-symbols*)
     133                       (compile-named-function def
     134                                               :name name
     135                                               :env env
     136                                               :keep-lambda *save-definitions*
     137                                               :keep-symbols *save-local-symbols*)
    140138    (signal-or-defer-warnings warnings env)
    141139    lfun))
    … …  
    153151
    154152(defparameter *load-time-eval-token* nil)
    155 
    156 
    157 
     153(defparameter *nx-source-note-map* nil)
     154
     155(defmacro nx-source-note (form)
     156  `(gethash ,form *nx-source-note-map*))
     157
     158(defun nx-find-or-make-source-note (form parent)
     159  ;; Here's a fun code coverage issue:  What if the same source form gets used multiple
     160  ;; times. e.g. (macrolet ((dup (x) `(progn (foo ,x) (bar ,x)))) (dup (something))).
     161  ;; We could arrange to have separate records for each instance, but as of right now no
     162  ;; existing or contemplated UI has a means of showing the distinction, so don't bother.
     163  (or (nx-source-note form)
     164      (and (consp form)
     165           (setf (nx-source-note form) (make-source-note :form form :source parent)))))
    158166
    159167(eval-when (:compile-toplevel)
    … …  
    162170(defparameter *nx-discard-xref-info-hook* nil)
    163171
    164 (defun compile-named-function
    165     (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target)
     172(defun compile-named-function (def &rest args)
     173  ;; For bootstrapping.  TODO: Switch to keyword version once fully bootstrapped
     174  (if (and (evenp (length args))
     175           (loop for aa on args by #'cddr always (keywordp (car aa))))
     176    (apply #'compile-named-function-1 def args)
     177    (destructuring-bind (&optional name env keep-lambda keep-symbols policy load-time-eval-token target) args
     178      (compile-named-function-1 def
     179                                :name name
     180                                :env env
     181                                :keep-lambda keep-lambda
     182                                :keep-symbols keep-symbols
     183                                :policy policy
     184                                :load-time-eval-token load-time-eval-token
     185                                :target target))))
     186
     187(defun compile-named-function-1 (def &key name env source keep-lambda keep-symbols policy load-time-eval-token target source-locations)
    166188  (when (and name *nx-discard-xref-info-hook*)
    167189    (funcall *nx-discard-xref-info-hook* name))
    168190  (setq
    169191   def
    170    (let ((env (new-lexical-environment env)))
     192   (let ((*load-time-eval-token* load-time-eval-token)
     193         (*nx-source-note-map* source-locations)
     194         (env (new-lexical-environment env)))
    171195     (setf (lexenv.variables env) 'barrier)
    172196       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
    … …  
    178202                      env
    179203                      (or policy *default-compiler-policy*)
    180                       *load-time-eval-token*)))
     204                      *load-time-eval-token*
     205                      source)))
    181206         (if (afunc-lfun afunc)
    182207           afunc

  • branches/gz-working/compiler/nx0.lisp

    r7939 r8438  
    5555(defvar *nx1-fcells* nil)
    5656
    57 (defvar *nx1-operators* (make-hash-table :size 160 :test #'eq))
     57(defvar *nx1-operators* (make-hash-table :size 300 :test #'eq))
    5858
    5959                                         
    … …  
    7878(defvar *nx-operators* ())
    7979(defvar *nx-warnings* nil)
     80(defvar *nx-ccrec* nil)
    8081
    8182(defvar *nx1-compiler-special-forms* nil "Real special forms")
    … …  
    9192(defvar *cross-compiling* nil "bootstrapping")
    9293
    93 
     94(defvar *compile-code-coverage* nil "True to instrument for code coverage")
     95(defvar *record-pc-mapping* nil "True to record pc -> source mapping")
    9496
    9597(defparameter *nx-operator-result-types*
    … …  
    208210    (let ((body (parse-macro-1 block-name arglist body env)))
    209211      `(eval-when (:compile-toplevel :load-toplevel :execute)
    210         (eval-when (:load-toplevel :execute)
    211           (record-source-file ',name 'compiler-macro))
     212        (record-source-file ',name 'compiler-macro)
    212213        (setf (compiler-macro-function ',name)
    213214         (nfunction (compiler-macro-function ,name)  ,body))
    … …  
    12511252                                 parent-env
    12521253                                 (policy *default-compiler-policy*)
    1253                                  load-time-eval-token)
     1254                                 load-time-eval-token
     1255                                 source)
    12541256  (if q
    12551257     (setf (afunc-parent p) q))
    … …  
    12841286                         (parse-body (%cddr lambda-form) *nx-lexical-environment* t)
    12851287      (setf (afunc-lambdaform p) lambda-form)
    1286       (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls))
     1288      (setf (afunc-acode p) (nx1-lambda (%cadr lambda-form) body decls source))
    12871289      (nx1-transitively-punt-bindings *nx-punted-vars*)
    12881290      (setf (afunc-blocks p) *nx-blocks*)
    … …  
    13081310
    13091311
    1310 
    1311 
    1312 
    1313 (defun nx1-lambda (ll body decls &aux (l ll) methvar)
    1314   (let ((old-env *nx-lexical-environment*)
    1315         (*nx-bound-vars* *nx-bound-vars*))
     1312(defun make-afunc-source-note (afunc source-form)
     1313  ;; Makes a source note and stores it in the lfun-info.
     1314  (let* ((source-note (nx-find-or-make-source-note source-form nil))
     1315         (lambda (afunc-lambdaform afunc))
     1316         (lambda-note (nx-find-or-make-source-note lambda source-note)))
     1317    (setf (afunc-lfun-info afunc)
     1318          (list* 'function-source-note lambda-note (afunc-lfun-info afunc)))
     1319    lambda-note))
     1320
     1321(defun nx1-lambda (ll body decls &optional source-form &aux (l ll) methvar)
     1322  (let* ((old-env *nx-lexical-environment*)
     1323         (*nx-bound-vars* *nx-bound-vars*)
     1324         ;; Make a toplevel source note even if not recording pc mapping or code coverage,
     1325         ;; just to store it for lfun source location info.
     1326         (source-note (when *nx-source-note-map*
     1327                        (make-afunc-source-note *nx-current-function* source-form)))
     1328         (*nx-ccrec* (and (or *compile-code-coverage* *record-pc-mapping*) source-note)))
    13161329    (with-nx-declarations (pending)
    13171330      (let* ((*nx-parsing-lambda-decls* t))
    … …  
    13231336              (nx-error "invalid lambda-list  - ~s" l)))
    13241337          (return-from nx1-lambda
    1325                        (list
     1338                       (make-acode
    13261339                        (%nx1-operator lambda-list)
    13271340                        (list (cons '&lap bits))
    … …  
    13711384         body
    13721385         *nx-new-p2decls*)))))
    1373  
     1386
    13741387(defun nx-parse-simple-lambda-list (pending ll &aux
    13751388                                              req
    … …  
    15651578
    15661579(defun nx1-typed-form (original env)
    1567   (nx1-transformed-form (nx-transform original env) env))
    1568 
    1569 (defun nx1-transformed-form (form &optional (env *nx-lexical-environment*))
     1580  (nx1-transformed-form (nx-transform original env) env original))
     1581
     1582(defun nx1-transformed-form (form env &optional original)
     1583  (if *nx-ccrec*
     1584    (let* ((original (or original form))
     1585           (*nx-ccrec* (nx-find-or-make-source-note original *nx-ccrec*)))
     1586      (make-acode (%nx1-operator with-source-note)
     1587                  *nx-ccrec*
     1588                  (nx1-transformed-form-aux form env)))
     1589    (nx1-transformed-form-aux form env)))
     1590
     1591(defun nx1-transformed-form-aux (form env)
    15701592  (if (consp form)
    15711593    (nx1-combination form env)
    … …  
    15791601        (nx1-symbol form env)
    15801602        (nx1-immediate (nx-unquote constant-value))))))
    1581 
    15821603
    15831604

  • branches/gz-working/compiler/nx1.lisp

    r7624 r8438  
    2929      (setq typespec '*)
    3030      (setq typespec (nx-target-type (type-specifier ctype)))))
    31   (let* ((*nx-form-type* typespec)
    32          (transformed (nx-transform form env)))
    33     (if (and (consp transformed)
    34              (eq (car transformed) 'the))
    35         (setq transformed form))
     31  (let* ((*nx-form-type* typespec))
    3632    (make-acode
    3733     (%nx1-operator typed-form)
    3834     typespec
    39      (nx1-transformed-form transformed env))))
     35     (nx1-transformed-form (let ((transformed (nx-transform form env)))
     36                             (if (and (consp transformed)
     37                                      (eq (car transformed) 'the))
     38                               form
     39                               transformed))
     40                           env form))))
    4041
    4142(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
    … …  
    8687          (cons
    8788           'macro
    88            (multiple-value-bind (function warnings) (compile-named-function (parse-macro name arglist mbody old-env) name  old-env)
     89           (multiple-value-bind (function warnings) (compile-named-function (parse-macro name arglist mbody old-env)
     90                                                                            :name name :env old-env)
    8991             (setq *nx-warnings* (append *nx-warnings* warnings))
    9092             function)))
    … …  
    10591061    (multiple-value-bind (function warnings)
    10601062                         (compile-named-function
    1061                           `(lambda () ,form) nil nil nil nil nil *nx-load-time-eval-token* (backend-name *target-backend*))
     1063                          `(lambda () ,form)
     1064                          :load-time-eval-token  *nx-load-time-eval-token*
     1065                          :target (backend-name *target-backend*))
    10621066      (setq *nx-warnings* (append *nx-warnings* warnings))
    10631067      (nx1-immediate (list *nx-load-time-eval-token* `(funcall ,function))))

  • branches/gz-working/compiler/nxenv.lisp

    r6176 r8438  
    2828#+ppc-target (require "PPCENV")
    2929#+x8664-target (require "X8664ENV")
     30
     31#-BOOTSTRAPPED (unless (boundp '$lfbits-info-bit) (set '$lfbits-info-bit 2))
    3032
    3133(defconstant $afunc-size
    … …  
    410412     (general-aref2 .  #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
    411413     (%single-float .  #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
    412      (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask)))))
     414     (%double-float . #. #.(logior operator-acode-subforms-mask operator-assignment-free-mask operator-single-valued-mask))
     415     (with-source-note . #.(logior operator-assignment-free-mask)))))
    413416
    414417(defmacro %nx1-operator (sym)

  • branches/gz-working/level-1/l1-reader.lisp

    r7730 r8438  
    24612461;;; rewriting those parts of the CLOS and I/O code that make
    24622462;;; using things like READ-CHAR impractical ...
     2463;;; mb: the reason multiple-value-list is used here is that we need to distinguish between the
     2464;;; recursive parse call returning (values nil) and (values).
    24632465(defun %parse-expression (stream firstchar dot-ok)
    24642466  (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))
    2470       (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         (declare (dynamic-extent vals)
    2485                  (list vals))
    2486         (if (null vals)
    2487             (values nil nil)
    2488             (values (car vals) t))))))
     2467         (attrtab (rdtab.ttab readtable))
     2468         (attr (%character-attribute firstchar attrtab))
     2469         (start-pos (file-position stream)))
     2470    (declare (fixnum attr))
     2471    (if (= attr $cht_ill)
     2472        (signal-reader-error stream "Illegal character ~S." firstchar))
     2473    (let* ((vals (multiple-value-list
     2474                  (if (not (logbitp $cht_macbit attr))
     2475                    (%parse-token stream firstchar dot-ok)
     2476                    (let* ((def (cdr (assq firstchar (rdtab.alist readtable)))))
     2477                      (cond ((null def))
     2478                            ((atom def)
     2479                             (funcall def stream firstchar))
     2480                            #+no ; include if %initial-readtable% broken (see above)
     2481                            ((and (consp (car def))
     2482                                  (eq (caar def) 'function))
     2483                             (funcall (cadar def) stream firstchar))
     2484                            ((functionp (car def))
     2485                             (funcall (car def) stream firstchar))
     2486                            (t (error "Bogus default dispatch fn: ~S" (car def)) nil))))))
     2487           (end-pos (and start-pos (file-position stream))))
     2488      (declare (dynamic-extent vals)
     2489               (list vals))
     2490      (if (null vals)
     2491        (values nil nil)
     2492        (destructuring-bind (form &optional nested-source-notes)
     2493                            vals
     2494          (values form
     2495                  t
     2496                  (and (consp form)
     2497                       start-pos
     2498                       (make-source-note :form form
     2499                                         :stream stream
     2500                                         :start-pos (1- start-pos)
     2501                                         :end-pos end-pos
     2502                                         :subform-notes nested-source-notes))))))))
    24892503
    24902504
    … …  
    25052519        (if (eq firstch termch)
    25062520            (return (values nil nil))
    2507             (multiple-value-bind (val val-p) (%parse-expression stream firstch dot-ok)
     2521            (multiple-value-bind (val val-p source-info)
     2522                                 (%parse-expression stream firstch dot-ok)
    25082523              (if val-p
    2509                   (return (values val t))))))))
     2524                  (return (values val t source-info))))))))
    25102525
    25112526
    … …  
    25132528  (let* ((dot-ok (cons nil nil))
    25142529         (head (cons nil nil))
    2515          (tail head))
     2530         (tail head)
     2531         (source-note-list nil))
    25162532    (declare (dynamic-extent dot-ok head)
    25172533             (list head tail))
    25182534    (if nodots (setq dot-ok nil))
    2519     (multiple-value-bind (firstform firstform-p)
     2535    (multiple-value-bind (firstform firstform-p firstform-source-note)
    25202536        (%read-list-expression stream dot-ok termch)
     2537      (when firstform-source-note
     2538        (push firstform-source-note source-note-list))
    25212539      (when firstform-p
    25222540        (if (and dot-ok (eq firstform dot-ok))       ; just read a dot
    … …  
    25242542        (rplacd tail (setq tail (cons firstform nil)))
    25252543        (loop
    2526           (multiple-value-bind (nextform nextform-p)
     2544          (multiple-value-bind (nextform nextform-p nextform-source-note)
    25272545              (%read-list-expression stream dot-ok termch)
     2546            (when nextform-source-note
     2547              (push nextform-source-note source-note-list))
    25282548            (if (not nextform-p) (return))
    25292549            (if (and dot-ok (eq nextform dot-ok))    ; just read a dot
    2530                 (if (multiple-value-bind (lastform lastform-p)
     2550                (if (multiple-value-bind (lastform lastform-p lastform-source-note)
    25312551                        (%read-list-expression stream nil termch)
     2552                      (when lastform-source-note
     2553                        (push lastform-source-note source-note-list))
    25322554                      (and lastform-p
    2533                            (progn (rplacd tail lastform) 
     2555                           (progn (rplacd tail lastform)
    25342556                                  (not (nth-value 1 (%read-list-expression stream nil termch))))))
    25352557                    (return)
    25362558                    (signal-reader-error stream "Dot context error."))
    2537                 (rplacd tail (setq tail (cons nextform nil))))))))
    2538     (cdr head)))
     2559                (progn
     2560                  (rplacd tail (setq tail (cons nextform nil)))))))))
     2561    (values (cdr head) source-note-list)))
    25392562
    25402563#|
    … …  
    28402863(defun read (&optional stream (eof-error-p t) eof-value recursive-p)
    28412864  (declare (resident))
     2865  ;; just return the first value of read-internal
     2866  (values (read-internal stream eof-error-p eof-value recursive-p)))
     2867
     2868(defun read-internal (stream eof-error-p eof-value recursive-p)
    28422869  (setq stream (input-stream-arg stream))
    28432870  (if recursive-p
    … …  
    28582885(defun read-delimited-list (char &optional stream recursive-p)
    28592886  "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."
     2887   value's representation is CHAR, and return the objects as a list."
    28612888  (setq char (require-type char 'character))
    28622889  (setq stream (input-stream-arg stream))
    … …  
    29122939              (error 'end-of-file :stream stream)
    29132940              (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 
     2941            (multiple-value-bind (form form-p source-note)
     2942                                 (%parse-expression stream ch nil)
     2943              (when form-p
     2944                (return
     2945                 (values (if *read-suppress* nil form)
     2946                         source-note)))))))))
    29202947
    29212948
    … …  
    29502977
    29512978
    2952 
    2953 
    2954 
     2979;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     2980
     2981(defstruct (source-note (:constructor %make-source-note))
     2982  ;; Code coverage state.  This MUST be the first slot - see nx**2-code-coverage.
     2983  code-coverage
     2984  ;; The actual form
     2985  form
     2986  ;; The source location: file name, and start/end offsets within the file
     2987  file-name
     2988  start-pos
     2989  end-pos
     2990  ;; For the outermost source form, a string (the text of the form).
     2991  ;; For an inner source form, the source-note of the outer source form.
     2992  ;; For a generated form (no file info), source-note of original form.
     2993  source
     2994  ;; PC information generated by compiler.  For source notes not stored in
     2995  ;; an lfun, it could contain garbage if compilation of containing form
     2996  ;; was started and interrupted.
     2997  start-pc
     2998  end-pc
     2999  ;; Notes for code-generating subforms of this form
     3000  subform-notes)
     3001
     3002(defun source-note-length (note)
     3003  (- (source-note-end-pos note) (source-note-start-pos note)))
     3004
     3005(defun source-note-text (note)
     3006  (multiple-value-bind (string offset) (source-note-string-and-offset note)
     3007    (subseq string offset (+ offset (source-note-length note)))))
     3008
     3009(defun source-note-string-and-offset (note)
     3010  "Returns a string and offset where the text of note's form starts"
     3011  (let ((source (source-note-source note)))
     3012    (cond ((stringp source)
     3013           (assert (<= (source-note-length note) (length source)))
     3014           (values source 0))
     3015          (t
     3016           (let ((start (source-note-start-pos note))
     3017                 (parent-start (source-note-start-pos source)))
     3018           (assert (<= parent-start start
     3019                       (source-note-end-pos note) (source-note-end-pos source)))
     3020           (multiple-value-bind (parent-string parent-offset)
     3021                                (source-note-string-and-offset source)
     3022             (values parent-string (+ parent-offset (- start parent-start)))))))))
     3023
     3024(defvar *recording-source-streams* ())
     3025
     3026(defun read-recording-source (stream &key eofval file-name start-offset map)
     3027  "Read a top-level form recording source location notes in MAP"
     3028  (if (null map)
     3029    (values (read-internal stream nil eofval nil))
     3030    (let* ((recording (list stream map file-name start-offset))
     3031           (*recording-source-streams* (cons recording *recording-source-streams*)))
     3032      (declare (dynamic-extent recording *recording-source-streams*))
     3033      (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
     3034        (when (and source-note (not (eq form eofval)))
     3035          (assert (null (source-note-source source-note)))
     3036          (let ((text (make-string (source-note-length source-note)))
     3037                (pos (file-position stream)))
     3038            (file-position stream (- (source-note-start-pos source-note) start-offset))
     3039            (read-sequence text stream)
     3040            (file-position stream pos)
     3041            (setf (source-note-source source-note) text)))
     3042        form))))
     3043
     3044(defun make-source-note (&key form stream start-pos end-pos subform-notes source)
     3045  (assert (or (null source) (null (or stream start-pos end-pos subform-notes))))
     3046  (if stream
     3047    ;; source note for form read from a stream
     3048    (let ((recording (assoc stream *recording-source-streams*)))
     3049      (assert (null source))
     3050      (when (and recording (not *read-suppress*))
     3051        (destructuring-bind (map file-name stream-offset) (cdr recording)
     3052          (let ((note (%make-source-note :form form
     3053                                         :file-name file-name
     3054                                         :start-pos (+ stream-offset start-pos)
     3055                                         :end-pos (+ stream-offset end-pos))))
     3056            (setf (gethash form map) note)
     3057            (labels ((rec (subnote)
     3058                       (cond
     3059                        ((consp subnote)
     3060                         (if (null (car subnote))
     3061                           (rec (cdr subnote))
     3062                           (progn (rec (car subnote)) (rec (cdr subnote)))))
     3063                        ((source-note-p subnote)
     3064                         (unless (source-note-source subnote)
     3065                           (setf (source-note-source subnote) note)))
     3066                        #| ((null note) '())
     3067                        (t (error "Don't know how to deal with a source note like ~S."
     3068                                  nested-source-notes)) |# )))
     3069              (rec subform-notes))
     3070            note))))
     3071    ;; Else note for a form generated by macroexpansion
     3072    (let* ((source (and source (require-type source 'source-note)))
     3073           (note (%make-source-note :form form :source source)))
     3074      (when source (push note (source-note-subform-notes source)))
     3075      note)))
     3076
     3077; end

  • branches/gz-working/lib/db-io.lisp

    r7609 r8438  
    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
     852            (if query
     853              fv
     854              (%foreign-access-form `(%reference-external-entry-point (load-time-value ,fv))
     855                                    (fv.type fv)
     856                                    0
     857                                    nil))
     858            source)))))))
    857859
    858860
    … …  
    987989         (query nil)
    988990         (error nil)
    989          (sym nil))
     991         (sym nil)
     992         (source nil))
    990993    (let* ((*package* package))
    991994      (unwind-protect
    … …  
    995998               (setq query t)
    996999               (read-char stream))
    997              (multiple-value-setq (sym error)
    998                (handler-case (read stream nil nil)
    999                  (error (condition) (values nil condition)))))
     1000             (multiple-value-setq (sym source error)
     1001               (handler-case (read-internal stream nil t nil)
     1002                 (error (condition) (values nil nil condition)))))
    10001003        (setf (readtable-case *readtable*) case)))
    10011004    (when error
    10021005      (error error))
    1003     (values sym query)))
     1006    (values sym source query)))
    10041007
    10051008(set-dispatch-macro-character
    … …  
    10081011   (declare (ignore char))
    10091012   (let* ((package (find-package (ftd-interface-package-name *target-ftd*))))
    1010      (multiple-value-bind (sym query)
     1013     (multiple-value-bind (sym source query)
    10111014         (%read-symbol-preserving-case
    10121015            stream
    … …  
    10161019           (symbol
    10171020            (if query
    1018               (load-os-constant sym query)
     1021              (values (load-os-constant sym query) source)
    10191022              (progn
    10201023                (when (eq (symbol-package sym) package)
    … …  
    10271030                       (load-os-constant sym)))
    10281031                    (1 (makunbound sym) (load-os-constant sym))))
    1029                 sym)))
     1032                (values sym source))))
    10301033           (string
    10311034            (let* ((val 0)
    10321035                   (len (length sym)))
    1033               (dotimes (i 4 val)
     1036              (dotimes (i 4 (values val source))
    10341037                (let* ((ch (if (< i len) (char sym i) #\space)))
    10351038                  (setq val (logior (ash val 8) (char-code ch)))))))))))))
    … …  
    10391042    (declare (ignore char))
    10401043    (unless arg (setq arg 0))
    1041     (multiple-value-bind (sym query)
     1044    (multiple-value-bind (sym source query)
    10421045        (%read-symbol-preserving-case
    10431046                 stream
    … …  
    10461049        (unless (and sym (symbolp sym)) (report-bad-arg sym 'symbol))
    10471050        (if query
    1048           (load-external-function sym t)
     1051          (values (load-external-function sym t) source)
    10491052          (let* ((def (if (eql arg 0)
    10501053                        (gethash sym (ftd-external-function-definitions
    10511054                                      *target-ftd*)))))
    1052             (if (and def (eq (macro-function sym) #'%external-call-expander))
    1053               sym
    1054               (load-external-function sym nil))))))))
     1055            (values (if (and def (eq (macro-function sym) #'%external-call-expander))
     1056                      sym
     1057                      (load-external-function sym nil))
     1058                    source)))))))
    10551059
    10561060(set-dispatch-macro-character

  • branches/gz-working/lib/defstruct-lds.lisp

    r2325 r8438  
    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/gz-working/lib/defstruct.lisp

    r5434 r8438  
    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/gz-working/lib/encapsulate.lisp

    r6499 r8438  
    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/gz-working/lib/misc.lisp

    r8418 r8438  
    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/gz-working/lib/nfcomp.lisp

    r8406 r8438  
    3030(require 'defstruct-macros)
    3131
     32#-BOOTSTRAPPED (unless (fboundp 'read-recording-source)
     33                 (defun read-internal (stream &optional eof-error-p eofval recursive-p)
     34                   (read stream eof-error-p eofval recursive-p))
     35                 (defun read-recording-source (stream &key eofval file-name start-offset map)
     36                   (read stream nil eofval nil)))
     37
    3238
    3339(defmacro short-fixnum-p (fixnum)
    … …  
    4753;they should be in the product just in case we need them for patches....
    4854(defvar *fasl-save-local-symbols* t)
     55(defvar *fasl-save-source-locations* nil)
    4956(defvar *fasl-deferred-warnings* nil)
    5057(defvar *fasl-non-style-warnings-signalled-p* nil)
    … …  
    6067  "The TRUENAME of the file currently being compiled, or NIL if not
    6168  compiling.") ; truename ...
     69(defvar *compile-file-original-truename* nil
     70  "The name to use for recording source locations")
     71(defvar *compile-file-original-buffer-offset* nil
     72  "Start offset to use for recording source locations")
    6273(defvar *fasl-target* (backend-name *host-backend*))
    6374(defvar *fasl-backend* *host-backend*)
    … …  
    108119                         (target *fasl-target* target-p)
    109120                         (save-local-symbols *fasl-save-local-symbols*)
     121                         (save-source-locations *fasl-save-source-locations*)
    110122                         (save-doc-strings *fasl-save-doc-strings*)
    111123                         (save-definitions *fasl-save-definitions*)
    … …  
    121133        (restart-case
    122134         (return (%compile-file src output-file verbose print load features
    123                                 save-local-symbols save-doc-strings save-definitions force backend external-format))
     135                                save-local-symbols save-source-locations save-doc-strings save-definitions
     136                                force backend external-format))
    124137         (retry-compile-file ()
    125138                             :report (lambda (stream) (format stream "Retry compiling ~s" src))
    … …  
    131144
    132145(defun %compile-file (src output-file verbose print load features
    133                           save-local-symbols save-doc-strings save-definitions force target-backend external-format
    134                           &aux orig-src)
     146                          save-local-symbols save-source-locations save-doc-strings save-definitions
     147                          force target-backend external-format &aux orig-src)
    135148
    136149  (setq orig-src (merge-pathnames src))
    … …  
    164177             (*fasl-deferred-warnings* nil) ; !!! WITH-COMPILATION-UNIT ...
    165178             (*fasl-save-local-symbols* save-local-symbols)
     179             (*fasl-save-source-locations* save-source-locations)
    166180             (*fasl-save-doc-strings* save-doc-strings)
    167181             (*fasl-save-definitions* save-definitions)
    … …  
    246260                              (signal c))))
    247261      (funcall (compile-named-function
    248                 `(lambda () ,form) nil env nil nil
    249                 *compile-time-evaluation-policy*)))))
     262                `(lambda () ,form)
     263                :env env
     264                :policy *compile-time-evaluation-policy*)))))
    250265
    251266
    … …  
    315330(defvar *fcomp-output-list*)
    316331(defvar *fcomp-toplevel-forms*)
     332(defvar *fcomp-source-note-map*)
    317333(defvar *fcomp-warnings-header*)
    318334(defvar *fcomp-stream-position* nil)
    … …  
    390406           (*fasl-eof-forms* nil)
    391407           (*loading-file-source-file* (namestring orig-file)) ; why orig-file???
     408           (*fcomp-source-note-map* (and *fasl-save-source-locations* (make-hash-table)))
    392409           (eofval (cons nil nil))
    393410           (read-package nil)
    … …  
    415432                                (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
    416433                                (signal c))))
    417                   (setq form (read stream nil eofval)))))
     434                  (setq form (read-recording-source stream
     435                                                    :eofval eofval
     436                                                    :file-name (or *compile-file-original-truename* (truename stream))
     437                                                    :start-offset (or *compile-file-original-buffer-offset* 0)
     438                                                    :map *fcomp-source-note-map*)))))
    418439            (when (eq eofval form) (return))
    419             (fcomp-form form env processing-mode)
     440            (fcomp-form form env processing-mode form)
    420441            (setq *fcomp-previous-position* *fcomp-stream-position*))))
    421442      (while (setq form *fasl-eof-forms*)
    422443        (setq *fasl-eof-forms* nil)
    423         (fcomp-form-list form env processing-mode))
     444        (fcomp-form-list form env processing-mode nil))
    424445      (when old-file
    425446        (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
    … …  
    428449
    429450
    430 (defun fcomp-form (form env processing-mode
     451(defun fcomp-form (form env processing-mode &optional source
    431452                        &aux print-stuff
    432453                        (load-time (and processing-mode (neq processing-mode :compile-time)))
    … …  
    467488                             "  (Compiletime)"
    468489                             "")))))))
    469     (fcomp-form-1 form env processing-mode)))
    470            
    471 (defun fcomp-form-1 (form env processing-mode &aux sym body)
     490    (fcomp-form-1 form env processing-mode source)))
     491
     492(defun fcomp-form-1 (form env processing-mode &optional source &aux sym body)
    472493  (if (consp form) (setq sym (%car form) body (%cdr form)))
    473494  (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))
     495    (progn
     496      (fcomp-form-list body env processing-mode source))
     497    (eval-when
     498      (fcomp-eval-when body env processing-mode source))
     499    (compiler-let
     500      (fcomp-compiler-let body env processing-mode source))
     501    (locally
     502      (fcomp-locally body env processing-mode source))
     503    (macrolet
     504      (fcomp-macrolet body env processing-mode source))
     505   #|;; special case for passing around source-location info
     506    (%source-note
     507       (fcomp-form (list 'quote (source-note-to-list *definition-source-note*))
     508                 end processing-mode))
     509    |#
    479510    ((%include include) (fcomp-include form env processing-mode))
    480511    (t
    … …  
    489520             (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
    490521             (multiple-value-bind (new win) (macroexpand-1 form env)
    491                (if win (setq form new))
     522               (when win
     523                 (setq form new))
    492524               win))
    493         (fcomp-form form env processing-mode))
     525        (fcomp-form form env processing-mode source))
    494526       ((and (not *fcomp-inside-eval-always*)
    495527             (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)))
     528        (let* ((*fcomp-inside-eval-always* t)
     529               (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form)))
     530          (fcomp-form-1 new env processing-mode source)))
    498531       (t
    499532        (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
    … …  
    501534        (when (and processing-mode (neq processing-mode :compile-time))
    502535          (case sym
    503             ((%defconstant) (fcomp-load-%defconstant form env))
    504             ((%defparameter) (fcomp-load-%defparameter form env))
    505             ((%defvar %defvar-init) (fcomp-load-defvar form env))
    506             ((%defun) (fcomp-load-%defun form env))
     536            ((%defconstant) (fcomp-load-%defconstant form env source))
     537            ((%defparameter) (fcomp-load-%defparameter form env source))
     538            ((%defvar %defvar-init) (fcomp-load-defvar form env source))
     539            ((%defun) (fcomp-load-%defun form env source))
    507540            ((set-package %define-package)
    508              (fcomp-random-toplevel-form form env)
     541             (fcomp-random-toplevel-form form env source)
    509542             (fcomp-compile-toplevel-forms env))
    510             ((%macro) (fcomp-load-%macro form env))
    511             ;; ((%deftype) (fcomp-load-%deftype form))
    512             ;; ((define-setf-method) (fcomp-load-define-setf-method form))
    513             (t (fcomp-random-toplevel-form form env)))))))))
    514 
    515 (defun fcomp-form-list (forms env processing-mode)
    516   (dolist (form forms) (fcomp-form form env processing-mode)))
    517 
    518 (defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
     543            ((%macro) (fcomp-load-%macro form env source))
     544            ;; ((%deftype) (fcomp-load-%deftype form source))
     545            ;; ((define-setf-method) (fcomp-load-define-setf-method form source))
     546            (t (fcomp-random-toplevel-form form env source)))))))))
     547
     548(defun fcomp-form-list (forms env processing-mode source)
     549  (dolist (form forms) (fcomp-form form env processing-mode source)))
     550
     551(defun fcomp-compiler-let (form env processing-mode source &aux vars varinits)
    519552  (fcomp-compile-toplevel-forms env)
    520553  (dolist (pair (pop form))
    … …  
    522555    (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
    523556  (progv (nreverse vars) (nreverse varinits)
    524                  (fcomp-form-list form env processing-mode)
     557                 (fcomp-form-list form env processing-mode source)
    525558                 (fcomp-compile-toplevel-forms env)))
    526559
    527 (defun fcomp-locally (body env processing-mode)
     560(defun fcomp-locally (body env processing-mode source)
    528561  (fcomp-compile-toplevel-forms env)
    529562  (multiple-value-bind (body decls) (parse-body body env)
    530563    (let* ((env (augment-environment env :declare (decl-specs-from-declarations decls))))
    531       (fcomp-form-list body env processing-mode)
     564      (fcomp-form-list body env processing-mode source)
    532565      (fcomp-compile-toplevel-forms env))))
    533566
    534 (defun fcomp-macrolet (body env processing-mode)
     567(defun fcomp-macrolet (body env processing-mode source)
    535568  (fcomp-compile-toplevel-forms env)
    536569  (let ((outer-env (augment-environment env
    … …  
    545578                   outer-env
    546579                   :declare (decl-specs-from-declarations decls))))
    547         (fcomp-form-list body env processing-mode)
     580        (fcomp-form-list body env processing-mode source)
    548581        (fcomp-compile-toplevel-forms env)))))
    549582
    550 (defun fcomp-symbol-macrolet (body env processing-mode)
     583(defun fcomp-symbol-macrolet (body env processing-mode source)
    551584  (fcomp-compile-toplevel-forms env)
    552585  (let* ((outer-env (augment-environment env :symbol-macro (car body))))
    … …  
    554587      (let* ((env (augment-environment outer-env
    555588                                       :declare (decl-specs-from-declarations decls))))
    556         (fcomp-form-list body env processing-mode)
     589        (fcomp-form-list body env processing-mode source)
    557590        (fcomp-compile-toplevel-forms env)))))
    558                                                                
    559 (defun fcomp-eval-when (form env processing-mode &aux (eval-times (pop form)))
     591
     592(defun fcomp-eval-when (form env processing-mode source &aux (eval-times (pop form)))
    560593  (let* ((compile-time-too  (eq processing-mode :compile-time-too))
    561594         (compile-time-only (eq processing-mode :compile-time))
    … …  
    574607    (fcomp-compile-toplevel-forms env)        ; always flush the suckers
    575608    (cond (compile-time-only
    576            (if at-eval-time (fcomp-form-list form env :compile-time)))
     609           (if at-eval-time (fcomp-form-list form env :compile-time source)))
    577610          (at-load-time
    578611           (fcomp-form-list form env (if (or at-compile-time (and at-eval-time compile-time-too))
    579612                                       :compile-time-too
    580                                        :not-compile-time)))
     613                                       :not-compile-time) source))
    581614          ((or at-compile-time (and at-eval-time compile-time-too))
    582            (fcomp-form-list form env :compile-time))))
     615           (fcomp-form-list form env :compile-time source))))
    583616  (fcomp-compile-toplevel-forms env))
    584617
    … …  
    609642    symbol))
    610643
    611 (defun fcomp-load-%defconstant (form env)
     644(defun fcomp-load-%defconstant (form env source)
    612645  (destructuring-bind (sym valform &optional doc) (cdr form)
    613646    (unless *fasl-save-doc-strings*
    … …  
    617650    (if (and (typep sym 'symbol) (or  (quoted-form-p valform) (self-evaluating-p valform)))
    618651      (fcomp-output-form $fasl-defconstant env sym (eval-constant valform) (eval-constant doc))
    619       (fcomp-random-toplevel-form form env))))
    620 
    621 (defun fcomp-load-%defparameter (form env)
     652      (fcomp-random-toplevel-form form env source))))
     653
     654(defun fcomp-load-%defparameter (form env source)
    622655  (destructuring-bind (sym valform &optional doc) (cdr form)
    623656    (unless *fasl-save-doc-strings*
    … …  
    628661      (if (and (typep sym 'symbol) (or fn (constantp valform)))
    629662        (fcomp-output-form $fasl-defparameter env sym (or fn (eval-constant valform)) (eval-constant doc))
    630         (fcomp-random-toplevel-form form env)))))
     663        (fcomp-random-toplevel-form form env source)))))
    631664
    632665; Both the simple %DEFVAR and the initial-value case (%DEFVAR-INIT) come here.
    … …  
    635668; Hairier initforms could be handled by another fasl operator that takes a thunk
    636669; and conditionally calls it.
    637 (defun fcomp-load-defvar (form env)
     670(defun fcomp-load-defvar (form env source)
    638671  (destructuring-bind (sym &optional (valform nil val-p) doc) (cdr form)
    639672    (unless *fasl-save-doc-strings*
    … …  
    647680          (if (and sym-p (or fn (constantp valform)))
    648681            (fcomp-output-form $fasl-defvar-init env sym (or fn (eval-constant valform)) (eval-constant doc))
    649             (fcomp-random-toplevel-form (macroexpand-1 form env) env)))))))
     682            (fcomp-random-toplevel-form (macroexpand-1 form env) env source)))))))
    650683     
    651684(defun define-compile-time-macro (name lambda-expression env)
    … …  
    654687      (push (list* name
    655688                   'macro
    656                    (compile-named-function lambda-expression name env))
     689                   (compile-named-function lambda-expression :name name :env env))
    657690            (defenv.functions definition-env)))
    658691    name))
    … …  
    722755         )))))
    723756
    724 (defun fcomp-load-%defun (form env)
     757(defun fcomp-load-%defun (form env source)
    725758  (destructuring-bind (fn &optional doc) (cdr form)
    726759    (unless *fasl-save-doc-strings*
    … …  
    730763        (setq doc nil)))
    731764    (if (and (constantp doc)
    732              (setq fn (fcomp-function-arg fn env)))
     765             (setq fn (fcomp-function-arg fn env source)))
    733766      (progn
    734767        (setq doc (eval-constant doc))
    735768        (fcomp-output-form $fasl-defun env fn doc))
    736       (fcomp-random-toplevel-form form env))))
    737 
    738 (defun fcomp-load-%macro (form env &aux fn doc)
     769      (fcomp-random-toplevel-form form env source))))
     770
     771(defun fcomp-load-%macro (form env source &aux fn doc)
    739772  (verify-arg-count form 1 2)
    740773  (if (and (constantp (setq doc (caddr form)))
    741            (setq fn (fcomp-function-arg (cadr form) env)))
     774           (setq fn (fcomp-function-arg (cadr form) env source)))
    742775    (progn
    743776      (setq doc (eval-constant doc))
    744777      (fcomp-output-form $fasl-macro env fn doc))
    745     (fcomp-random-toplevel-form form env)))
     778    (fcomp-random-toplevel-form form env source)))
    746779
    747780(defun define-compile-time-structure (sd refnames predicate env)
    … …  
    766799  (nx-transform form env))
    767800
    768 (defun fcomp-random-toplevel-form (form env)
     801(defun fcomp-random-toplevel-form (form env source)
    769802  (unless (constantp form)
    770803    (unless (or (atom form)
    … …  
    778811        (while args
    779812          (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
    780             (when (or (setq lfun (fcomp-function-arg arg env))
     813            (when (or (setq lfun (fcomp-function-arg arg env source))
    781814                      win)
    782815              (when lfun (setq arg `',lfun))
    … …  
    788821    (push form *fcomp-toplevel-forms*)))
    789822
    790 (defun fcomp-function-arg (expr env)
     823(defun fcomp-function-arg (expr env &optional source)
    791824  (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)))))
     825    (cond ((and (eq (%car expr) 'nfunction)
     826                (symbolp (car (%cdr expr)))
     827                (lambda-expression-p (car (%cddr expr))))
     828           (fcomp-named-function (%caddr expr) (%cadr expr) env source))
     829          ((and (eq (%car expr) 'function)
     830                (lambda-expression-p (car (%cdr expr))))
     831           (fcomp-named-function (%cadr expr) nil env source)))))
    799832
    800833(defun fcomp-compile-toplevel-forms (env)
    … …  
    835868;;; file.  The result will not be funcalled.  This really shouldn't bother
    836869;;; making an lfun, but it's simpler this way...
    837 (defun fcomp-named-function (def name env)
     870(defun fcomp-named-function (def name env &optional source)
    838871  (let* ((env (new-lexical-environment env)))
    839872    (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*)
     873                         (compile-named-function def
     874                                                 :name name
     875                                                 :env env
     876                                                 :source source
     877                                                 :keep-lambda *fasl-save-definitions*
     878                                                 :keep-symbols *fasl-save-local-symbols*
     879                                                 :policy *default-file-compilation-policy*
     880                                                 :source-locations *fcomp-source-note-map*
     881                                                 :load-time-eval-token cfasl-load-time-eval-sym
     882                                                 :target *fasl-target*)
    848883      (fcomp-signal-or-defer-warnings warnings env)
    849884      lfun)))
    … …  
    10831118                                             (or
    10841119                                              (gethash load-form *make-load-form-hash*)
    1085                                               (fcomp-named-function `(lambda () ,load-form) nil nil))
     1120                                              (fcomp-named-function `(lambda () ,load-form) nil nil nil))
    10861121                          (when warnings
    10871122                            (cerror "Ignore the warnings"

  • branches/gz-working/lib/read.lisp

    r6921 r8438  
    4646               (cons form (read-file-to-list-aux stream))))))
    4747|#
    48 
    49 (defun read-internal (input-stream)
    50   (read input-stream t nil t))
    5148
    5249
    … …  
    9693          (signal-reader-error stream "reader macro #A used without a rank integer"))
    9794         ((eql dimensions 0) ;0 dimensional array
    98           (make-array nil :initial-contents (read-internal stream)))
     95          (make-array nil :initial-contents (read-internal stream t nil t)))
    9996         ((and (integerp dimensions) (> dimensions 0))
    100           (let ((init-list (read-internal stream)))
     97          (let ((init-list (read-internal stream t nil t)))
    10198            (cond ((not (typep init-list 'sequence))
    10299                   (signal-reader-error stream "The form following a #~SA reader macro should have been a sequence, but it was: ~S" dimensions init-list))
    … …  
    130127  (qlfun |#S-reader| (input-stream sub-char int &aux list sd)
    131128     (declare (ignore sub-char int))
    132      (setq list (read-internal input-stream))
     129     (setq list (read-internal input-stream t nil t))
    133130     (unless *read-suppress*
    134131       (unless (and (consp list)

  • branches/gz-working/library/lispequ.lisp

    r7958 r8438  
    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.