Changeset 13613 for release/1.5


Ignore:
Timestamp:
Apr 11, 2010, 8:54:45 PM (9 years ago)
Author:
rme
Message:

Merge trunk changes through r13592.

Location:
release/1.5/source
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/1.5/source

  • release/1.5/source/lib/defstruct.lisp

    r13344 r13613  
    111111                              print-function)))
    112112
     113(defun sd-refname-in-included-struct-p (sd name &optional env)
     114  (dolist (included-type (cdr (sd-superclasses sd)))
     115    (let ((sub-sd (or (let ((defenv (definition-environment env)))
     116                        (when defenv (%cdr (assq included-type
     117                                                 (defenv.structures
     118                                                     defenv)))))
     119                      (gethash included-type %defstructs%))))
     120      (when sub-sd
     121        (if (member name (sd-refnames sub-sd) :test 'eq)
     122          (return t))))))
    113123
    114124(defun sd-refname-pos-in-included-struct (sd name)
     
    137147            (let ((offset (ssd-offset slot)))
    138148              (unless (eql pos offset)
    139                 ; This should be a style-warning
     149                ;; This should be a style-warning
    140150                (warn "Accessor ~s at different position than in included structure"
    141151                      accessor)))
    142             (let ((fn (slot-accessor-fn slot accessor env)))
    143               (push
    144                `(progn
    145                   ,.fn
    146                   (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
    147                   (record-source-file ',accessor 'structure-accessor))
    148                stuff))))))
     152            (unless (sd-refname-in-included-struct-p sd accessor env)
     153              (let ((fn (slot-accessor-fn slot accessor env)))
     154                (push
     155                 `(progn
     156                    ,.fn
     157                    (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
     158                    (record-source-file ',accessor 'structure-accessor))
     159                 stuff)))))))
    149160    (nreverse stuff)))
    150161
  • release/1.5/source/lib/read.lisp

    r13067 r13613  
    196196
    197197
     198(defun get-read-object (arg)
     199  (if (listp %read-objects%)
     200    (assoc arg %read-objects%)
     201    (gethash arg %read-objects%)))
     202
     203(defparameter *read-objects-hash-threshold* 30)
     204
     205(defun note-read-object (data)
     206  (let* ((lab (car data)))
     207    (if (get-read-object lab)
     208      (%err-disp $xduprdlbl lab)
     209      (if (listp %read-objects%)
     210        (if (< (length %read-objects%) *read-objects-hash-threshold*)
     211          (push data %read-objects%)
     212          (let* ((hash (make-hash-table :test #'eql :shared nil :rehash-size 2.0)))
     213            (dolist (info %read-objects%)
     214              (let* ((lab (car info)))
     215                (setf (gethash lab hash) info)))
     216            (setf (gethash lab hash) data)
     217            (setq %read-objects% hash)))
     218        (setf (gethash lab %read-objects%) data)))))
     219
     220
     221   
     222
    198223(set-dispatch-macro-character #\# #\#
    199224  #'(lambda (stream char arg)
     
    202227        nil
    203228        (if arg
    204           (let ((pair (assoc arg %read-objects%))) ;Not assq, could be bignum!
     229          (let ((pair (get-read-object arg)))
    205230            (if pair
    206               (cdr pair)
     231              (let* ((cell (cdr pair)))
     232                (setf (car cell) t)
     233                (cdr cell))
    207234              (%err-disp $xnordlbl arg)))
    208235          (%err-disp $xrdndarg char)))))
     
    214241     (cond (*read-suppress* (values))
    215242           ((null arg) (%err-disp $xrdndarg char))
    216            ((assoc arg %read-objects%)    ;Not assq, could be bignum!
    217             (%err-disp $xduprdlbl arg))
    218243           (t (setq lab (cons arg nil))
    219               (push (%rplacd lab lab) %read-objects%)
     244              (%rplacd lab (cons nil lab))
     245              (note-read-object lab)
    220246              (setq form (read stream t nil t))
    221               (when (eq form lab)   ;#n= #n#.  No can do.
     247              (when (eq form lab)       ;#n= #n#.  No can do.
    222248                (%err-disp $xnordlbl (%car lab)))
    223               (%rplacd lab form)
    224               (let ((scanned nil))
    225                   (labels ((circle-subst (tree)
    226                              (if (memq tree %read-objects%)
    227                                (progn
    228                                  (unless (memq tree scanned)
    229                                    (setq scanned (%temp-cons tree scanned))
    230                                    (circle-subst (cdr tree)))
    231                                  (cdr tree))
    232                                (let ((gvectorp (and (gvectorp tree)  (not (or (symbolp tree) (functionp tree))))))
    233                                  (unless (or (and (atom tree) (not gvectorp)) (memq tree scanned))
    234                                    (setq scanned (%temp-cons tree scanned))
    235                                    (if gvectorp
    236                                      (let* ((subtype  (typecode tree)))
    237                                        (dotimes (i (uvsize tree))
    238                                          (declare (fixnum i))
    239                                          (unless (and (eql i 0) (eql subtype target::subtag-instance))
    240                                            (setf (uvref tree i) (circle-subst (uvref tree i))))))
    241                                      (locally
    242                                       (declare (type cons tree))
    243                                       (rplaca tree (circle-subst (car tree)))
    244                                       (rplacd tree (circle-subst (cdr tree))))))
    245                                  tree))))
    246                     (declare (dynamic-extent #'circle-subst))
    247                     (circle-subst form)))))))
    248 
    249 
    250 
     249              (%rplacd (cdr lab) form)
     250              (let* ((reffed (cadr lab)))
     251                (if (not reffed)
     252                  form
     253                  (let ((scanned nil))
     254                    (labels ((circle-subst (tree)
     255                               (if (eq tree lab)
     256                                 (progn
     257                                   (unless (memq tree scanned)
     258                                     (setq scanned (%temp-cons tree scanned))
     259                                     (circle-subst (cddr tree)))
     260                                   (cddr tree))
     261                                 (progn
     262                                   (cond ((consp tree)
     263                                          (unless (memq tree scanned)
     264                                            (push tree scanned)
     265                                            (locally
     266                                                (declare (type cons tree))
     267                                              (let* ((orig (car tree))
     268                                                     (new (circle-subst orig)))
     269                                                (unless (eq orig new)
     270                                                  (rplaca tree new))
     271                                                (setq orig (cdr tree)
     272                                                      new (circle-subst orig))
     273                                                (unless (eq orig new)
     274                                                  (rplacd tree new))))))
     275                                         ((let* ((typecode (typecode tree)))
     276                                            (declare (type (unsigned-byte 8) typecode))
     277                                            (or (= typecode target::subtag-simple-vector)
     278                                                (= typecode target::subtag-struct)
     279                                                (= typecode target::subtag-arrayH)))
     280                                          (unless (memq tree scanned)
     281                                            (push tree scanned)
     282                                            (let* ((n (uvsize tree)))
     283                                              (declare (fixnum n))
     284                                              (do* ((i (if (eql (typecode tree) target::subtag-struct) 1 0) (1+ i)))
     285                                                   ((= i n))
     286                                                (declare (fixnum i))
     287                                                (let* ((old (%svref tree i))
     288                                                       (new (circle-subst old)))
     289                                               (unless (eq old new)
     290                                                 (setf (%svref tree i) new))))))))
     291                                   tree))))
     292                      (declare (dynamic-extent #'circle-subst))
     293                      (circle-subst form)))))))))
     294
     295
     296
  • release/1.5/source/lisp-kernel/macros.h

    r13067 r13613  
    9191#define TCR_INTERRUPT_LEVEL(tcr) \
    9292  (((signed_natural *)((tcr)->tlb_pointer))[INTERRUPT_LEVEL_BINDING_INDEX])
    93 #endif
    9493
    9594#ifdef WINDOWS
     
    115114#define DECIMAL "%ld"
    116115#endif
     116
     117#endif /* __macros __ */
  • release/1.5/source/lisp-kernel/pmcl-kernel.c

    r13376 r13613  
    933933#endif
    934934
    935 char *
    936 case_inverted_path(char *path)
    937 {
    938   char *copy = strdup(path), *base = copy, *work = copy, c;
    939   if (copy == NULL) {
    940     return NULL;
    941   }
    942   while(*work) {
    943     if (*work++ == '/') {
    944       base = work;
    945     }
    946   }
    947   work = base;
    948   while ((c = *work) != '\0') {
    949     if (islower(c)) {
    950       *work++ = toupper(c);
    951     } else {
    952       *work++ = tolower(c);
    953     }
    954   }
    955   return copy;
    956 }
    957 /*
    958    The underlying file system may be case-insensitive (e.g., HFS),
    959    so we can't just case-invert the kernel's name.
    960    Tack ".image" onto the end of the kernel's name.  Much better ...
    961 */
    962935#ifdef WINDOWS
    963936wchar_t *
     
    972945default_image_name(char *orig)
    973946{
    974 #ifdef WINDOWS
    975   char *path = chop_exe_suffix(orig);
    976 #else
    977947  char *path = orig;
    978 #endif
    979948  char *image_name = path_by_appending_image(path);
    980 #if !defined(WINDOWS) && !defined(DARWIN)
    981   if (!probe_file(image_name)) {
    982     char *legacy = case_inverted_path(path);
    983     if (probe_file(legacy)) {
    984       image_name = legacy;
    985     }
    986   }
    987 #endif
    988949  return image_name;
    989950}
Note: See TracChangeset for help on using the changeset viewer.