Changeset 13613
- Timestamp:
- Apr 11, 2010, 8:54:45 PM (10 years ago)
- Location:
- release/1.5/source
- Files:
-
- 5 edited
Legend:
- Unmodified
- Added
- Removed
-
release/1.5/source
- Property svn:mergeinfo changed
/trunk/source merged: 13589-13592
- Property svn:mergeinfo changed
-
release/1.5/source/lib/defstruct.lisp
r13344 r13613 111 111 print-function))) 112 112 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)))))) 113 123 114 124 (defun sd-refname-pos-in-included-struct (sd name) … … 137 147 (let ((offset (ssd-offset slot))) 138 148 (unless (eql pos offset) 139 ; This should be a style-warning149 ;; This should be a style-warning 140 150 (warn "Accessor ~s at different position than in included structure" 141 151 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))))))) 149 160 (nreverse stuff))) 150 161 -
release/1.5/source/lib/read.lisp
r13067 r13613 196 196 197 197 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 198 223 (set-dispatch-macro-character #\# #\# 199 224 #'(lambda (stream char arg) … … 202 227 nil 203 228 (if arg 204 (let ((pair ( assoc arg %read-objects%))) ;Not assq, could be bignum!229 (let ((pair (get-read-object arg))) 205 230 (if pair 206 (cdr pair) 231 (let* ((cell (cdr pair))) 232 (setf (car cell) t) 233 (cdr cell)) 207 234 (%err-disp $xnordlbl arg))) 208 235 (%err-disp $xrdndarg char))))) … … 214 241 (cond (*read-suppress* (values)) 215 242 ((null arg) (%err-disp $xrdndarg char)) 216 ((assoc arg %read-objects%) ;Not assq, could be bignum!217 (%err-disp $xduprdlbl arg))218 243 (t (setq lab (cons arg nil)) 219 (push (%rplacd lab lab) %read-objects%) 244 (%rplacd lab (cons nil lab)) 245 (note-read-object lab) 220 246 (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. 222 248 (%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 91 91 #define TCR_INTERRUPT_LEVEL(tcr) \ 92 92 (((signed_natural *)((tcr)->tlb_pointer))[INTERRUPT_LEVEL_BINDING_INDEX]) 93 #endif94 93 95 94 #ifdef WINDOWS … … 115 114 #define DECIMAL "%ld" 116 115 #endif 116 117 #endif /* __macros __ */ -
release/1.5/source/lisp-kernel/pmcl-kernel.c
r13376 r13613 933 933 #endif 934 934 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 */962 935 #ifdef WINDOWS 963 936 wchar_t * … … 972 945 default_image_name(char *orig) 973 946 { 974 #ifdef WINDOWS975 char *path = chop_exe_suffix(orig);976 #else977 947 char *path = orig; 978 #endif979 948 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 #endif988 949 return image_name; 989 950 }
Note: See TracChangeset
for help on using the changeset viewer.