Changeset 11901


Ignore:
Timestamp:
Apr 5, 2009, 5:42:53 PM (10 years ago)
Author:
gz
Message:

Record source locations when loading source files

Location:
trunk/source
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/nx-basic.lisp

    r11805 r11901  
    5555    (setf (gethash acode *nx-acode-note-map*) note)))
    5656
    57 
    58 (defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
    59   (when source-notes
    60     (when (or (consp form) (vectorp form) (pathnamep form))
    61       (let ((note (gethash form source-notes)))
    62         (unless (listp note) note)))))
    6357
    6458(defstruct (code-note (:constructor %make-code-note))
     
    116110             (not (gethash new source-notes)))
    117111    (setf (gethash new source-notes) sn)))
    118 
    119112
    120113
  • trunk/source/compiler/nx0.lisp

    r11806 r11901  
    21632163
    21642164)
     2165
     2166(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
     2167  (when source-notes
     2168    (when (or (consp form) (vectorp form) (pathnamep form))
     2169      (let ((note (gethash form source-notes)))
     2170        (unless (listp note) note)))))
    21652171
    21662172(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
  • trunk/source/level-1/l1-files.lisp

    r11859 r11901  
    13221322(defun load-from-stream (stream print &aux (eof-val (list ())) val)
    13231323  (with-compilation-unit (:override nil) ; try this for included files
    1324     (let ((env (new-lexical-environment (new-definition-environment 'eval))))
     1324    (let ((env (new-lexical-environment (new-definition-environment 'eval)))
     1325          ;; source note map to use with any compilations.
     1326          (*nx-source-note-map*  (and *save-source-locations*
     1327                                      (make-hash-table :test #'eq :shared nil)))
     1328          (*loading-toplevel-location* nil))
    13251329      (%rplacd (defenv.type (lexenv.parent-env env)) *outstanding-deferred-warnings*)
    1326       (while (neq eof-val (setq val (read stream nil eof-val)))
     1330      (loop
     1331        (multiple-value-setq (val *loading-toplevel-location*)
     1332          (read-recording-source stream
     1333                                 :eofval eof-val
     1334                                 :file-name *loading-file-source-file*
     1335                                 :map *nx-source-note-map*
     1336                                 :save-source-text (neq *save-source-locations* :no-text)))
     1337        (when (eq eof-val val)
     1338          (return))
    13271339        (when (eq print :source) (format t "~&Source: ~S~%" val))
    13281340        (setq val (cheap-eval-in-environment val env))
  • trunk/source/level-1/l1-readloop.lisp

    r11787 r11901  
    554554        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
    555555
     556(defun cheap-eval-macroexpand-1 (form env)
     557  (multiple-value-bind (new win) (macroexpand-1 form env)
     558    (when win
     559      (note-source-transformation form new))
     560    (values new win)))
     561
     562(defun cheap-eval-transform (original new)
     563  (note-source-transformation original new)
     564  new)
     565
     566(defun cheap-eval-function (name lambda env)
     567  (multiple-value-bind (lfun warnings)
     568                       (compile-named-function lambda
     569                                               :name name
     570                                               :env env
     571                                               :function-note *loading-toplevel-location*
     572                                               :keep-lambda *save-definitions*
     573                                               :keep-symbols *save-local-symbols*
     574                                               :source-notes *nx-source-note-map*)
     575    (signal-or-defer-warnings warnings env)
     576    lfun))
     577
     578(fset 'nx-source-note (nlambda bootstrapping-source-note (form) (declare (ignore form)) nil))
     579
    556580(defun cheap-eval-in-environment (form env &aux sym)
    557581  (declare (resident))
     582  ;; records source locations if *nx-source-note-map* is bound by caller
     583  (setq *loading-toplevel-location* (or (nx-source-note form) *loading-toplevel-location*))
    558584  (flet ((progn-in-env (body&decls parse-env base-env)
    559585           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
    560586             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
    561              (while (cdr body)
    562                (cheap-eval-in-environment (pop body) base-env))
     587             (loop with default-location = *loading-toplevel-location*
     588               while (cdr body) as form = (pop body)
     589               do (cheap-eval-in-environment form base-env)
     590               do (setq *loading-toplevel-location* default-location))
    563591             (cheap-eval-in-environment (car body) base-env))))
    564592    (if form
    565593      (cond ((symbolp form)
    566              (multiple-value-bind (expansion win) (macroexpand-1 form env)
     594             (multiple-value-bind (expansion win) (cheap-eval-macroexpand-1 form env)
    567595               (if win
    568                  (cheap-eval-in-environment expansion env) 
     596                 (cheap-eval-in-environment expansion env)
    569597                 (let* ((defenv (definition-environment env))
    570598                        (constant (if defenv (assq form (defenv.constants defenv))))
     
    595623                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
    596624                    (%function (setf-function-name (%cadr sym))))
    597                    (t (%make-function nil sym env))))
     625                   (t (cheap-eval-function nil sym env))))
    598626            ((eq sym 'nfunction)
    599627             (verify-arg-count form 2 2)
    600              (%make-function (%cadr form) (%caddr form) env))
     628             (cheap-eval-function (%cadr form) (%caddr form) env))
    601629            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
    602630            ((eq sym 'setq)
     
    604632               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
    605633             (let* ((sym nil)
    606                     (val nil))
     634                    (val nil)
     635                    (original form))
    607636               (while (setq form (%cdr form))
    608637                 (setq sym (require-type (pop form) 'symbol))
    609638                 (multiple-value-bind (expansion expanded)
    610                                       (macroexpand-1 sym env)
     639                                      (cheap-eval-macroexpand-1 sym env)
    611640                   (if expanded
    612                      (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
     641                     (setq val (cheap-eval-in-environment
     642                                (cheap-eval-transform original `(setf ,expansion ,(%car form)))
     643                                env))
    613644                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
    614645               val))
     
    618649            ((eq sym 'if)
    619650             (destructuring-bind (test true &optional false) (%cdr form)
    620                (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
     651               (setq test (let ((*loading-toplevel-location* *loading-toplevel-location*))
     652                            (cheap-eval-in-environment test env)))
     653               (cheap-eval-in-environment (if test true false) env)))
    621654            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
    622655            ((eq sym 'symbol-macrolet)
     
    638671               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
    639672                 (unwind-protect
    640                    (cheap-eval-in-environment protected-form env)
     673                     (let ((*loading-toplevel-location* *loading-toplevel-location*))
     674                       (cheap-eval-in-environment protected-form env))
    641675                   (progn-in-env cleanup-forms env env)))
    642                (funcall (%make-function nil `(lambda () (progn ,form)) env))))
     676               (funcall (cheap-eval-function nil (cheap-eval-transform form `(lambda () (progn ,form))) env))))
    643677            ((and (symbolp sym) (macro-function sym env))
    644              (if (eq sym 'step)
    645                (let ((*compile-definitions* nil))
    646                      (cheap-eval-in-environment (macroexpand-1 form env) env))
    647                (cheap-eval-in-environment (macroexpand-1 form env) env)))
     678             (cheap-eval-in-environment (cheap-eval-macroexpand-1 form env) env))
    648679            ((or (symbolp sym)
    649680                 (and (consp sym) (eq (%car sym) 'lambda)))
    650              (let ((args nil))
    651                (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
    652                (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
     681             (let ((args nil) (form-location *loading-toplevel-location*))
     682               (dolist (elt (%cdr form))
     683                 (push (cheap-eval-in-environment elt env) args)
     684                 (setq *loading-toplevel-location* form-location))
     685               (apply #'call-check-regs (if (symbolp sym) sym (cheap-eval-function nil sym env))
    653686                      (nreverse args))))
    654687            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
Note: See TracChangeset for help on using the changeset viewer.