Changeset 13613

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:

• . (modified) (1 prop)
• lib/defstruct.lisp (modified) (2 diffs)
• lib/read.lisp (modified) (3 diffs)
• lisp-kernel/macros.h (modified) (2 diffs)
• lisp-kernel/pmcl-kernel.c (modified) (2 diffs)

release/1.5/source/lib/defstruct.lisp

@@ -111 +111 @@
                               print-function)))
 
+(defun sd-refname-in-included-struct-p (sd name &optional env)
+  (dolist (included-type (cdr (sd-superclasses sd)))
+    (let ((sub-sd (or (let ((defenv (definition-environment env)))
+                        (when defenv (%cdr (assq included-type
+                                                 (defenv.structures
+                                                     defenv)))))
+                      (gethash included-type %defstructs%))))
+      (when sub-sd
+        (if (member name (sd-refnames sub-sd) :test 'eq)
+          (return t))))))
 
 (defun sd-refname-pos-in-included-struct (sd name)
@@ -137 +147 @@
             (let ((offset (ssd-offset slot)))
               (unless (eql pos offset)
-                ; This should be a style-warning
+                ;; This should be a style-warning
                 (warn "Accessor ~s at different position than in included structure"
                       accessor)))
-            (let ((fn (slot-accessor-fn slot accessor env)))
-              (push
-               `(progn
-                  ,.fn
-                  (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
-                  (record-source-file ',accessor 'structure-accessor))
-               stuff))))))
+            (unless (sd-refname-in-included-struct-p sd accessor env)
+              (let ((fn (slot-accessor-fn slot accessor env)))
+                (push
+                 `(progn
+                    ,.fn
+                    (puthash ',accessor %structure-refs% ',(ssd-type-and-refinfo slot))
+                    (record-source-file ',accessor 'structure-accessor))
+                 stuff)))))))
     (nreverse stuff)))
 

release/1.5/source/lib/read.lisp

@@ -196 +196 @@
 
 
+(defun get-read-object (arg)
+  (if (listp %read-objects%)
+    (assoc arg %read-objects%)
+    (gethash arg %read-objects%)))
+
+(defparameter *read-objects-hash-threshold* 30)
+
+(defun note-read-object (data)
+  (let* ((lab (car data)))
+    (if (get-read-object lab)
+      (%err-disp $xduprdlbl lab)
+      (if (listp %read-objects%)
+        (if (< (length %read-objects%) *read-objects-hash-threshold*)
+          (push data %read-objects%)
+          (let* ((hash (make-hash-table :test #'eql :shared nil :rehash-size 2.0)))
+            (dolist (info %read-objects%)
+              (let* ((lab (car info)))
+                (setf (gethash lab hash) info)))
+            (setf (gethash lab hash) data)
+            (setq %read-objects% hash)))
+        (setf (gethash lab %read-objects%) data)))))
+
+
+    
+
 (set-dispatch-macro-character #\# #\#
   #'(lambda (stream char arg)
@@ -202 +227 @@
         nil
         (if arg
-          (let ((pair (assoc arg %read-objects%))) ;Not assq, could be bignum!
+          (let ((pair (get-read-object arg)))
             (if pair
-              (cdr pair)
+              (let* ((cell (cdr pair)))
+                (setf (car cell) t)
+                (cdr cell))
               (%err-disp $xnordlbl arg)))
           (%err-disp $xrdndarg char)))))
@@ -214 +241 @@
      (cond (*read-suppress* (values))
            ((null arg) (%err-disp $xrdndarg char))
-           ((assoc arg %read-objects%)    ;Not assq, could be bignum!
-            (%err-disp $xduprdlbl arg))
            (t (setq lab (cons arg nil))
-              (push (%rplacd lab lab) %read-objects%)
+              (%rplacd lab (cons nil lab))
+              (note-read-object lab)
               (setq form (read stream t nil t))
-              (when (eq form lab)   ;#n= #n#.  No can do.
+              (when (eq form lab)       ;#n= #n#.  No can do.
                 (%err-disp $xnordlbl (%car lab)))
-              (%rplacd lab form)
-              (let ((scanned nil))
-                  (labels ((circle-subst (tree)
-                             (if (memq tree %read-objects%)
-                               (progn
-                                 (unless (memq tree scanned)
-                                   (setq scanned (%temp-cons tree scanned))
-                                   (circle-subst (cdr tree)))
-                                 (cdr tree))
-                               (let ((gvectorp (and (gvectorp tree)  (not (or (symbolp tree) (functionp tree))))))
-                                 (unless (or (and (atom tree) (not gvectorp)) (memq tree scanned))
-                                   (setq scanned (%temp-cons tree scanned))
-                                   (if gvectorp
-                                     (let* ((subtype  (typecode tree)))
-                                       (dotimes (i (uvsize tree))
-                                         (declare (fixnum i))
-                                         (unless (and (eql i 0) (eql subtype target::subtag-instance))
-                                           (setf (uvref tree i) (circle-subst (uvref tree i))))))
-                                     (locally 
-                                      (declare (type cons tree))
-                                      (rplaca tree (circle-subst (car tree)))
-                                      (rplacd tree (circle-subst (cdr tree))))))
-                                 tree))))
-                    (declare (dynamic-extent #'circle-subst))
-                    (circle-subst form)))))))
-
-
-
+              (%rplacd (cdr lab) form)
+              (let* ((reffed (cadr lab)))
+                (if (not reffed)
+                  form
+                  (let ((scanned nil))
+                    (labels ((circle-subst (tree)
+                               (if (eq tree lab)
+                                 (progn
+                                   (unless (memq tree scanned)
+                                     (setq scanned (%temp-cons tree scanned))
+                                     (circle-subst (cddr tree)))
+                                   (cddr tree))
+                                 (progn
+                                   (cond ((consp tree)
+                                          (unless (memq tree scanned)
+                                            (push tree scanned)
+                                            (locally 
+                                                (declare (type cons tree))
+                                              (let* ((orig (car tree))
+                                                     (new (circle-subst orig)))
+                                                (unless (eq orig new)
+                                                  (rplaca tree new))
+                                                (setq orig (cdr tree)
+                                                      new (circle-subst orig))
+                                                (unless (eq orig new)
+                                                  (rplacd tree new))))))
+                                         ((let* ((typecode (typecode tree)))
+                                            (declare (type (unsigned-byte 8) typecode))
+                                            (or (= typecode target::subtag-simple-vector)
+                                                (= typecode target::subtag-struct)
+                                                (= typecode target::subtag-arrayH)))
+                                          (unless (memq tree scanned)
+                                            (push tree scanned)
+                                            (let* ((n (uvsize tree)))
+                                              (declare (fixnum n))
+                                              (do* ((i (if (eql (typecode tree) target::subtag-struct) 1 0) (1+ i)))
+                                                   ((= i n))
+                                                (declare (fixnum i))
+                                                (let* ((old (%svref tree i))
+                                                       (new (circle-subst old)))
+                                               (unless (eq old new)
+                                                 (setf (%svref tree i) new))))))))
+                                   tree))))
+                      (declare (dynamic-extent #'circle-subst))
+                      (circle-subst form)))))))))
+
+
+

release/1.5/source/lisp-kernel/macros.h

@@ -91 +91 @@
 #define TCR_INTERRUPT_LEVEL(tcr) \
   (((signed_natural *)((tcr)->tlb_pointer))[INTERRUPT_LEVEL_BINDING_INDEX])
-#endif
 
 #ifdef WINDOWS
@@ -115 +114 @@
 #define DECIMAL "%ld"
 #endif
+
+#endif /* __macros __ */

release/1.5/source/lisp-kernel/pmcl-kernel.c

@@ -933 +933 @@
 #endif
 
-char *
-case_inverted_path(char *path)
-{
-  char *copy = strdup(path), *base = copy, *work = copy, c;
-  if (copy == NULL) {
-    return NULL;
-  }
-  while(*work) {
-    if (*work++ == '/') {
-      base = work;
-    }
-  }
-  work = base;
-  while ((c = *work) != '\0') {
-    if (islower(c)) {
-      *work++ = toupper(c);
-    } else {
-      *work++ = tolower(c);
-    }
-  }
-  return copy;
-}
-/* 
-   The underlying file system may be case-insensitive (e.g., HFS),
-   so we can't just case-invert the kernel's name.
-   Tack ".image" onto the end of the kernel's name.  Much better ...
-*/
 #ifdef WINDOWS
 wchar_t *
@@ -972 +945 @@
 default_image_name(char *orig)
 {
-#ifdef WINDOWS
-  char *path = chop_exe_suffix(orig);
-#else
   char *path = orig;
-#endif
   char *image_name = path_by_appending_image(path);
-#if !defined(WINDOWS) && !defined(DARWIN)
-  if (!probe_file(image_name)) {
-    char *legacy = case_inverted_path(path);
-    if (probe_file(legacy)) {
-      image_name = legacy;
-    }
-  }
-#endif
   return image_name;
 }