Changeset 8421


Ignore:
Timestamp:
Feb 4, 2008, 7:03:04 PM (13 years ago)
Author:
wws
Message:

Marco's source-tracking-0801 branch passes tests on the customer system. Merge it here.

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

Legend:

Unmodified
Added
Removed

  • branches/working-0711/ccl/compiler/PPC/ppc2.lisp

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

  • branches/working-0711/ccl/compiler/X86/x86-disassemble.lisp

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

  • branches/working-0711/ccl/compiler/X86/x862.lisp

    r8019 r8421  
    175175(defvar *x862-record-symbols* nil)
    176176(defvar *x862-recorded-symbols* nil)
     177(defvar *x862-emitted-source-notes* '()
     178  "List of all the :source-location-begin notes we've emitted during this compile.")
     179(defvar *definition-source-note* nil
     180  "Represents the current 'toplevel' source note. Exists mainly so that (progn (defun a ..) (defun b
     181  ..)) can do the 'right' thing.")
    177182
    178183(defvar *x862-result-reg* x8664::arg_z)
    … …  
    427432    0
    428433    (min (- (ash ea (- x8664::word-shift)) count) #xff)))
    429 
    430 
    431434(defun x862-compile (afunc &optional lambda-form *x862-record-symbols*)
    432435  (progn
    … …  
    434437      (unless (afunc-lfun a)
    435438        (x862-compile a
    436                       (if lambda-form
    437                         (afunc-lambdaform a))
     439                      (if lambda-form (afunc-lambdaform a))
    438440                      *x862-record-symbols*))) ; always compile inner guys
    439441    (let* ((*x862-cur-afunc* afunc)
    … …  
    504506           (*x862-vcells* (x862-ensure-binding-indices-for-vcells (afunc-vcells afunc)))
    505507           (*x862-fcells* (afunc-fcells afunc))
    506            *x862-recorded-symbols*)
     508           *x862-recorded-symbols*
     509           (*x862-emitted-source-notes* '()))
    507510      (set-fill-pointer
    508511       *backend-labels*
    … …  
    530533               (with-dll-node-freelist ((frag-list make-frag-list) *frag-freelist*)
    531534                 (with-dll-node-freelist ((uuo-frag-list make-frag-list) *frag-freelist*)
    532                  (let* ((*x86-lap-labels* nil)
    533                         (instruction (x86::make-x86-instruction))
    534                         (end-code-tag (gensym))
    535                         debug-info)
    536                    (make-x86-lap-label end-code-tag)
    537                    (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
    538                                                              *x86-lap-entry-offset*) -3))
    539                    (x86-lap-directive frag-list :byte 0) ;regsave PC
    540                    (x86-lap-directive frag-list :byte 0) ;regsave ea
    541                    (x86-lap-directive frag-list :byte 0) ;regsave mask
    542 
    543                    (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list)
    544                    (when (or *x862-double-float-constant-alist*
    545                              *x862-single-float-constant-alist*)
     535                   (let* ((*x86-lap-labels* nil)
     536                          (instruction (x86::make-x86-instruction))
     537                          (end-code-tag (gensym))
     538                          debug-info)
     539                     (make-x86-lap-label end-code-tag)
     540                     (x86-lap-directive frag-list :long `(ash (+ (- (:^ ,end-code-tag ) 8)
     541                                                                 *x86-lap-entry-offset*)
     542                                                              -3))
     543                     (x86-lap-directive frag-list :byte 0) ;regsave PC
     544                     (x86-lap-directive frag-list :byte 0) ;regsave ea
     545                     (x86-lap-directive frag-list :byte 0) ;regsave mask
     546
     547                     (x862-expand-vinsns vinsns frag-list instruction uuo-frag-list)
     548                     (when (or *x862-double-float-constant-alist*
     549                               *x862-single-float-constant-alist*)
     550                       (x86-lap-directive frag-list :align 3)
     551                       (dolist (double-pair *x862-double-float-constant-alist*)
     552                         (destructuring-bind (dfloat . lab) double-pair
     553                           (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
     554                           (multiple-value-bind (high low)
     555                               (x862-double-float-bits dfloat)
     556                             (x86-lap-directive frag-list :long low)
     557                             (x86-lap-directive frag-list :long high))))
     558                       (dolist (single-pair *x862-single-float-constant-alist*)
     559                         (destructuring-bind (sfloat . lab) single-pair
     560                           (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
     561                           (let* ((val (single-float-bits sfloat)))
     562                             (x86-lap-directive frag-list :long val)))))
    546563                     (x86-lap-directive frag-list :align 3)
    547                      (dolist (double-pair *x862-double-float-constant-alist*)
    548                        (destructuring-bind (dfloat . lab) double-pair
    549                          (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
    550                          (multiple-value-bind (high low)
    551                              (x862-double-float-bits dfloat)
    552                            (x86-lap-directive frag-list :long low)
    553                            (x86-lap-directive frag-list :long high))))
    554                      (dolist (single-pair *x862-single-float-constant-alist*)
    555                        (destructuring-bind (sfloat . lab) single-pair
    556                          (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))
    557                          (let* ((val (single-float-bits sfloat)))
    558                            (x86-lap-directive frag-list :long val)))))
    559                    (x86-lap-directive frag-list :align 3)
    560                    (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
    561                    (emit-x86-lap-label frag-list end-code-tag)
    562                    (dolist (c (reverse *x862-constant-alist*))
    563                      (let* ((vinsn-label (cdr c)))
    564                        (or (vinsn-label-info vinsn-label)
    565                            (setf (vinsn-label-info vinsn-label)
    566                                  (find-or-create-x86-lap-label
    567                                   vinsn-label)))
    568                        (emit-x86-lap-label frag-list vinsn-label)
    569                        (x86-lap-directive frag-list :quad 0)))
     564                     (x86-lap-directive frag-list :quad x8664::function-boundary-marker)
     565                     (emit-x86-lap-label frag-list end-code-tag)
     566                     (dolist (c (reverse *x862-constant-alist*))
     567                       (let* ((vinsn-label (cdr c)))
     568                         (or (vinsn-label-info vinsn-label)
     569                             (setf (vinsn-label-info vinsn-label)
     570                                   (find-or-create-x86-lap-label
     571                                    vinsn-label)))
     572                         (emit-x86-lap-label frag-list vinsn-label)
     573                         (x86-lap-directive frag-list :quad 1)))
    570574                 
    571                    (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
    572                      (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
    573                    (let* ((function-debugging-info (afunc-lfun-info afunc)))
    574                      (when (or function-debugging-info lambda-form *x862-record-symbols*)
    575                        (if lambda-form (setq function-debugging-info
    576                                              (list* 'function-lambda-expression lambda-form function-debugging-info)))
    577                        (if *x862-record-symbols*
    578                          (setq function-debugging-info (nconc (list 'function-symbol-map *x862-recorded-symbols*)
    579                                                               function-debugging-info)))
    580                        (setq bits (logior (ash 1 $lfbits-symmap-bit) bits))
    581                        (setq debug-info function-debugging-info)))
    582                    (unless (or fname lambda-form *x862-recorded-symbols*)
    583                      (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
    584                    (unless (afunc-parent afunc)
    585                      (x862-fixup-fwd-refs afunc))
    586                    (setf (afunc-all-vars afunc) nil)
    587                    (setf (afunc-argsword afunc) bits)
    588                    (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
    589                                            (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
    590                           (regsave-mask (if regsave-label (x862-register-mask-byte
    591                                                            *x862-register-restore-count*)))
    592                           (regsave-addr (if regsave-label (x862-encode-register-save-ea
    593                                                            *x862-register-restore-ea*
    594                                                            *x862-register-restore-count*))))
    595                      (when debug-info
    596                        (x86-lap-directive frag-list :quad 0))
    597                      (when fname
    598                        (x86-lap-directive frag-list :quad 0))
    599                      (x86-lap-directive frag-list :quad 0)
    600                      (relax-frag-list frag-list)
    601                      (apply-relocs frag-list)
    602                      (fill-for-alignment frag-list)
    603                      (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
    604                      (setf (afunc-lfun afunc)
    605                            #+x86-target
    606                            (if (eq *host-backend* *target-backend*)
    607                              (create-x86-function fname frag-list *x862-constant-alist* bits debug-info)
     575                     (if (logbitp $fbitnonnullenv (the fixnum (afunc-bits afunc)))
     576                       (setq bits (+ bits (ash 1 $lfbits-nonnullenv-bit))))
     577                     (unless (afunc-parent afunc)
     578                       (x862-fixup-fwd-refs afunc))
     579                     (setf (afunc-all-vars afunc) nil)
     580                     (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
     581                                             (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
     582                            (regsave-mask (if regsave-label (x862-register-mask-byte
     583                                                             *x862-register-restore-count*)))
     584                            (regsave-addr (if regsave-label (x862-encode-register-save-ea
     585                                                             *x862-register-restore-ea*
     586                                                             *x862-register-restore-count*))))
     587
     588                       
     589                       (when (or (afunc-lfun-info afunc)
     590                                 lambda-form
     591                                 (and *compiler-record-source* *definition-source-note*)
     592                                 *x862-recorded-symbols*
     593                                 (and *compiler-record-source* *x862-emitted-source-notes* *definition-source-note*))
     594                         (x86-lap-directive frag-list :quad 0))
     595                       (when fname
     596                         (x86-lap-directive frag-list :quad 0))
     597                       (x86-lap-directive frag-list :quad 0)
     598                       (relax-frag-list frag-list)
     599                       (apply-relocs frag-list)
     600                       (fill-for-alignment frag-list)
     601                       (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
     602                       (setf debug-info
     603                             (nconc (copy-list (afunc-lfun-info afunc))
     604                                    (when lambda-form
     605                                      (list 'function-debugging-info lambda-form))
     606                                    (when (and *compiler-record-source* *definition-source-note*)
     607                                      (list 'function-source-note
     608                                            (source-note-to-list *definition-source-note* :form nil :children nil)))
     609                                    (when *x862-recorded-symbols*
     610                                      (list 'function-symbol-map *x862-recorded-symbols*))
     611                                    (when (and *compiler-record-source*
     612                                               *x862-emitted-source-notes*
     613                                               *definition-source-note*)
     614                                      (list 'pc-source-map
     615                                            (x862-generate-pc-source-map *definition-source-note*
     616                                                                         *x862-emitted-source-notes*)))))
     617                       (when debug-info
     618                         (setq bits (logior (ash 1 $lfbits-info-bit) bits)))
     619                       (unless (or fname lambda-form *x862-recorded-symbols*)
     620                         (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
     621                       (setf (afunc-argsword afunc) bits)
     622                       (setf (afunc-lfun afunc)
     623                             #+x86-target
     624                             (if (eq *host-backend* *target-backend*)
     625                               (create-x86-function       fname frag-list *x862-constant-alist* bits debug-info)
     626                               (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
     627                             #-x86-target
    608628                             (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
    609                            #-x86-target
    610                            (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))
    611                    (x862-digest-symbols)))))
     629                       (x862-digest-symbols))))))
    612630          (backend-remove-labels))))
    613631    afunc))
    614 
    615 
    616      
    617632   
    618633(defun x862-make-stack (size &optional (subtype target::subtag-s16-vector))
    … …  
    644659                (setf (%svref v i) ref-fun)))))))))
    645660
     661(defun x862-generate-pc-source-map (definition-source-note emitted-source-notes)
     662  (when *compiler-record-source*
     663    (let ((def-start (source-note-start definition-source-note)))
     664      (mapcar (lambda (start)
     665                (list :pc-range (cons (x862-vinsn-note-label-address
     666                                       start
     667                                       t)
     668                                      (x862-vinsn-note-label-address
     669                                       (vinsn-note-peer start)
     670                                       nil))
     671                      :source-text-range (cons (- (source-note-start (aref (vinsn-note-info start) 0))
     672                                                  def-start)
     673                                               (- (source-note-end (aref (vinsn-note-info start) 0))
     674                                                  def-start))))
     675              emitted-source-notes))))
     676
     677(defun x862-vinsn-note-label-address (note &optional start-p sym)
     678  (-
     679   (let* ((label (vinsn-note-label note))
     680          (lap-label (if label (vinsn-label-info label))))
     681     (if lap-label
     682         (x86-lap-label-address lap-label)
     683         (compiler-bug "Missing or bad ~s label~@[: ~s~]"
     684                       (if start-p 'start 'end)
     685                       sym)))
     686   x8664::fulltag-function))
     687
    646688(defun x862-digest-symbols ()
    647689  (if *x862-recorded-symbols*
    648     (let* ((symlist *x862-recorded-symbols*)
    649            (len (length symlist))
    650            (syms (make-array len))
    651            (ptrs (make-array (%i+  (%i+ len len) len)))
    652            (i -1)
    653            (j -1))
    654       (declare (fixnum i j))
    655       (dolist (info symlist (progn (%rplaca symlist syms)
    656                                    (%rplacd symlist ptrs)))
    657         (flet ((label-address (note start-p sym)
    658                  (-
    659                   (let* ((label (vinsn-note-label note))
    660                          (lap-label (if label (vinsn-label-info label))))
    661                     (if lap-label
    662                       (x86-lap-label-address lap-label)
    663                       (compiler-bug "Missing or bad ~s label: ~s"
    664                                     (if start-p 'start 'end) sym)))
    665                   x8664::fulltag-function)))
     690      (let* ((symlist *x862-recorded-symbols*)
     691             (len (length symlist))
     692             (syms (make-array len))
     693             (ptrs (make-array (%i+  (%i+ len len) len)))
     694             (i -1)
     695             (j -1))
     696        (declare (fixnum i j))
     697        (dolist (info symlist (progn (%rplaca symlist syms)
     698                                     (%rplacd symlist ptrs)))
    666699          (destructuring-bind (var sym startlab endlab) info
    667700            (let* ((ea (var-ea var))
    668701                   (ea-val (ldb (byte 16 0) ea)))
    669702              (setf (aref ptrs (incf i)) (if (memory-spec-p ea)
    670                                            (logior (ash ea-val 6) #o77)
    671                                            ea-val)))
     703                                             (logior (ash ea-val 6) #o77)
     704                                             ea-val)))
    672705            (setf (aref syms (incf j)) sym)
    673             (setf (aref ptrs (incf i)) (label-address startlab t sym))
    674             (setf (aref ptrs (incf i)) (label-address endlab nil sym))))))))
     706            (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address startlab t sym))
     707            (setf (aref ptrs (incf i)) (x862-vinsn-note-label-address endlab nil sym))))
     708        *x862-recorded-symbols*)))
    675709
    676710(defun x862-decls (decls)
    … …  
    10881122    n))
    10891123
     1124(defun x862-emit-source-note (seg class nx1-form)
     1125  (check-type class (member :source-location-begin :source-location-end))
     1126  (when (nx1-source-note nx1-form)
     1127    (x862-emit-note seg class (nx1-source-note nx1-form))))
     1128
     1129(defmacro x862-wrap-in-source-notes ((seg form) &body body)
     1130  (let ((x862-wrap-in-source-notes-body (gensym "X862-WRAP-IN-SOURCE-NOTES-BODY-")))
     1131    `(flet ((,x862-wrap-in-source-notes-body () ,@body))
     1132       (call-with-x862-wrap-in-source-notes ,seg ,form #',x862-wrap-in-source-notes-body))))
     1133
     1134(defun call-with-x862-wrap-in-source-notes (seg form thunk)
     1135  (let (start end)
     1136    (setf start (x862-emit-source-note seg :source-location-begin form))
     1137    (multiple-value-prog1
     1138        (funcall thunk)
     1139      (setf end (x862-emit-source-note seg :source-location-end form))
     1140      (when (and start end)
     1141        (setf (vinsn-note-peer start) end
     1142              (vinsn-note-peer end) start
     1143              *x862-emitted-source-notes* (cons start *x862-emitted-source-notes*))))))
    10901144
    10911145(defun x862-form (seg vreg xfer form)
    1092   (if (nx-null form)
    1093     (x862-nil seg vreg xfer)
    1094     (if (nx-t form)
    1095       (x862-t seg vreg xfer)
    1096       (let* ((op nil)
    1097              (fn nil))
    1098         (if (and (consp form)
    1099                  (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    1100           (if (and (null vreg)
    1101                    (%ilogbitp operator-acode-subforms-bit op)
    1102                    (%ilogbitp operator-assignment-free-bit op))
    1103             (dolist (f (%cdr form) (x862-branch seg xfer))
    1104               (x862-form seg nil nil f ))
    1105             (apply fn seg vreg xfer (%cdr form)))
    1106           (compiler-bug "x862-form ? ~s" form))))))
     1146  (x862-wrap-in-source-notes (seg form)
     1147     (if (nx-null form)
     1148         (x862-nil seg vreg xfer)
     1149         (if (nx-t form)
     1150             (x862-t seg vreg xfer)
     1151             (let* ((op nil)
     1152                    (fn nil))
     1153               (if (and (consp form)
     1154                        (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
     1155                   (if (and (null vreg)
     1156                            (%ilogbitp operator-acode-subforms-bit op)
     1157                            (%ilogbitp operator-assignment-free-bit op))
     1158                       (dolist (f (%cdr form) (x862-branch seg xfer))
     1159                         (x862-form seg nil nil f ))
     1160                       (apply fn seg vreg xfer (%cdr form)))
     1161                   (compiler-bug "x862-form ? ~s" form)))))))
    11071162
    11081163;;; dest is a float reg - form is acode
    … …  
    50795134  (let* ((lab (vinsn-note-label note)))
    50805135    (case (vinsn-note-class note)
    5081       ((:regsave :begin-variable-scope :end-variable-scope)
     5136      ((:regsave :begin-variable-scope :end-variable-scope
     5137        :source-location-begin :source-location-end)
    50825138       (setf (vinsn-label-info lab) (emit-x86-lap-label frag-list lab))))))
    50835139
    … …  
    91079163                         *target-ftd*)))
    91089164    (multiple-value-bind (xlfun warnings)
    9109         (compile-named-function def nil
    9110                                 nil
    9111                                 nil
    9112                                 nil
    9113                                 nil
    9114                                 nil
    9115                                 target)
     9165        (compile-named-function def :target target)
    91169166      (signal-or-defer-warnings warnings nil)
    91179167      (when disassemble

  • branches/working-0711/ccl/compiler/lambda-list.lisp

    r4020 r8421  
    2121;;; Compiler functions needed elsewhere
    2222
    23 ;;; used-by: backtrace, arglist
    24 (defun function-symbol-map (fn)
    25   (getf (%lfun-info fn) 'function-symbol-map))
    26 
    2723(defun %lfun-info-index (fn)
    2824  (and (compiled-function-p fn)
    2925       (let ((bits (lfun-bits fn)))
    3026         (declare (fixnum bits))
    31          (and (logbitp $lfbits-symmap-bit bits)
     27         (and (logbitp $lfbits-info-bit bits)
    3228               (%i- (uvsize (function-to-function-vector fn))
    3329                              (if (logbitp $lfbits-noname-bit bits) 2 3))))))
    … …  
    3935  (getf (%lfun-info fn) 'function-lambda-expression ))
    4036
     37;;; used-by: backtrace, arglist
     38(defun function-symbol-map (fn)
     39  (getf (%lfun-info fn) 'function-symbol-map))
     40
     41(defun function-source-text (fn)
     42  (getf (%lfun-info fn) 'text))
     43
     44(defun show-function-constants (f)
     45  (dotimes (i (- (uvsize (function-to-function-vector f))
     46                 (%function-code-words f)))
     47    (format t "~&~d: ~s" i (nth-immediate f (1+ i)))))
     48
     49(defun show-uvector-contents (uvector)
     50  (dotimes (i (uvsize uvector))
     51    (format t "~&~D: ~S" i (uvref uvector i))))
    4152
    4253;;; Lambda-list utilities

  • branches/working-0711/ccl/compiler/nx.lisp

    r7719 r8421  
    8888                       (if (functionp def)
    8989                         def
    90                          (compile-named-function def spec nil *save-definitions* *save-local-symbols*))
     90                         (compile-named-function def
     91                                                 :name spec
     92                                                 :keep-lambda *save-definitions*
     93                                                 :keep-symbols *save-local-symbols*))
    9194    (let ((harsh nil) (some nil) (init t))
    9295      (dolist (w warnings)
    … …  
    121124         (*target-backend* (or backend *target-backend*)))
    122125    (multiple-value-bind (xlfun warnings)
    123         (compile-named-function def nil
    124                                 nil
    125                                 nil
    126                                 nil
    127                                 nil
    128                                 nil
    129                                 target)
     126        (compile-named-function def :target target)
    130127      (signal-or-defer-warnings warnings nil)
    131128      (ppc-xdisassemble xlfun :target target)
    132129      xlfun)))
    133  
    134 (defun compile-user-function (def name &optional env)
    135   (multiple-value-bind (lfun warnings)
    136                        (compile-named-function def name
    137                                                env
    138                                                *save-definitions*
    139                                                *save-local-symbols*)
    140     (signal-or-defer-warnings warnings env)
    141     lfun))
    142130
    143131(defun signal-or-defer-warnings (warnings env)
    … …  
    154142(defparameter *load-time-eval-token* nil)
    155143
    156 
    157 
    158 
    159144(eval-when (:compile-toplevel)
    160145  (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
    … …  
    163148
    164149(defun compile-named-function
    165     (def &optional name env keep-lambda keep-symbols policy *load-time-eval-token* target)
     150    (definition &key name env keep-lambda keep-symbols policy load-time-eval-token target)
    166151  (when (and name *nx-discard-xref-info-hook*)
    167152    (funcall *nx-discard-xref-info-hook* name))
    168153  (setq
    169    def
    170    (let ((env (new-lexical-environment env)))
     154   definition
     155   (let ((*load-time-eval-token* load-time-eval-token)
     156         (env (new-lexical-environment env)))
    171157     (setf (lexenv.variables env) 'barrier)
    172158       (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
    173159              (afunc (nx1-compile-lambda
    174160                      name
    175                       def
     161                      definition
    176162                      (make-afunc)
    177163                      nil
    … …  
    180166                      *load-time-eval-token*)))
    181167         (if (afunc-lfun afunc)
    182            afunc
    183            (funcall (backend-p2-compile *target-backend*)
    184             afunc
    185             ; will also bind *nx-lexical-environment*
    186             (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
    187             keep-symbols)))))
    188   (values (afunc-lfun def) (afunc-warnings def)))
    189 
    190 
     168             afunc
     169             (funcall (backend-p2-compile *target-backend*)
     170                      afunc
     171                      ;; will also bind *nx-lexical-environment*
     172                      (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda definition))
     173                      keep-symbols)))))
     174  (values (afunc-lfun definition) (afunc-warnings definition)))
    191175 
    192 
    193 
    194 
     176(defun compile-user-function (def name &optional env)
     177  (multiple-value-bind (lfun warnings)
     178      (compile-named-function def
     179                              :name name
     180                              :env env
     181                              :keep-lambda *save-definitions*
     182                              :keep-symbols *save-local-symbols*)
     183    (signal-or-defer-warnings warnings env)
     184    lfun))
    195185
    196186(defparameter *compiler-whining-conditions*
    … …  
    213203(provide 'nx)
    214204
     205(defun define-compile-time-macro (name lambda-expression env)
     206  (let ((definition-env (definition-environment env)))
     207    (if definition-env
     208      (push (list* name
     209                   'macro
     210                   (compile-named-function lambda-expression :name name :env env))
     211            (defenv.functions definition-env)))
     212    name))
     213
     214(defun fcomp-named-function (def name env)
     215  (let* ((env (new-lexical-environment env)))
     216    (multiple-value-bind (lfun warnings)
     217                         (compile-named-function def
     218                                                 :name name
     219                                                 :env env
     220                                                 :keep-lambda *fasl-save-definitions*
     221                                                 :keep-symbols *fasl-save-local-symbols*
     222                                                 :policy *default-file-compilation-policy*
     223                                                 :load-time-eval-token cfasl-load-time-eval-sym
     224                                                 :target *fasl-target*)
     225      (fcomp-signal-or-defer-warnings warnings env)
     226      lfun)))

  • branches/working-0711/ccl/compiler/nx0.lisp

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

  • branches/working-0711/ccl/compiler/nx1.lisp

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

  • branches/working-0711/ccl/compiler/nxenv.lisp

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

  • branches/working-0711/ccl/level-1/l1-clos-boot.lisp

    r7945 r8421  
    835835  (%add-standard-method-to-standard-gf gf method))
    836836
     837;; Redefined in l1-clos.lisp
     838(defun maybe-remove-make-instance-optimization (gfn method)
     839  (declare (ignore gfn method))
     840  nil)
     841
    837842(defun %add-standard-method-to-standard-gf (gfn method)
    838843  (when (%method-gf method)
    … …  
    844849         (qualifiers (%method-qualifiers method)))
    845850    (remove-obsoleted-combined-methods method dt specializers)
     851    (maybe-remove-make-instance-optimization gfn method)
    846852    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
    847853    (dolist (m methods)
    … …  
    962968   (when dt
    963969     (if specializers
    964        (let* ((argnum (%gf-dispatch-table-argnum dt))
    965               (class (nth argnum specializers))
    966               (size (%gf-dispatch-table-size dt))
    967               (index 0))
    968          (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
    969          (if (typep class 'eql-specializer)
    970            (setq class (class-of (eql-specializer-object class))))
    971          (while (%i< index size)
    972            (let* ((wrapper (%gf-dispatch-table-ref dt index))
    973                   hash-index-0?
    974                   (cpl (and wrapper
    975                             (not (setq hash-index-0?
    976                                        (eql 0 (%wrapper-hash-index wrapper))))
    977                             (%inited-class-cpl
    978                              (require-type (%wrapper-class wrapper) 'class)))))
    979              (when (or hash-index-0? (and cpl (cpl-index class cpl)))
    980                (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
    981                      (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
    982              (setq index (%i+ index 2)))))
     970       (let* ((argnum (%gf-dispatch-table-argnum dt)))
     971         (when (>= argnum 0)
     972           (let ((class (nth argnum specializers))
     973                 (size (%gf-dispatch-table-size dt))
     974                 (index 0))
     975             (clear-accessor-method-offsets (%gf-dispatch-table-gf dt) method)
     976             (if (typep class 'eql-specializer)
     977                 (setq class (class-of (eql-specializer-object class))))
     978             (while (%i< index size)
     979               (let* ((wrapper (%gf-dispatch-table-ref dt index))
     980                      hash-index-0?
     981                      (cpl (and wrapper
     982                                (not (setq hash-index-0?
     983                                           (eql 0 (%wrapper-hash-index wrapper))))
     984                                (%inited-class-cpl
     985                                 (require-type (%wrapper-class wrapper) 'class)))))
     986                 (when (or hash-index-0? (and cpl (cpl-index class cpl)))
     987                   (setf (%gf-dispatch-table-ref dt index) *obsolete-wrapper*
     988                         (%gf-dispatch-table-ref dt (%i+ index 1)) *gf-dispatch-bug*))
     989                 (setq index (%i+ index 2)))))))
    983990       (setf (%gf-dispatch-table-ref dt 1) nil)))))   ; clear 0-arg gf cm
    984991

  • branches/working-0711/ccl/level-1/l1-clos.lisp

    r8056 r8421  
    19101910              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
    19111911                (clear-gf-dispatch-table dt)
     1912                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
    19121913                (cond ((null (cdr alist))
    19131914                       ;; Method is only applicable to a single class.
    … …  
    22442245           %find-classes%))
    22452246
     2247;; Redefined from bootstrapping verison in l1-clos-boot.lisp
     2248;; Remove the make-instance optimization if the user is adding
     2249;; a method on initialize-instance, allocate-instance, or shared-initialize
     2250(defun maybe-remove-make-instance-optimization (gfn method)
     2251  (when (or (eq gfn #'allocate-instance)
     2252            (eq gfn #'initialize-instance)
     2253            (eq gfn #'shared-initialize))
     2254    (let* ((specializer (car (method-specializers method)))
     2255           (cell (and (typep specializer 'class)
     2256                      (gethash (class-name specializer) %find-classes%))))
     2257      (when cell
     2258        (setf (class-cell-instantiate cell) '%make-instance)))))           
     2259
    22462260;;; Iterate over all known GFs; try to optimize their dcode in cases
    22472261;;; involving reader methods.

  • branches/working-0711/ccl/level-1/l1-files.lisp

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

  • branches/working-0711/ccl/level-1/l1-init.lisp

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

  • branches/working-0711/ccl/level-1/l1-reader.lisp

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

  • branches/working-0711/ccl/level-1/l1-utils.lisp

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

  • branches/working-0711/ccl/lib/arglist.lisp

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

  • branches/working-0711/ccl/lib/backquote.lisp

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

  • branches/working-0711/ccl/lib/db-io.lisp

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

  • branches/working-0711/ccl/lib/defstruct-lds.lisp

    r2325 r8421  
    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/working-0711/ccl/lib/defstruct.lisp

    r5434 r8421  
    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/working-0711/ccl/lib/encapsulate.lisp

    r6499 r8421  
    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/working-0711/ccl/lib/misc.lisp

    r7954 r8421  
    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/working-0711/ccl/lib/nfcomp.lisp

    r8042 r8421  
    101101                   pathname))
    102102
    103 (defun compile-file (src &key output-file
    104                          (verbose *compile-verbose*)
    105                          (print *compile-print*)
    106                          load
    107                          features
    108                          (target *fasl-target* target-p)
    109                          (save-local-symbols *fasl-save-local-symbols*)
    110                          (save-doc-strings *fasl-save-doc-strings*)
    111                          (save-definitions *fasl-save-definitions*)
    112                          (external-format :default)
    113                          force)
    114   "Compile INPUT-FILE, producing a corresponding fasl file and returning
    115    its filename."
    116   (let* ((backend *target-backend*))
    117     (when (and target-p (not (setq backend (find-backend target))))
    118       (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
    119       (setq target *fasl-target*  backend *target-backend*))
    120     (loop
    121         (restart-case
    122          (return (%compile-file src output-file verbose print load features
    123                                 save-local-symbols save-doc-strings save-definitions force backend external-format))
    124          (retry-compile-file ()
    125                              :report (lambda (stream) (format stream "Retry compiling ~s" src))
    126                              nil)
    127          (skip-compile-file ()
    128                             :report (lambda (stream) (format stream "Skip compiling ~s" src))
    129                             (return))))))
    130 
    131 
    132103(defun %compile-file (src output-file verbose print load features
    133104                          save-local-symbols save-doc-strings save-definitions force target-backend external-format
     105                          compile-file-original-truename compile-file-original-buffer-offset
    134106                          &aux orig-src)
    135 
    136107  (setq orig-src (merge-pathnames src))
    137108  (let* ((output-default-type (backend-target-fasl-pathname target-backend)))
    … …  
    169140             (*compile-file-pathname* orig-src)
    170141             (*compile-file-truename* (truename src))
     142             (*compile-file-original-truename* compile-file-original-truename)
     143             (*compile-file-original-buffer-offset* compile-file-original-buffer-offset)
    171144             (*package* *package*)
    172145             (*readtable* *readtable*)
    … …  
    199172              *fasl-non-style-warnings-signalled-p*))))
    200173
     174(defun compile-file (src &key output-file
     175                         (verbose *compile-verbose*)
     176                         (print *compile-print*)
     177                         load
     178                         features
     179                         (target *fasl-target* target-p)
     180                         (save-local-symbols *fasl-save-local-symbols*)
     181                         (save-doc-strings *fasl-save-doc-strings*)
     182                         (save-definitions *fasl-save-definitions*)
     183                         (external-format :default)
     184                         force
     185                         compile-file-original-truename
     186                         (compile-file-original-buffer-offset 0))
     187  "Compile INPUT-FILE, producing a corresponding fasl file and returning
     188   its filename."
     189  (let* ((backend *target-backend*))
     190    (when (and target-p (not (setq backend (find-backend target))))
     191      (warn "Unknown :TARGET : ~S.  Reverting to ~s ..." target *fasl-target*)
     192      (setq target *fasl-target*  backend *target-backend*))
     193    (loop
     194        (restart-case
     195         (return (%compile-file src output-file verbose print load features
     196                                save-local-symbols save-doc-strings save-definitions force backend external-format
     197                                compile-file-original-truename compile-file-original-buffer-offset))
     198         (retry-compile-file ()
     199                             :report (lambda (stream) (format stream "Retry compiling ~s" src))
     200                             nil)
     201         (skip-compile-file ()
     202                            :report (lambda (stream) (format stream "Skip compiling ~s" src))
     203                            (return))))))
     204
    201205(defvar *fcomp-locked-hash-tables*)
    202206(defvar *fcomp-load-forms-environment* nil)
    … …  
    246250                              (signal c))))
    247251      (funcall (compile-named-function
    248                 `(lambda () ,form) nil env nil nil
    249                 *compile-time-evaluation-policy*)))))
     252                `(lambda () ,form)
     253                :env env
     254                :policy *compile-time-evaluation-policy*)))))
    250255
    251256
    … …  
    281286;;;;          Produces a list of (opcode . args) to run on loading, intermixed
    282287;;;;          with read packages.
    283 
    284 (defparameter *fasl-eof-forms* nil)
    285288
    286289(defparameter cfasl-load-time-eval-sym (make-symbol "LOAD-TIME-EVAL"))
    … …  
    382385            (if (eq filename *compiling-file*) "Compiling" " Including")
    383386            filename))
    384   (with-open-file (stream filename
    385                           :element-type 'base-char
    386                           :external-format *fcomp-external-format*)
     387  (with-open-file (*fcomp-stream* filename
     388                                  :element-type 'base-char
     389                                  :external-format *fcomp-external-format*)
    387390    (let* ((old-file (and (neq filename *compiling-file*) *fasl-source-file*))           
    388391           (*fasl-source-file* filename)
    389            (*fcomp-toplevel-forms* nil)
    390            (*fasl-eof-forms* nil)
     392           (*fcomp-toplevel-forms* '())
    391393           (*loading-file-source-file* (namestring orig-file)) ; why orig-file???
    392394           (eofval (cons nil nil))
    393395           (read-package nil)
    394            form)
    395       (declare (special *fasl-eof-forms* *fcomp-toplevel-forms* *fasl-source-file*))
     396           *form-source-note-map*
     397           (*nx1-source-note-map* (make-hash-table)))
     398      (declare (special *fcomp-toplevel-forms* *fasl-source-file*))
    396399      ;;This should really be something like `(set-loading-source
    397400      ;;,filename) but then couldn't compile level-1 with this...  ->
    … …  
    403406      (let* ((*fcomp-previous-position* nil))
    404407        (loop
    405           (let* ((*fcomp-stream-position* (file-position stream)))
     408          (let* ((*fcomp-stream-position* (file-position *fcomp-stream*))
     409                 (*definition-source-note* *definition-source-note*)
     410                 form)
    406411            (unless (eq read-package *package*)
    407412              (fcomp-compile-toplevel-forms env)
    … …  
    410415                   (and *fcomp-load-time* cfasl-load-time-eval-sym)))
    411416              (declare (special *reading-for-cfasl*))
    412               (let ((pos (file-position stream)))
     417              (let ((pos (file-position *fcomp-stream*)))
    413418                (handler-bind
    414419                    ((error #'(lambda (c) ; we should distinguish read errors from others?
    415                                 (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position stream) filename)
     420                                (format *error-output* "~&Read error between positions ~a and ~a in ~a." pos (file-position *fcomp-stream*) filename)
    416421                                (signal c))))
    417                   (setq form (read stream nil eofval)))))
    418             (when (eq eofval form) (return))
     422                  (multiple-value-bind (-form source-note)
     423                      (read-internal *fcomp-stream* nil eofval nil)
     424                    (when (eq -form eofval)
     425                      (return))
     426                    (setf form -form
     427                          *definition-source-note* source-note
     428                          *form-source-note-map* (make-source-note-form-map source-note
     429                                                                            *form-source-note-map*))))))
    419430            (fcomp-form form env processing-mode)
    420431            (setq *fcomp-previous-position* *fcomp-stream-position*))))
    421       (while (setq form *fasl-eof-forms*)
    422         (setq *fasl-eof-forms* nil)
    423         (fcomp-form-list form env processing-mode))
    424432      (when old-file
    425433        (fcomp-output-form $fasl-src env (namestring *compile-file-pathname*)))
    426434      (fcomp-compile-toplevel-forms env))))
    427 
    428 
    429435
    430436(defun fcomp-form (form env processing-mode
    … …  
    468474                             "")))))))
    469475    (fcomp-form-1 form env processing-mode)))
    470            
     476
     477(defun record-form-source-equivalent/list (form list)
     478  (dolist (f list)
     479    (record-form-source-equivalent form f)))
     480
    471481(defun fcomp-form-1 (form env processing-mode &aux sym body)
    472482  (if (consp form) (setq sym (%car form) body (%cdr form)))
    473483  (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))
     484    (progn
     485      (record-form-source-equivalent/list form body)
     486      (fcomp-form-list body env processing-mode))
     487    (eval-when
     488      (record-form-source-equivalent/list form body)
     489      (fcomp-eval-when body env processing-mode))
     490    (compiler-let
     491      (record-form-source-equivalent/list form body)
     492      (fcomp-compiler-let body env processing-mode))
     493    (locally
     494      (record-form-source-equivalent/list form body)
     495      (fcomp-locally body env processing-mode))
     496    (macrolet
     497      (record-form-source-equivalent/list form body)
     498      (fcomp-macrolet body env processing-mode))
     499    ;; special case for passing around source-location info
     500    (%source-note (fcomp-form (list 'quote (source-note-to-list *definition-source-note*))
     501                              env processing-mode))
    479502    ((%include include) (fcomp-include form env processing-mode))
    480503    (t
    … …  
    488511             (not (compiler-macro-function sym env))
    489512             (not (eq sym '%defvar-init)) ;  a macro that we want to special-case
    490              (multiple-value-bind (new win) (macroexpand-1 form env)
    491                (if win (setq form new))
     513             (multiple-value-bind (new win)
     514                 (macroexpand-1 form env)
     515               (if win
     516                   (progn
     517                    (record-form-source-equivalent form new)
     518                    (setf form new)))
    492519               win))
    493520        (fcomp-form form env processing-mode))
    494521       ((and (not *fcomp-inside-eval-always*)
    495522             (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)))
     523        (let* ((*fcomp-inside-eval-always* t)
     524               (new `(eval-when (:execute :compile-toplevel :load-toplevel) ,form)))
     525          (record-form-source-equivalent form new)
     526          (fcomp-form-1 new env processing-mode)))
    498527       (t
    499528        (when (or (eq processing-mode :compile-time) (eq processing-mode :compile-time-too))
    … …  
    504533            ((%defparameter) (fcomp-load-%defparameter form env))
    505534            ((%defvar %defvar-init) (fcomp-load-defvar form env))
    506             ((%defun) (fcomp-load-%defun form env))
     535            ((%defun)
     536               (let ((*definition-source-note* (gethash form *form-source-note-map*)))
     537                 (fcomp-load-%defun form env)))
    507538            ((set-package %define-package)
    508539             (fcomp-random-toplevel-form form env)
    … …  
    514545
    515546(defun fcomp-form-list (forms env processing-mode)
    516   (dolist (form forms) (fcomp-form form env processing-mode)))
     547  (dolist (form forms)
     548    (fcomp-form form env processing-mode)))
    517549
    518550(defun fcomp-compiler-let (form env processing-mode &aux vars varinits)
    … …  
    522554    (push (%compile-time-eval (nx-pair-initform pair) env) varinits))
    523555  (progv (nreverse vars) (nreverse varinits)
    524                  (fcomp-form-list form env processing-mode)
    525                  (fcomp-compile-toplevel-forms env)))
     556    (fcomp-form-list form env processing-mode)
     557    (fcomp-compile-toplevel-forms env)))
    526558
    527559(defun fcomp-locally (body env processing-mode)
    … …  
    654686      (push (list* name
    655687                   'macro
    656                    (compile-named-function lambda-expression name env))
     688                   (compile-named-function lambda-expression :name name :env env))
    657689            (defenv.functions definition-env)))
    658690    name))
    … …  
    729761          (setf (car (cadr doc)) nil))
    730762        (setq doc nil)))
     763    (record-form-source-equivalent form fn)
    731764    (if (and (constantp doc)
    732765             (setq fn (fcomp-function-arg fn env)))
    … …  
    738771(defun fcomp-load-%macro (form env &aux fn doc)
    739772  (verify-arg-count form 1 2)
     773  (record-form-source-equivalent form (cadr form))
    740774  (if (and (constantp (setq doc (caddr form)))
    741775           (setq fn (fcomp-function-arg (cadr form) env)))
    … …  
    777811      (let (lfun (args (%cdr form)))
    778812        (while args
     813          (record-form-source-equivalent form (first args))
    779814          (multiple-value-bind (arg win) (fcomp-transform (%car args) env)
    780815            (when (or (setq lfun (fcomp-function-arg arg env))
    … …  
    790825(defun fcomp-function-arg (expr env)
    791826  (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)))))
     827    (cond
     828      ((and (eq (%car expr) 'nfunction)
     829            (symbolp (%cadr expr))
     830            (lambda-expression-p (%caddr expr)))
     831       (record-form-source-equivalent expr (%caddr expr))
     832       (fcomp-named-function (%caddr expr) (%cadr expr) env))
     833      ((and (eq (%car expr) 'function)
     834            (lambda-expression-p (%cadr expr)))
     835       (record-form-source-equivalent expr (%cadr expr))
     836       (fcomp-named-function (%cadr expr) nil env)))))
    799837
    800838(defun fcomp-compile-toplevel-forms (env)
    … …  
    809847                                     (compiler-function-overflow)))
    810848                          ,@forms)))))
    811       (setq *fcomp-toplevel-forms* nil)
     849      (record-form-source-equivalent/list lambda forms)
     850      (setq *fcomp-toplevel-forms* '())
    812851      ;(format t "~& Random toplevel form: ~s" lambda)
    813852      (handler-case (fcomp-output-form
    … …  
    838877  (let* ((env (new-lexical-environment env)))
    839878    (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*)
     879        (compile-named-function def
     880                                :name name
     881                                :env env
     882                                :keep-lambda *fasl-save-definitions*
     883                                :keep-symbols *fasl-save-local-symbols*
     884                                :policy *default-file-compilation-policy*
     885                                :load-time-eval-token cfasl-load-time-eval-sym
     886                                :target *fasl-target*)
    848887      (fcomp-signal-or-defer-warnings warnings env)
    849888      lfun)))

  • branches/working-0711/ccl/lib/read.lisp

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

  • branches/working-0711/ccl/lib/source-files.lisp

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

  • branches/working-0711/ccl/library/lispequ.lisp

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