Changeset 11279


Ignore:
Timestamp:
Oct 31, 2008, 1:52:57 PM (11 years ago)
Author:
gz
Message:

Backport compiler source location changes from trunk, mostly reorg and move file-compiler stuff out of the compiler, but also a fix to record a source note for inner functions

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

Legend:

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

    r11089 r11279  
    204204(defvar *x862-emitted-source-notes* '()
    205205  "List of all the :source-location-begin notes we've emitted during this compile.")
    206 (defvar *definition-source-note* nil
    207   "Represents the current 'toplevel' source note. Exists mainly so that (progn (defun a ..) (defun b
    208   ..)) can do the 'right' thing.")
    209206
    210207(defvar *x862-result-reg* x8664::arg_z)
     
    633630                        (start-tag (gensym))
    634631                        (srt-tag (gensym))
    635                         debug-info
    636                         debug-info-p)
     632                        debug-info)
    637633                   (make-x86-lap-label end-code-tag)
    638634                   (target-arch-case
     
    700696                   (when (logbitp $fbitccoverage (the fixnum (afunc-bits afunc)))
    701697                     (setq bits (+ bits (ash 1 $lfbits-code-coverage-bit))))
     698                   (setq debug-info (afunc-lfun-info afunc))
     699                   (when lambda-form
     700                     (setq debug-info
     701                           (list* 'function-lambda-expression lambda-form debug-info)))
     702                   (when *x862-record-symbols*
     703                     (setq debug-info
     704                           (list* 'function-symbol-map *x862-recorded-symbols* debug-info)))
     705                   (when (and (getf debug-info 'function-source-note) *x862-emitted-source-notes*)
     706                     (setq debug-info                     ;; Compressed below
     707                           (list* 'pc-source-map *x862-emitted-source-notes* debug-info)))
     708                   (when debug-info
     709                     (setq bits (logior (ash 1 $lfbits-info-bit) bits)))
     710                   (unless (or fname lambda-form *x862-recorded-symbols*)
     711                     (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
    702712                   (unless (afunc-parent afunc)
    703713                     (x862-fixup-fwd-refs afunc))
    704714                   (setf (afunc-all-vars afunc) nil)
     715                   (setf (afunc-argsword afunc) bits)
    705716                   (let* ((regsave-label (if (typep *x862-compiler-register-save-label* 'vinsn-note)
    706717                                           (vinsn-label-info (vinsn-note-label *x862-compiler-register-save-label*))))
     
    710721                                                           *x862-register-restore-ea*
    711722                                                           *x862-register-restore-count*))))
    712 
    713                      (when (or (afunc-lfun-info afunc)
    714                                lambda-form
    715                                *x862-recorded-symbols*
    716                                (and *fasl-save-source-locations*
    717                                     *x862-emitted-source-notes*
    718                                     *definition-source-note*))
    719                        (target-arch-case
    720                         (:x8632
    721                          (x86-lap-directive frag-list :long 0))
    722                         (:x8664
    723                          (x86-lap-directive frag-list :quad 0)))
    724                        (setf debug-info-p t))
    725                      (target-arch-case
    726                       (:x8632
    727                        (when fname
    728                          (x86-lap-directive frag-list :long 0))
    729                        (x86-lap-directive frag-list :long 0))
    730                       (:x8664
    731                        (when fname
    732                          (x86-lap-directive frag-list :quad 0))
    733                        (x86-lap-directive frag-list :quad 0)))
     723                     (target-arch-case
     724                      (:x8632
     725                       (when debug-info
     726                         (x86-lap-directive frag-list :long 0))
     727                       (when fname
     728                         (x86-lap-directive frag-list :long 0))
     729                       (x86-lap-directive frag-list :long 0))
     730                      (:x8664
     731                       (when debug-info
     732                         (x86-lap-directive frag-list :quad 0))
     733                       (when fname
     734                         (x86-lap-directive frag-list :quad 0))
     735                       (x86-lap-directive frag-list :quad 0)))
    734736
    735737                     (relax-frag-list frag-list)
     
    752754
    753755                     (x862-lap-process-regsave-info frag-list regsave-label regsave-mask regsave-addr)
    754                      (when debug-info-p
    755                        (setf debug-info
    756                              (nconc (copy-list (afunc-lfun-info afunc))
    757                                     (when lambda-form
    758                                       (list 'function-debugging-info lambda-form))
    759                                     (when *x862-recorded-symbols*
    760                                       (list 'function-symbol-map (x862-digest-symbols)))
    761                                     (when (and *x862-emitted-source-notes*
    762                                                *definition-source-note*)
    763                                       (list 'pc-source-map
    764                                             (x862-generate-pc-source-map *definition-source-note* *x862-emitted-source-notes*)))))
    765                        (setf bits (logior (ash 1 $lfbits-info-bit) bits)))
    766                      (unless (or fname lambda-form *x862-recorded-symbols*)
    767                        (setq bits (logior (ash 1 $lfbits-noname-bit) bits)))
    768                      (setf (afunc-argsword afunc) bits)
     756
     757                     (when (getf debug-info 'pc-source-map)
     758                       (setf (getf debug-info 'pc-source-map) (x862-generate-pc-source-map debug-info)))
     759                     (when (getf debug-info 'function-symbol-map)
     760                       (setf (getf debug-info 'function-symbol-map) (x862-digest-symbols)))
     761                     (let ((source-note (getf debug-info 'function-source-note)))
     762                       (when source-note
     763                         (setf (getf debug-info 'function-source-note)
     764                               (source-note-for-%lfun-info source-note))))
     765
    769766                     (setf (afunc-lfun afunc)
    770767                           #+x86-target
     
    773770                             (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info))
    774771                           #-x86-target
    775                            (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))))))))
    776       (backend-remove-labels)))
    777     afunc)
     772                           (cross-create-x86-function fname frag-list *x862-constant-alist* bits debug-info)))))))
     773          (backend-remove-labels))))
     774    afunc))
    778775
    779776
     
    800797            (do* ((i (if native-x86-functions
    801798                       (%function-code-words
    802                         (%function-vector-to-function v))
     799                        (function-vector-to-function v))
    803800                       1)
    804801                     (1+ i)))
     
    808805                (setf (%svref v i) ref-fun)))))))))
    809806
    810 (defun pc-source-map-pc-start (source-mapping)
    811   (etypecase source-mapping
    812     (integer (ldb (byte 15 0) source-mapping))
    813     (vector (aref source-mapping 0))))
    814 
    815 (defun pc-source-map-pc-end (source-mapping)
    816   (etypecase source-mapping
    817     (integer (ldb (byte 15 15) source-mapping))
    818     (vector (aref source-mapping 1))))
    819 
    820 (defun pc-source-map-text-start (source-mapping)
    821   (etypecase source-mapping
    822     (integer (ldb (byte 15 30) source-mapping))
    823     (vector (aref source-mapping 2))))
    824 
    825 (defun pc-source-map-text-end (source-mapping)
    826   (etypecase source-mapping
    827     (integer (ldb (byte 15 45) source-mapping))
    828     (vector (aref source-mapping 3))))
    829 
    830 (defun x862-generate-pc-source-map (definition-source-note emitted-source-notes)
    831   (when *fasl-save-source-locations*
    832     (let* ((def-start (source-note-start-pos definition-source-note))
    833            (n (length emitted-source-notes))
    834            (nvalid 0)
    835            (max 0)
    836            (pc-starts (make-array n))
    837            (pc-ends (make-array n))
    838            (text-starts (make-array n))
    839            (text-ends (make-array n)))
    840       (declare (fixnum n nvalid)
    841                (dynamic-extent pc-starts pc-ends text-starts text-ends))
    842       (dolist (start emitted-source-notes)
    843         (let* ((pc-start (x862-vinsn-note-label-address start t))
    844                (pc-end (x862-vinsn-note-label-address (vinsn-note-peer start) nil))
    845                (text-start (- (source-note-start-pos (aref (vinsn-note-info start) 0)) def-start))
    846                (text-end (- (source-note-end-pos (aref (vinsn-note-info start) 0)) def-start)))
    847           (declare (fixnum pc-start pc-end text-start text-end))
    848           (when (and (plusp pc-start)
    849                      (plusp pc-end)
    850                      (plusp text-start)
    851                      (plusp text-end))
    852             (if (> pc-start max) (setq max pc-start))
    853             (if (> pc-end max) (setq max pc-end))
    854             (if (> text-start max) (setq max text-start))
    855             (if (> text-end max) (setq max text-end))
    856             (setf (svref pc-starts nvalid) pc-start
    857                   (svref pc-ends nvalid) pc-end
    858                   (svref text-starts nvalid) text-start
    859                   (svref text-ends nvalid) text-end)
    860             (incf nvalid))))
    861       (let* ((nentries (* nvalid 4))
    862              (vec (cond ((< max #x100) (make-array nentries :element-type '(unsigned-byte 8)))
    863                         ((< max #x10000) (make-array nentries :element-type '(unsigned-byte 16)))
    864                         (t (make-array nentries :element-type '(unsigned-byte 32))))))
    865         (declare (fixnum nentries))
    866         (do* ((i 0 (+ i 4))
    867               (j 1 (+ j 4))
    868               (k 2 (+ k 4))
    869               (l 3 (+ l 4))
    870               (idx 0 (1+ idx)))
    871              ((= i nentries) vec)
    872           (declare (fixnum i j k l idx))
    873           (setf (aref vec i) (svref pc-starts idx)
    874                 (aref vec j) (svref pc-ends idx)
    875                 (aref vec k) (svref text-starts idx)
    876                 (aref vec l) (svref text-ends idx)))))))
    877 
     807(defun x862-generate-pc-source-map (debug-info)
     808  (let* ((definition-source-note (getf debug-info 'function-source-note))
     809         (emitted-source-notes (getf debug-info 'pc-source-map))
     810         (def-start (source-note-start-pos definition-source-note))
     811         (n (length emitted-source-notes))
     812         (nvalid 0)
     813         (max 0)
     814         (pc-starts (make-array n))
     815         (pc-ends (make-array n))
     816         (text-starts (make-array n))
     817         (text-ends (make-array n)))
     818    (declare (fixnum n nvalid)
     819             (dynamic-extent pc-starts pc-ends text-starts text-ends))
     820    (dolist (start emitted-source-notes)
     821      (let* ((pc-start (x862-vinsn-note-label-address start t))
     822             (pc-end (x862-vinsn-note-label-address (vinsn-note-peer start) nil))
     823             (source-note (aref (vinsn-note-info start) 0))
     824             (text-start (- (source-note-start-pos source-note) def-start))
     825             (text-end (- (source-note-end-pos source-note) def-start)))
     826        (declare (fixnum pc-start pc-end text-start text-end))
     827        (when (and (plusp pc-start)
     828                   (plusp pc-end)
     829                   (plusp text-start)
     830                   (plusp text-end))
     831          (if (> pc-start max) (setq max pc-start))
     832          (if (> pc-end max) (setq max pc-end))
     833          (if (> text-start max) (setq max text-start))
     834          (if (> text-end max) (setq max text-end))
     835          (setf (svref pc-starts nvalid) pc-start
     836                (svref pc-ends nvalid) pc-end
     837                (svref text-starts nvalid) text-start
     838                (svref text-ends nvalid) text-end)
     839          (incf nvalid))))
     840    (let* ((nentries (* nvalid 4))
     841           (vec (cond ((< max #x100) (make-array nentries :element-type '(unsigned-byte 8)))
     842                      ((< max #x10000) (make-array nentries :element-type '(unsigned-byte 16)))
     843                      (t (make-array nentries :element-type '(unsigned-byte 32))))))
     844      (declare (fixnum nentries))
     845      (do* ((i 0 (+ i 4))
     846            (j 1 (+ j 4))
     847            (k 2 (+ k 4))
     848            (l 3 (+ l 4))
     849            (idx 0 (1+ idx)))
     850          ((= i nentries) vec)
     851        (declare (fixnum i j k l idx))
     852        (setf (aref vec i) (svref pc-starts idx)
     853              (aref vec j) (svref pc-ends idx)
     854              (aref vec k) (svref text-starts idx)
     855              (aref vec l) (svref text-ends idx))))))
    878856
    879857(defun x862-vinsn-note-label-address (note &optional start-p sym)
     
    13491327    n))
    13501328
    1351 (defun x862-emit-source-note (seg class nx1-form)
    1352   (check-type class (member :source-location-begin :source-location-end))
    1353   (when (nx1-source-note nx1-form)
    1354     (x862-emit-note seg class (nx1-source-note nx1-form))))
    1355 
    1356 (defmacro x862-wrap-in-source-notes ((seg form) &body body)
    1357   (let ((x862-wrap-in-source-notes-body (gensym "X862-WRAP-IN-SOURCE-NOTES-BODY-")))
    1358     `(flet ((,x862-wrap-in-source-notes-body () ,@body))
    1359        (call-with-x862-wrap-in-source-notes ,seg ,form #',x862-wrap-in-source-notes-body))))
    1360 
    1361 (defun call-with-x862-wrap-in-source-notes (seg form thunk)
    1362   (let (start end)
    1363     (setf start (x862-emit-source-note seg :source-location-begin form))
    1364     (multiple-value-prog1
    1365         (funcall thunk)
    1366       (setf end (x862-emit-source-note seg :source-location-end form))
    1367       (when (and start end)
    1368         (setf (vinsn-note-peer start) end
    1369               (vinsn-note-peer end) start
    1370               *x862-emitted-source-notes* (cons start *x862-emitted-source-notes*))))))
    1371 
    1372 (defun x862-form (seg vreg xfer form)
    1373   (x862-wrap-in-source-notes (seg form)
    1374      (if (nx-null form)
    1375          (x862-nil seg vreg xfer)
    1376          (if (nx-t form)
    1377              (x862-t seg vreg xfer)
    1378              (let* ((op nil)
    1379                     (fn nil))
    1380                (if (and (consp form)
    1381                         (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
     1329(defun x862-form (seg vreg xfer form &aux (note (acode-source-note form)))
     1330  (flet ((main (seg vreg xfer form)
     1331           (if (nx-null form)
     1332             (x862-nil seg vreg xfer)
     1333             (if (nx-t form)
     1334               (x862-t seg vreg xfer)
     1335               (let* ((op nil)
     1336                      (fn nil))
     1337                 (if (and (consp form)
     1338                          (setq fn (svref *x862-specials* (%ilogand #.operator-id-mask (setq op (acode-operator form))))))
    13821339                   (if (and (null vreg)
    1383                             (not *x862-full-safety*)
    13841340                            (%ilogbitp operator-acode-subforms-bit op)
    13851341                            (%ilogbitp operator-assignment-free-bit op))
    1386                        (dolist (f (%cdr form) (x862-branch seg xfer))
    1387                          (x862-form seg nil nil f ))
    1388                        (apply fn seg vreg xfer (%cdr form)))
     1342                     (dolist (f (%cdr form) (x862-branch seg xfer))
     1343                       (x862-form seg nil nil f ))
     1344                     (apply fn seg vreg xfer (%cdr form)))
    13891345                   (compiler-bug "x862-form ? ~s" form)))))))
     1346    (if note
     1347      (let* ((start (x862-emit-note seg :source-location-begin note))
     1348             (bits (main seg vreg xfer form))
     1349             (end (x862-emit-note seg :source-location-end)))
     1350        (setf (vinsn-note-peer start) end
     1351              (vinsn-note-peer end) start)
     1352        (push start *x862-emitted-source-notes*)
     1353        bits)
     1354      (main seg vreg xfer form))))
    13901355
    13911356;;; dest is a float reg - form is acode
     
    31363101                  (if (typep form 'integer)
    31373102                    form)))))
    3138     (and val (%typep val (mode-specifier-type mode)) val)))
     3103    (when val
     3104      (let* ((type (mode-specifier-type mode))
     3105             (high (numeric-ctype-high type))
     3106             (low (numeric-ctype-low type)))
     3107        (if (and (>= val low)
     3108                 (<= val high))
     3109          val
     3110          (if (<= (integer-length val) (integer-length (- high low)))
     3111            (if (eql 0 low)             ; type is unsigned, value is negative
     3112              (logand high val)
     3113              (- val (1+ (- high low))))))))))
     3114
    31393115         
    31403116
     
    44374413                      (cval (nx-constant-form-p clear-form)))
    44384414                 (if cval
    4439                      (progn
    4440                        (x862-one-targeted-reg-form seg (%cadr val) ($ *x862-arg-z*))
    4441                        (if (nx-null cval)
    4442                            (! make-stack-block)
    4443                            (! make-stack-block0)))
    4444                      (with-crf-target () crf
    4445                        (let ((stack-block-0-label (backend-get-next-label))
    4446                              (done-label (backend-get-next-label))
    4447                              (rval ($ *x862-arg-z*))
    4448                              (rclear ($ *x862-arg-y*)))
    4449                          (x862-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
    4450                          (! compare-to-nil crf rclear)
    4451                          (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
    4452                          (! make-stack-block)
    4453                          (-> done-label)
    4454                          (@ stack-block-0-label)
    4455                          (! make-stack-block0)
    4456                          (@ done-label)))))
     4415                   (progn
     4416                     (x862-one-targeted-reg-form seg (%cadr val) ($ *x862-arg-z*))
     4417                     (if (nx-null cval)
     4418                       (! make-stack-block)
     4419                       (! make-stack-block0)))
     4420                   (with-crf-target () crf
     4421                     (let ((stack-block-0-label (backend-get-next-label))
     4422                           (done-label (backend-get-next-label))
     4423                           (rval ($ *x862-arg-z*))
     4424                           (rclear ($ *x862-arg-y*)))
     4425                       (x862-two-targeted-reg-forms seg (%cadr val) rval clear-form rclear)
     4426                       (! compare-to-nil crf rclear)
     4427                       (! cbranch-false (aref *backend-labels* stack-block-0-label) crf x86::x86-e-bits)
     4428                       (! make-stack-block)
     4429                       (-> done-label)
     4430                       (@ stack-block-0-label)
     4431                       (! make-stack-block0)
     4432                       (@ done-label)))))
    44574433               (x862-open-undo $undo-x86-c-frame)
    44584434               (setq val ($ *x862-arg-z*)))
     
    44934469                                                         (:x8664
    44944470                                                          ($ x8664::arg_x)))
    4495                                                         subtag ($ *x862-arg-y*)
    4496                                                         init ($ *x862-arg-z*))
     4471                                                        subtag ($ *x862-arg-y*)
     4472                                                        init ($ *x862-arg-z*))
    44974473                         (! stack-misc-alloc-init))
    44984474                       (progn
  • branches/working-0711/ccl/compiler/nx.lisp

    r11164 r11279  
    151151
    152152(defparameter *load-time-eval-token* nil)
     153
    153154(defparameter *nx-source-note-map* nil)
     155
     156(defun nx-source-note (form &aux (source-notes *nx-source-note-map*))
     157  (when source-notes (gethash form source-notes)))
     158 
     159(defun nx-note-source-transformation (original new &aux (source-notes *nx-source-note-map*) sn)
     160  (when (and source-notes
     161             (setq sn (gethash original source-notes))
     162             (not (gethash new source-notes)))
     163    (setf (gethash new source-notes) sn))
     164  (record-form-source-equivalent original new))
     165
     166(defparameter *nx-discard-xref-info-hook* nil)
     167
     168;; In lieu of a slot in acode.  Don't reference this variable elsewhere because I'm
     169;; hoping to make it go away.
     170(defparameter *nx-acode-source-map* nil)
     171
     172(defun acode-source-note (acode &aux (hash *nx-acode-source-map*))
     173  (and hash (gethash acode hash)))
     174
     175(defun (setf acode-source) (form acode)
     176  ;; Could save the form, but right now only really care about the source note,
     177  ;; and this way don't have to keep looking it up in pass 2.
     178  (let ((note (nx-source-note form)))
     179    (when note
     180      (assert *nx-acode-source-map*)
     181      (setf (gethash acode *nx-acode-source-map*) note))))
    154182
    155183(defun note-contained-in-p (note parent)
     
    194222    note))
    195223
    196 (eval-when (:compile-toplevel)
    197   (declaim (ftype (function (&rest ignore) t)  ppc-compile)))
    198 
    199 (defparameter *nx-discard-xref-info-hook* nil)
    200 
    201 (defun compile-named-function (def &key name env function-note keep-lambda keep-symbols policy load-time-eval-token target source-notes)
     224(defun compile-named-function (def &key name env policy load-time-eval-token target
     225                                function-note keep-lambda keep-symbols source-notes)
     226  ;; SOURCE-NOTES, if not nil, is a hash table mapping source forms to locations,
     227  ;;   is used to produce and attach a pc/source map to the lfun, also to attach
     228  ;;   source locations and pc/source maps to inner lfuns.
     229  ;; FUNCTION-NOTE, if not nil, is a note to attach to the function as the lfun
     230  ;;   source location in preference to whatever the source-notes table assigns to it.
    202231  (when (and name *nx-discard-xref-info-hook*)
    203232    (funcall *nx-discard-xref-info-hook* name))
     
    206235   (let* ((*load-time-eval-token* load-time-eval-token)
    207236          (*nx-source-note-map* source-notes)
    208           (*nx1-source-note-map* (and *fasl-save-source-locations* *nx-source-note-map*))
    209           (*nx-current-code-note* (and source-notes
     237          (*nx-acode-source-map* (and source-notes (make-hash-table :test #'eq :shared nil)))
     238          (*nx-current-code-note* (and source-notes
    210239                                       *compile-code-coverage*
    211240                                       (nx-ensure-code-note def nil function-note)))
    212           (*definition-source-note* (and *fasl-save-source-locations*
    213                                          (or function-note
    214                                              (and *form-source-note-map* (gethash def *form-source-note-map*)))))
    215241          (env (new-lexical-environment env)))
    216242     (setf (lexenv.variables env) 'barrier)
    217        (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
    218               (afunc (nx1-compile-lambda
    219                       name
    220                       def
    221                       (make-afunc)
    222                       nil
    223                       env
    224                       (or policy *default-compiler-policy*)
    225                       *load-time-eval-token*)))
    226          (if (afunc-lfun afunc)
    227            afunc
    228            (funcall (backend-p2-compile *target-backend*)
    229                     afunc
    230                     ;; will also bind *nx-lexical-environment*
    231                     (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
    232                     keep-symbols)))))
     243     (let* ((*target-backend* (or (if target (find-backend target)) *host-backend*))
     244            (afunc (nx1-compile-lambda
     245                    name
     246                    def
     247                    (make-afunc)
     248                    nil
     249                    env
     250                    (or policy *default-compiler-policy*)
     251                    *load-time-eval-token*
     252                    function-note)))
     253       (if (afunc-lfun afunc)
     254         afunc
     255         (funcall (backend-p2-compile *target-backend*)
     256                  afunc
     257                  ;; will also bind *nx-lexical-environment*
     258                  (if keep-lambda (if (lambda-expression-p keep-lambda) keep-lambda def))
     259                  keep-symbols)))))
    233260  (values (afunc-lfun def) (afunc-warnings def)))
    234261
  • branches/working-0711/ccl/compiler/nx0.lisp

    r11164 r11279  
    531531         (not (%ilogbitp $vbitspecial bits)))))
    532532
     533;; Use acode-unwrapped-form-value to reason about the value of a form at
     534;; compile time.   To actually generate code, use acode-unwrapped-form.
     535(defun acode-unwrapped-form-value (form)
     536  (setq form (acode-unwrapped-form form))
     537  (when (and (acode-p form)
     538             (eq (acode-operator form) (%nx1-operator with-code-note)))
     539    (setq form (acode-unwrapped-form-value (caddr form))))
     540  form)
     541
    533542; Strip off any type info or "punted" lexical references.
    534543; ??? Is it true that the "value" of the punted reference is unwrapped ? ???
     
    538547           (acode-punted-var-p (cadr form)))
    539548    (setq form (var-ea (cadr form))))
    540   form)
    541 
    542 ;; Use this only to reason about the value of a form at compile time.   To actually
    543 ;; generate code, use acode-unwrapped-form, because we want to include the code note code.
    544 (defun acode-unwrapped-form-value (form)
    545   (setq form (acode-unwrapped-form form))
    546   (when (and (acode-p form)
    547              (eq (acode-operator form) (%nx1-operator with-code-note)))
    548     (setq form (acode-unwrapped-form-value (caddr form))))
    549549  form)
    550550
     
    12901290                                (%i+ (%i- boundtocount 1) varcount)))))))))
    12911291
    1292 (defvar *nx1-source-note-map* nil
    1293   "Mapping between nx1-forms source locations.")
    1294 
    12951292;; Home-baked handler-case replacement.  About 10 times as fast as full handler-case.
    12961293;;(LET ((S 0)) (DOTIMES (I 1000000) (INCF S))) took 45,678 microseconds
     
    13101307                                 parent-env
    13111308                                 (policy *default-compiler-policy*)
    1312                                  load-time-eval-token)
     1309                                 load-time-eval-token
     1310                                 function-note)
     1311
    13131312  (if q
    13141313     (setf (afunc-parent p) q))
     
    13321331            name)))
    13331332
    1334   (when *definition-source-note*
     1333  (when (or function-note
     1334            (setq function-note (nx-source-note lambda-form))
     1335            (setq function-note (and q (getf (afunc-lfun-info q) 'function-source-note))))
    13351336    (setf (afunc-lfun-info p)
    1336           (list* 'function-source-note
    1337                  (source-note-for-%lfun-info *definition-source-note*)
    1338                  (afunc-lfun-info p))))
     1337          (list* 'function-source-note function-note (afunc-lfun-info p))))
     1338
    13391339  (unless (lambda-expression-p lambda-form)
    13401340    (nx-error "~S is not a valid lambda expression." lambda-form))
     
    16541654    (list (%nx1-operator lambda-list) whole req opt rest keys auxen)))
    16551655
    1656 (defun %fast-compact-simple-string (string start end)
    1657   (declare (simple-string string)
    1658            (fixnum start end))
    1659   (let* ((len (- end start))
    1660          (noctets (utf-8-octets-in-string string start end))
    1661          (vec (make-array noctets :element-type '(unsigned-byte 8))))
    1662     (declare (fixnum len noctets)
    1663              (type (simple-array (unsigned-byte 8) (*)) vec))
    1664     (if (= len noctets)                 ;ASCII.
    1665       (do* ((in start (1+ in))
    1666             (out 0 (1+ out)))
    1667            ((= in end))
    1668         (declare (fixnum in out))
    1669         (setf (aref vec out) (%scharcode string in)))
    1670       (funcall (character-encoding-vector-encode-function
    1671                 (get-character-encoding :utf-8))
    1672                string
    1673                vec
    1674                0
    1675                start
    1676                end))
    1677     vec))
    1678 
    1679 (defun %fast-compact (string)
    1680   ;; mb: bootstrap
    1681   (when (typep string '(array (unsigned-byte 8) (*)))
    1682     (return-from %fast-compact string))
    1683   (when (null string)
    1684     (return-from %fast-compact nil))
    1685   (etypecase string
    1686     (simple-string
    1687      (%fast-compact-simple-string string 0 (uvsize string)))
    1688     (string
    1689      (multiple-value-bind (data offset)
    1690          (array-data-and-offset string)
    1691        (declare (fixnum offset))
    1692        (%fast-compact-simple-string data offset (the fixnum (+ offset (length string))))))))
    1693 
    1694 (defun %fast-uncompact (data)
    1695   (etypecase data
    1696     ((simple-array (unsigned-byte 8) (*))
    1697      (let* ((encoding (get-character-encoding :utf-8))
    1698             (noctets (length data))
    1699             (nchars (funcall (character-encoding-length-of-vector-encoding-function encoding)
    1700                              data
    1701                              0
    1702                              noctets))
    1703             (string (make-string nchars)))
    1704        (declare (fixnum noctets nchars)
    1705                 (simple-string string))
    1706        (if (= noctets nchars)           ;ASCII
    1707          (dotimes (i nchars)
    1708            (setf (%scharcode string i) (aref data i)))
    1709          (funcall (character-encoding-vector-decode-function encoding)
    1710                   data
    1711                   0
    1712                   noctets
    1713                   string))
    1714        string))
    1715     (null data)
    1716     (string data)))
    1717 
    1718 
    1719 (defvar *form-source-note-map* nil
    1720   "Hash table used when compiling a top level definition to map lists of source code to their
    1721   corresponding source notes.")
    1722 
    1723 #||
    1724 (defun make-source-note-form-map (source-note &optional existing-map)
    1725   "Creates a mapping from lisp forms to source-notes based on SOURCE-NOTES. This should be bound to
    1726 *form-source-note-map* or similar."
    1727   (let ((map (or existing-map (make-hash-table))))
    1728     (labels ((walk (note)
    1729                (cond
    1730                  ((consp note)
    1731                   (walk (car note))
    1732                   (walk (cdr note)))
    1733                  ((source-note-p note)
    1734                   (when (and note (not (gethash (source-note-form note) map)))
    1735                     (setf (gethash (source-note-form note) map) note)
    1736                     (walk (source-note-subform-notes note))
    1737                     (setf (source-note-subform-notes note) '())))
    1738                  ((null note) '())
    1739                  (t (error "Don't know how to deal with a source note like ~S."
    1740                            note)))))
    1741       (walk source-note))
    1742     map))
    1743 ||#
    1744 
    1745 (defun nx1-source-note (nx1-code)
    1746   "Return the source-note for the form which generated NX1-CODE."
    1747   (and *fasl-save-source-locations*
    1748        *nx1-source-note-map*
    1749        (gethash nx1-code *nx1-source-note-map*)))
    1750 
    1751 (defun form-source-note (source-form)
    1752   (and *fasl-save-source-locations*
    1753        *form-source-note-map*
    1754        (gethash source-form *form-source-note-map*)))
    1755 
    17561656(defun find-source-at-pc (function pc)
    17571657  (let* ((function-source-note (getf (%lfun-info function) 'function-source-note))
     
    17911691  (with-program-error-handler
    17921692      (lambda (c)
    1793         (nx1-transformed-form (nx-transform (runtime-program-error-form c) env) env original))
     1693        (let ((replacement (runtime-program-error-form c)))
     1694          (nx-note-source-transformation original replacement)
     1695          (nx1-transformed-form (nx-transform replacement env) env original)))
    17941696    (nx1-transformed-form (nx-transform original env) env original)))
    17951697
     
    18091711
    18101712(defun nx1-transformed-form-aux (form env)
    1811   (flet ((main ()
     1713  (flet ((main (form env)
    18121714           (if (consp form)
    1813                (nx1-combination form env)
    1814                (let* ((symbolp (non-nil-symbol-p form))
    1815                       (constant-value (unless symbolp form))
    1816                       (constant-symbol-p nil))
    1817                  (if symbolp
    1818                      (multiple-value-setq (constant-value constant-symbol-p)
    1819                        (nx-transform-defined-constant form env)))
    1820                  (if (and symbolp (not constant-symbol-p))
    1821                      (nx1-symbol form env)
    1822                      (nx1-immediate (nx-unquote constant-value)))))))
    1823     (if *fasl-save-source-locations*
    1824         (destructuring-bind (nx1-form . values)
    1825             (multiple-value-list (main))
    1826           (record-form-to-nx1-transformation form nx1-form)
    1827           (values-list (cons nx1-form values)))
    1828         (main))))
     1715             (nx1-combination form env)
     1716             (let* ((symbolp (non-nil-symbol-p form))
     1717                    (constant-value (unless symbolp form))
     1718                    (constant-symbol-p nil))
     1719               (if symbolp
     1720                 (multiple-value-setq (constant-value constant-symbol-p)
     1721                   (nx-transform-defined-constant form env)))
     1722               (if (and symbolp (not constant-symbol-p))
     1723                 (nx1-symbol form env)
     1724                 (nx1-immediate (nx-unquote constant-value)))))))
     1725    (if *nx-source-note-map*
     1726      (let ((acode (main form env)))
     1727        (setf (acode-source acode) form)
     1728        acode)
     1729      (main form env))))
    18291730
    18301731(defun nx1-prefer-areg (form env)
     
    18511752  (setq form (nx-untyped-form form))
    18521753  (and (or (nx-null form)
    1853            (nx-t form)
    1854            (and (acode-p form)
    1855                 (or (eq (acode-operator form) (%nx1-operator immediate))
    1856                     (eq (acode-operator form) (%nx1-operator fixnum))
    1857                     (eq (acode-operator form) (%nx1-operator simple-function))
    1858                     (and (eq (acode-operator form) (%nx1-operator with-code-note))
    1859                         (setq form (nx-constant-form-p (%caddr form)))))))
     1754           (nx-t form)
     1755           (and (acode-p form)
     1756                (or (eq (acode-operator form) (%nx1-operator immediate))
     1757                    (eq (acode-operator form) (%nx1-operator fixnum))
     1758                    (eq (acode-operator form) (%nx1-operator simple-function))
     1759                    (and (eq (acode-operator form) (%nx1-operator with-code-note))
     1760                        (setq form (nx-constant-form-p (%caddr form)))))))
    18601761       form))
    18611762
     
    22762177)
    22772178
    2278 (defun record-form-to-nx1-transformation (form nx1)
    2279   (when (and *nx1-source-note-map* (form-source-note form))
    2280     (setf (gethash nx1 *nx1-source-note-map*) (form-source-note form))))
    2281 
    2282 (defun record-nx1-source-equivalent (original new)
    2283   (when (and *nx1-source-note-map*
    2284              (nx1-source-note original)
    2285              (not (nx1-source-note new)))
    2286     (setf (gethash new *nx1-source-note-map*)
    2287           (gethash original *nx1-source-note-map*))))
    2288 
    2289 (defun record-form-source-equivalent (original new)
    2290   (when (and *form-source-note-map*
    2291              (form-source-note original)
    2292              (not (form-source-note new)))
    2293     (setf (gethash new *form-source-note-map*)
    2294           (gethash original *form-source-note-map*))))
    2295 
    2296 (defun nx-note-source-transformation (original new)
    2297   (when (and *nx-source-note-map*
    2298              (gethash original *nx-source-note-map*)
    2299              (not (gethash new *nx-source-note-map*)))
    2300     (setf (gethash new *nx-source-note-map*)
    2301           (gethash original *nx-source-note-map*)))
    2302   (record-form-source-equivalent original new))
    2303 
    23042179(defun nx-transform (form &optional (environment *nx-lexical-environment*) (source-note-map *nx-source-note-map*))
    2305   (let* (sym transforms lexdefs changed enabled macro-function compiler-macro (source t))
    2306     (when source-note-map
    2307       (setq source (gethash form source-note-map)))
    2308     (tagbody
     2180  (macrolet ((form-changed (form)
     2181               `(progn
     2182                  (unless source (setq source (gethash ,form source-note-map)))
     2183                  (setq changed t))))
     2184    (prog (sym transforms lexdefs changed enabled macro-function compiler-macro (source t))
     2185       (when source-note-map
     2186         (setq source (gethash form source-note-map)))
    23092187       (go START)
    23102188     LOOP
    2311        (unless source (setq source (gethash form source-note-map)))
    2312        (setq changed t)
     2189       (form-changed form)
    23132190       (when (and (consp form)
    2314                   (or (eq (%car form) 'the)
    2315                       (and sym (eq (%car form) sym))))
    2316         (go DONE))
     2191                  (or (eq (%car form) 'the)
     2192                      (and sym (eq (%car form) sym))))
     2193        (go DONE))
    23172194     START
    23182195       (when (non-nil-symbol-p form)
    2319         (multiple-value-bind (newform win) (nx-transform-symbol form environment)
    2320            (unless win (go DONE))
    2321            (setq form newform)
    2322            (go LOOP)))
     2196        (multiple-value-bind (newform win) (nx-transform-symbol form environment)
     2197           (unless win (go DONE))
     2198           (setq form newform)
     2199           (go LOOP)))
    23232200       (when (atom form) (go DONE))
    23242201       (unless (symbolp (setq sym (%car form)))
    2325         (go DONE))
     2202        (go DONE))
    23262203       (when (eq sym 'the)
    2327         (destructuring-bind (typespec thing) (cdr form)
     2204        (destructuring-bind (typespec thing) (cdr form)
    23282205           (if (constantp thing)
    23292206             (progn
    23302207               (setq form thing)
    23312208               (go LOOP))
    2332              (multiple-value-bind (newform win) (nx-transform thing environment)
     2209             (multiple-value-bind (newform win) (nx-transform thing environment source-note-map)
    23332210               (when win
    2334                  (unless source (setq source (gethash newform source-note-map)))
    2335                  (setq changed t)
     2211                 (form-changed newform)
    23362212                 (if (and (self-evaluating-p newform)
    23372213                          (typep newform typespec))
     
    23402216                 (go DONE))))))
    23412217       (when (nx-quoted-form-p form)
    2342         (when (self-evaluating-p (%cadr form))
    2343            (setq form (%cadr form)))
    2344         (go DONE))
     2218        (when (self-evaluating-p (%cadr form))
     2219           (setq form (%cadr form)))
     2220        (go DONE))
    23452221       (when (setq lexdefs (nx-lexical-finfo sym environment))
    2346         (if (eq 'function (%car lexdefs))
    2347            (go DONE)))
     2222        (if (eq 'function (%car lexdefs))
     2223           (go DONE)))
    23482224       (setq transforms (setq compiler-macro (compiler-macro-function sym environment))
    2349              macro-function (macro-function sym environment)
    2350              enabled (nx-allow-transforms environment))
     2225             macro-function (macro-function sym environment)
     2226             enabled (nx-allow-transforms environment))
    23512227       (unless macro-function
    2352          (let* ((win nil))
    2353            (when (and enabled (functionp (fboundp sym)))
    2354              (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map))
    2355              (when win
    2356                (unless source (setq source (gethash form source-note-map)))
    2357                (setq changed t)))))
     2228         (let* ((win nil))
     2229           (when (and enabled (functionp (fboundp sym)))
     2230             (multiple-value-setq (form win) (nx-transform-arglist form environment source-note-map))
     2231             (when win
     2232               (form-changed form)))))
    23582233       (when (and enabled
    2359                   (not (nx-declared-notinline-p sym environment)))
    2360         (multiple-value-bind (value folded) (nx-constant-fold form environment)
    2361            (when folded
    2362              (setq form value changed t)
    2363              (unless source (setq source (gethash form source-note-map)))
     2234                  (not (nx-declared-notinline-p sym environment)))
     2235        (multiple-value-bind (value folded) (nx-constant-fold form environment)
     2236           (when folded
     2237             (setq form value)
     2238             (form-changed form)
    23642239             (unless (and (consp form) (eq (car form) sym)) (go START))))
    2365         (when compiler-macro
    2366            (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
    2367              (when win
    2368                (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym)))
    2369                 (setq sym nil))
    2370                (setq form newform)
    2371                (go LOOP))))
    2372         (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment)
    2373            (when win
    2374              (setq sym nil)
    2375              (setq form newform)
    2376              (go START)))
    2377         (unless macro-function
    2378            (when (setq transforms (or (environment-structref-info sym environment)
    2379                                       (and #-bccl (boundp '%structure-refs%)
    2380                                            (gethash sym %structure-refs%))))
    2381              (setq form (defstruct-ref-transform transforms (%cdr form)) changed T)
    2382              (unless source (setq source (gethash form source-note-map)))
    2383              (go START))
    2384            (when (setq transforms (assq sym *nx-synonyms*))
    2385              (setq form (cons (%cdr transforms) (setq sym (%cdr form))))
    2386              (go LOOP))))
     2240        (when compiler-macro
     2241           (multiple-value-bind (newform win) (compiler-macroexpand-1 form environment)
     2242             (when win
     2243               (when (and (consp newform) (eq (car newform) sym) (functionp (fboundp sym)))
     2244                (setq sym nil))
     2245               (setq form newform)
     2246               (go LOOP))))
     2247        (multiple-value-bind (newform win) (maybe-optimize-slot-accessor-form form environment)
     2248           (when win
     2249             (setq sym nil)
     2250             (setq form newform)
     2251             (go START)))
     2252        (unless macro-function
     2253           (when (setq transforms (or (environment-structref-info sym environment)
     2254                                      (and (boundp '%structure-refs%)
     2255                                           (gethash sym %structure-refs%))))
     2256             (setq form (defstruct-ref-transform transforms (%cdr form)))
     2257             (form-changed form)
     2258             (go START))
     2259           (when (setq transforms (assq sym *nx-synonyms*))
     2260             (setq form (cons (%cdr transforms) (setq sym (%cdr form))))
     2261             (go LOOP))))
    23872262       (when (and macro-function
    2388                   (or lexdefs
    2389                       (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment))))))
    2390          (nx-record-xref-info :macro-calls (function-name macro-function))
    2391          (setq form (macroexpand-1 form environment) changed t)
    2392          (unless source (setq source (gethash form source-note-map)))
    2393          (go START))
    2394      DONE)
    2395     (when (and source (neq source t) (not (gethash form source-note-map)))
    2396       (unless (and (consp form)
    2397                    (eq (%car form) 'the)
    2398                    (eq source (gethash (caddr form) source-note-map)))
    2399         (unless (eq form (%unbound-marker))
    2400           (setf (gethash form source-note-map) source))))
    2401     (values form changed)))
     2263                  (or lexdefs
     2264                      (not (and (gethash sym *nx1-alphatizers*) (not (nx-declared-notinline-p sym environment))))))
     2265         (nx-record-xref-info :macro-calls (function-name macro-function))
     2266         (setq form (macroexpand-1 form environment))
     2267         (form-changed form)
     2268         (go START))
     2269     DONE
     2270       (when (and source (neq source t) (not (gethash form source-note-map)))
     2271         (unless (and (consp form)
     2272                      (eq (%car form) 'the)
     2273                      (eq source (gethash (caddr form) source-note-map)))
     2274           (unless (or (eq form (%unbound-marker))
     2275                       (eq form (%slot-unbound-marker)))
     2276             (setf (gethash form source-note-map) source))))
     2277       (return (values form changed)))))
    24022278
    24032279; Transform all of the arguments to the function call form.
    24042280; If any of them won, return a new call form (with the same operator as the original), else return the original
    24052281; call form unchanged.
    2406 
    2407 (defun nx-transform-arglist (callform env &optional source-note-map)
    2408     (let* ((any-wins nil)
    2409            (transformed-call (cons (car callform) nil))
    2410            (ptr transformed-call)
    2411            (win nil))
    2412       (declare (type cons ptr))
    2413       (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
    2414         (multiple-value-setq (form win) (nx-transform form env source-note-map))
    2415         (rplacd ptr (setq ptr (cons form nil)))
    2416         (if win (setq any-wins t)))))
     2282(defun nx-transform-arglist (callform env source-note-map)
     2283  (let* ((any-wins nil)
     2284         (transformed-call (cons (car callform) nil))
     2285         (ptr transformed-call)
     2286         (win nil))
     2287    (declare (type cons ptr))
     2288    (dolist (form (cdr callform) (if any-wins (values (copy-list transformed-call) t) (values callform nil)))
     2289      (multiple-value-setq (form win) (nx-transform form env source-note-map))
     2290      (rplacd ptr (setq ptr (cons form nil)))
     2291      (if win (setq any-wins t)))))
    24172292
    24182293;This is needed by (at least) SETF.
  • branches/working-0711/ccl/compiler/nx1.lisp

    r11267 r11279  
    3030      (setq typespec (nx-target-type (type-specifier ctype)))))
    3131  (let* ((*nx-form-type* typespec)
    32          (transformed (nx-transform form env))
    33          (aform (nx1-transformed-form (if (and (consp transformed)
    34                                                (eq (car transformed) 'the))
    35                                         form
    36                                         transformed) env form)))
    37     ;; Doing this in this bizarre way may be a little easier
    38     ;; to bootstrap.
    39     (if (nx-the-typechecks env)
    40       (make-acode
    41        (%nx1-operator typed-form)
    42        typespec
    43        aform
    44        t)
    45       (make-acode
    46        (%nx1-operator typed-form)
    47        typespec
    48        aform))))
     32         (transformed (nx-transform form env)))
     33    (when (and (consp transformed)
     34               (eq (car transformed) 'the))
     35      (setq transformed form))
     36    (make-acode
     37     (%nx1-operator typed-form)
     38     typespec
     39     (nx1-transformed-form transformed env)
     40     (nx-the-typechecks env))))
    4941
    5042(defnx1 nx1-struct-ref struct-ref (&whole whole structure offset)
     
    14781470                    (nx-error "Can't funcall macro function ~s ." name)))
    14791471              (and (consp name)
    1480                    (or (eq (%car name) 'lambda)
     1472                   (or (when (eq (%car name) 'lambda)
     1473                         (nx-note-source-transformation func name)
     1474                         t)
    14811475                       (setq name (nx-need-function-name name))))))
    14821476      (nx1-form (cons name args))  ; This picks up call-next-method evil.
     
    15551549            (multiple-value-bind (body decls)
    15561550                                 (parse-body flet-function-body env)
    1557               (let ((func (make-afunc)))
     1551              (let ((func (make-afunc))
     1552                    (expansion `(lambda ,lambda-list
     1553                                  ,@decls
     1554                                  (block ,(if (consp funcname) (%cadr funcname) funcname)
     1555                                    ,@body))))
     1556                (nx-note-source-transformation def expansion)
    15581557                (setf (afunc-environment func) env
    1559                       (afunc-lambdaform func) `(lambda ,lambda-list
    1560                                                      ,@decls
    1561                                                      (block ,(if (consp funcname) (%cadr funcname) funcname)
    1562                                                        ,@body)))
     1558                      (afunc-lambdaform func) expansion)
    15631559                (push func funcs)
    15641560                (when (and *nx-next-method-var*
     
    16511647                                   (block ,blockname
    16521648                                     ,@body))))
     1649                (nx-note-source-transformation def expansion)
    16531650                (setf (afunc-lambdaform func) expansion
    16541651                      (afunc-environment func) env)
  • branches/working-0711/ccl/level-1/l1-init.lisp

    r11164 r11279  
    261261(defparameter *save-local-symbols* t)
    262262(defvar *save-source-locations* nil
    263   "Controls whether complete source locations is stored.
     263  "Controls whether complete source locations is stored, both for definitions (names) and
     264in function objects.
    264265
    265266If NIL we don't store any source location (other than the filename if *record-source-file* is non-NIL).
  • branches/working-0711/ccl/level-1/l1-reader.lisp

    r11185 r11279  
    30243024  end-pos)
    30253025
     3026(defun %fast-compact-simple-string (string start end)
     3027  (declare (simple-string string)
     3028           (fixnum start end))
     3029  (let* ((len (- end start))
     3030         (noctets (utf-8-octets-in-string string start end))
     3031         (vec (make-array noctets :element-type '(unsigned-byte 8))))
     3032    (declare (fixnum len noctets)
     3033             (type (simple-array (unsigned-byte 8) (*)) vec))
     3034    (if (= len noctets)                 ;ASCII.
     3035      (do* ((in start (1+ in))
     3036            (out 0 (1+ out)))
     3037           ((= in end))
     3038        (declare (fixnum in out))
     3039        (setf (aref vec out) (%scharcode string in)))
     3040      (funcall (character-encoding-vector-encode-function
     3041                (get-character-encoding :utf-8))
     3042               string
     3043               vec
     3044               0
     3045               start
     3046               end))
     3047    vec))
     3048
     3049(defun %fast-compact (string)
     3050  ;; mb: bootstrap
     3051  (when (typep string '(array (unsigned-byte 8) (*)))
     3052    (return-from %fast-compact string))
     3053  (when (null string)
     3054    (return-from %fast-compact nil))
     3055  (etypecase string
     3056    (simple-string
     3057     (%fast-compact-simple-string string 0 (uvsize string)))
     3058    (string
     3059     (multiple-value-bind (data offset)
     3060         (array-data-and-offset string)
     3061       (declare (fixnum offset))
     3062       (%fast-compact-simple-string data offset (the fixnum (+ offset (length string))))))))
     3063
     3064(defun %fast-uncompact (data)
     3065  (etypecase data
     3066    ((simple-array (unsigned-byte 8) (*))
     3067     (let* ((encoding (get-character-encoding :utf-8))
     3068            (noctets (length data))
     3069            (nchars (funcall (character-encoding-length-of-vector-encoding-function encoding)
     3070                             data
     3071                             0
     3072                             noctets))
     3073            (string (make-string nchars)))
     3074       (declare (fixnum noctets nchars)
     3075                (simple-string string))
     3076       (if (= noctets nchars)           ;ASCII
     3077         (dotimes (i nchars)
     3078           (setf (%scharcode string i) (aref data i)))
     3079         (funcall (character-encoding-vector-decode-function encoding)
     3080                  data
     3081                  0
     3082                  noctets
     3083                  string))
     3084       string))
     3085    (null data)
     3086    (string data)))
     3087
     3088
     3089
    30263090;;; we don't actually store source-note structs in the fasl since that runs into problems dumping
    30273091;;; the struct.
  • branches/working-0711/ccl/lib/ccl-export-syms.lisp

    r11267 r11279  
    3636                                        ; misc
    3737     record-source-file
     38     get-source-files
     39     edit-definition
     40     edit-definition-p
     41     *loading-file-source-file*
    3842     definition-source
    3943     define-definition-type
  • branches/working-0711/ccl/lib/macros.lisp

    r11267 r11279  
    956956; This is supposedly ANSI CL.
    957957(defmacro lambda (&whole lambda-expression (&rest paramlist) &body body)
     958  (declare (ignore paramlist body))
    958959  (unless (lambda-expression-p lambda-expression)
    959960    (warn "Invalid lambda expression: ~s" lambda-expression))
    960   `(function (lambda ,paramlist ,@body)))
     961  `(function ,lambda-expression))
    961962
    962963; This isn't
  • branches/working-0711/ccl/lib/nfcomp.lisp

    r11164 r11279  
    402402      (getf *fcomp-print-handler-plist* 'include) '(nil . t))
    403403
     404
     405(defvar *form-source-note-map* nil
     406  "Hash table used when compiling a top level definition to map lists of source code to their
     407  corresponding source notes.")
     408
     409(defun record-form-source-equivalent (original new)
     410  (when (and *form-source-note-map*
     411             *fasl-save-source-locations*
     412             (setq original (gethash original *form-source-note-map*))
     413             (not (gethash new *form-source-note-map*)))
     414    (setf (gethash new *form-source-note-map*) original)))
    404415
    405416(defun fcomp-file (filename orig-file env)  ; orig-file is back-translated
Note: See TracChangeset for help on using the changeset viewer.