Changeset 12236 for branches


Ignore:
Timestamp:
Jun 9, 2009, 3:16:16 PM (11 years ago)
Author:
gz
Message:

r11901 from trunk

Location:
branches/working-0711/ccl
Files:
8 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/compiler/nx-basic.lisp

    r12162 r12236  
    6262    (assert *nx-acode-note-map*)
    6363    (setf (gethash acode *nx-acode-note-map*) note)))
    64 
    65 
    66 (defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
    67   (when source-notes
    68     (when (or (consp form) (vectorp form) (pathnamep form))
    69       (let ((note (gethash form source-notes)))
    70         (unless (listp note) note)))))
    7164
    7265
  • branches/working-0711/ccl/compiler/nx0.lisp

    r12158 r12236  
    21942194                                     (declare (ignore env))
    21952195                                     (funcall old a b)))))
     2196
     2197(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
     2198  (when source-notes
     2199    (when (or (consp form) (vectorp form) (pathnamep form))
     2200      (let ((note (gethash form source-notes)))
     2201        (unless (listp note) note)))))
     2202
    21962203
    21972204(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
  • branches/working-0711/ccl/level-1/l1-files.lisp

    r12202 r12236  
    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))
  • branches/working-0711/ccl/level-1/l1-reader.lisp

    r12079 r12236  
    32063206In addition, if MAP is a hash table, it gets filled with source-note's for all
    32073207non-atomic nested subforms."
     3208  (when (null start-offset) (setq start-offset 0))
    32083209  (typecase map
    32093210    (null (values (read-internal stream nil eofval nil) nil))
    32103211    (hash-table
    3211      (let* ((recording (list stream map file-name (or start-offset 0)))
    3212             (*recording-source-streams* (cons recording *recording-source-streams*)))
    3213        (declare (dynamic-extent recording *recording-source-streams*))
    3214        (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
    3215          (when (and source-note (not (eq form eofval)))
    3216            (assert (null (source-note-source source-note)))
    3217            (loop for form being the hash-key using (hash-value note) of map
    3218                  do (cond ((eq note source-note) nil)
    3219                           ;; Remove entries with multiple source notes, which can happen
    3220                           ;; for atoms.  If we can't tell which instance we mean, then we
    3221                           ;; don't have useful source info.
    3222                           ((listp note) (remhash form map))
    3223                           ((loop for p = note then (source-note-source p) while (source-note-p p)
    3224                                  thereis (eq p source-note))
    3225                            ;; Flatten the backpointers so each subnote points directly
    3226                            ;; to the toplevel note.
    3227                            (setf (source-note-source note) source-note))))
    3228            (when save-source-text
    3229              (let ((text (make-string (source-note-length source-note)))
    3230                     (pos (file-position stream)))
    3231                (file-position stream (- (source-note-start-pos source-note) start-offset))
    3232                (read-sequence text stream)
    3233                (file-position stream pos)
    3234                (setf (source-note-source source-note) (%fast-compact text)))))
    3235         (values form source-note))))
     3212       (let* ((recording (list stream map file-name start-offset))
     3213              (*recording-source-streams* (cons recording *recording-source-streams*)))
     3214         (declare (dynamic-extent recording *recording-source-streams*))
     3215         (multiple-value-bind (form source-note) (read-internal stream nil eofval nil)
     3216           (when (and source-note (not (eq form eofval)))
     3217             (assert (null (source-note-source source-note)))
     3218             (loop for form being the hash-key using (hash-value note) of map
     3219                   do (cond ((eq note source-note) nil)
     3220                            ;; Remove entries with multiple source notes, which can happen
     3221                            ;; for atoms.  If we can't tell which instance we mean, then we
     3222                            ;; don't have useful source info.
     3223                            ((listp note) (remhash form map))
     3224                            ((loop for p = note then (source-note-source p) while (source-note-p p)
     3225                                   thereis (eq p source-note))
     3226                             ;; Flatten the backpointers so each subnote points directly
     3227                             ;; to the toplevel note.
     3228                             (setf (source-note-source note) source-note))))
     3229             (when save-source-text
     3230               (let ((text (make-string (source-note-length source-note)))
     3231                     (pos (file-position stream)))
     3232                 (file-position stream (- (source-note-start-pos source-note) start-offset))
     3233                 (read-sequence text stream)
     3234                 (file-position stream pos)
     3235                 (setf (source-note-source source-note) (%fast-compact text)))))
     3236          (values form source-note))))
    32363237    (T
    32373238     (let* ((start (file-position stream))
  • branches/working-0711/ccl/level-1/l1-readloop-lds.lisp

    r12208 r12236  
    307307  (let* ((*break-level* break-level)
    308308         (*last-break-level* break-level)
    309          *loading-file-source-file*
     309         (*loading-file-source-file* nil)
     310         (*loading-toplevel-location* nil)
    310311         *in-read-loop*
    311312         *** ** * +++ ++ + /// // / -
  • branches/working-0711/ccl/level-1/l1-readloop.lisp

    r12082 r12236  
    620620        (setq decl-specs (nconc decl-specs (list decl-spec)))))))
    621621
     622(defun cheap-eval-macroexpand-1 (form env)
     623  (multiple-value-bind (new win) (macroexpand-1 form env)
     624    (when win
     625      (note-source-transformation form new))
     626    (values new win)))
     627
     628(defun cheap-eval-transform (original new)
     629  (note-source-transformation original new)
     630  new)
     631
     632(defun cheap-eval-function (name lambda env)
     633  (multiple-value-bind (lfun warnings)
     634                       (compile-named-function lambda
     635                                               :name name
     636                                               :env env
     637                                               :function-note *loading-toplevel-location*
     638                                               :keep-lambda *save-definitions*
     639                                               :keep-symbols *save-local-symbols*
     640                                               :source-notes *nx-source-note-map*)
     641    (signal-or-defer-warnings warnings env)
     642    lfun))
     643
     644(fset 'nx-source-note (nlambda bootstrapping-source-note (form) (declare (ignore form)) nil))
     645
    622646(defun cheap-eval-in-environment (form env &aux sym)
    623647  (declare (resident))
     648  ;; records source locations if *nx-source-note-map* is bound by caller
     649  (setq *loading-toplevel-location* (or (nx-source-note form) *loading-toplevel-location*))
    624650  (flet ((progn-in-env (body&decls parse-env base-env)
    625651           (multiple-value-bind (body decls) (parse-body body&decls parse-env)
    626652             (setq base-env (augment-environment base-env :declare (decl-specs-from-declarations decls)))
    627              (while (cdr body)
    628                (cheap-eval-in-environment (pop body) base-env))
     653             (loop with default-location = *loading-toplevel-location*
     654               while (cdr body) as form = (pop body)
     655               do (cheap-eval-in-environment form base-env)
     656               do (setq *loading-toplevel-location* default-location))
    629657             (cheap-eval-in-environment (car body) base-env))))
    630658    (if form
    631659      (cond ((symbolp form)
    632              (multiple-value-bind (expansion win) (macroexpand-1 form env)
     660             (multiple-value-bind (expansion win) (cheap-eval-macroexpand-1 form env)
    633661               (if win
    634                  (cheap-eval-in-environment expansion env) 
     662                 (cheap-eval-in-environment expansion env)
    635663                 (let* ((defenv (definition-environment env))
    636664                        (constant (if defenv (assq form (defenv.constants defenv))))
     
    661689                        (error "~s can't be used to reference lexically defined macro ~S" 'function sym)))
    662690                    (%function (setf-function-name (%cadr sym))))
    663                    (t (%make-function nil sym env))))
     691                   (t (cheap-eval-function nil sym env))))
    664692            ((eq sym 'nfunction)
    665693             (verify-arg-count form 2 2)
    666              (%make-function (%cadr form) (%caddr form) env))
     694             (cheap-eval-function (%cadr form) (%caddr form) env))
    667695            ((eq sym 'progn) (progn-in-env (%cdr form) env env))
    668696            ((eq sym 'setq)
     
    670698               (verify-arg-count form 0 0)) ;Invoke a "Too many args" error.
    671699             (let* ((sym nil)
    672                     (val nil))
     700                    (val nil)
     701                    (original form))
    673702               (while (setq form (%cdr form))
    674703                 (setq sym (require-type (pop form) 'symbol))
    675704                 (multiple-value-bind (expansion expanded)
    676                                       (macroexpand-1 sym env)
     705                                      (cheap-eval-macroexpand-1 sym env)
    677706                   (if expanded
    678                      (setq val (cheap-eval-in-environment `(setf ,expansion ,(%car form)) env))
     707                     (setq val (cheap-eval-in-environment
     708                                (cheap-eval-transform original `(setf ,expansion ,(%car form)))
     709                                env))
    679710                     (set sym (setq val (cheap-eval-in-environment (%car form) env))))))
    680711               val))
     
    684715            ((eq sym 'if)
    685716             (destructuring-bind (test true &optional false) (%cdr form)
    686                (cheap-eval-in-environment (if (cheap-eval-in-environment test env) true false) env)))
     717               (setq test (let ((*loading-toplevel-location* *loading-toplevel-location*))
     718                            (cheap-eval-in-environment test env)))
     719               (cheap-eval-in-environment (if test true false) env)))
    687720            ((eq sym 'locally) (progn-in-env (%cdr form) env env))
    688721            ((eq sym 'symbol-macrolet)
     
    704737               (destructuring-bind (protected-form . cleanup-forms) (cdr form)
    705738                 (unwind-protect
    706                    (cheap-eval-in-environment protected-form env)
     739                     (let ((*loading-toplevel-location* *loading-toplevel-location*))
     740                       (cheap-eval-in-environment protected-form env))
    707741                   (progn-in-env cleanup-forms env env)))
    708                (funcall (%make-function nil `(lambda () (progn ,form)) env))))
     742               (funcall (cheap-eval-function nil (cheap-eval-transform form `(lambda () (progn ,form))) env))))
    709743            ((and (symbolp sym) (macro-function sym env))
    710              (if (eq sym 'step)
    711                (let ((*compile-definitions* nil))
    712                      (cheap-eval-in-environment (macroexpand-1 form env) env))
    713                (cheap-eval-in-environment (macroexpand-1 form env) env)))
     744             (cheap-eval-in-environment (cheap-eval-macroexpand-1 form env) env))
    714745            ((or (symbolp sym)
    715746                 (and (consp sym) (eq (%car sym) 'lambda)))
    716              (let ((args nil))
    717                (dolist (elt (%cdr form)) (push (cheap-eval-in-environment elt env) args))
    718                (apply #'call-check-regs (if (symbolp sym) sym (%make-function nil sym env))
     747             (let ((args nil) (form-location *loading-toplevel-location*))
     748               (dolist (elt (%cdr form))
     749                 (push (cheap-eval-in-environment elt env) args)
     750                 (setq *loading-toplevel-location* form-location))
     751               (apply #'call-check-regs (if (symbolp sym) sym (cheap-eval-function nil sym env))
    719752                      (nreverse args))))
    720753            (t (signal-simple-condition 'simple-program-error "Car of ~S is not a function name or lambda-expression." form))))))
  • branches/working-0711/ccl/level-1/l1-utils.lisp

    r12160 r12236  
    683683        (report-bad-arg form '(satisfies constantp))))))
    684684
    685 ;;; avoid hanging onto beezillions of pathnames
    686 (defvar *last-back-translated-name* nil)
    687685(defvar *lfun-names*)
    688686
  • branches/working-0711/ccl/lib/source-files.lisp

    r12079 r12236  
    699699    name))
    700700
     701;;; avoid hanging onto beezillions of pathnames
     702(defparameter *last-back-translated-name* (cons nil nil))
     703
    701704;; Define the real record-source-file, which will be the last defn handled by the
    702705;; bootstrapping record-source-file, so convert all queued up data right afterwards.
Note: See TracChangeset for help on using the changeset viewer.