X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsharpm.lisp;h=049145d4d964cb8683439e8d89cb0980fc8663de;hb=4dc4761909992ceb346d003f3fb19e5c837ee985;hp=273a6a6004ca2081a52e2fa7f96a604b69167e12;hpb=80cee3cf18d09202aa30ab957e08c5759e573bbe;p=sbcl.git diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index 273a6a6..049145d 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -119,37 +119,73 @@ (%reader-error stream "non-list following #S: ~S" body)) (unless (symbolp (car body)) (%reader-error stream "Structure type is not a symbol: ~S" (car body))) - (let ((class (sb!xc:find-class (car body) nil))) - (unless (typep class 'sb!xc:structure-class) + (let ((classoid (find-classoid (car body) nil))) + (unless (typep classoid 'structure-classoid) (%reader-error stream "~S is not a defined structure type." (car body))) (let ((def-con (dd-default-constructor (layout-info - (class-layout class))))) + (classoid-layout classoid))))) (unless def-con (%reader-error stream "The ~S structure does not have a default constructor." (car body))) - (apply (fdefinition def-con) (rest body)))))) + (when (and (atom (rest body)) + (not (null (rest body)))) + (%reader-error + stream "improper list for #S: ~S." body)) + (apply (fdefinition def-con) + (loop for tail on (rest body) by #'cddr + with slot-name = (and (consp tail) (car tail)) + do (progn + (when (null (cdr tail)) + (%reader-error + stream + "the arglist for the ~S constructor in #S ~ + has an odd length: ~S." + (car body) (rest body))) + (when (or (atom (cdr tail)) + (and (atom (cddr tail)) + (not (null (cddr tail))))) + (%reader-error + stream + "the arglist for the ~S constructor in #S ~ + is improper: ~S." + (car body) (rest body))) + (when (not (typep (car tail) 'string-designator)) + (%reader-error + stream + "a slot name in #S is not a string ~ + designator: ~S." + slot-name)) + (when (not (keywordp slot-name)) + (warn 'structure-initarg-not-keyword + :format-control + "in #S ~S, the use of non-keywords ~ + as slot specifiers is deprecated: ~S." + :format-arguments + (list (car body) slot-name)))) + collect (intern (string (car tail)) *keyword-package*) + collect (cadr tail))))))) ;;;; reading numbers: the #B, #C, #O, #R, and #X readmacros (defun sharp-B (stream sub-char numarg) (ignore-numarg sub-char numarg) - (sharp-r stream sub-char 2)) + (sharp-R stream sub-char 2)) (defun sharp-C (stream sub-char numarg) (ignore-numarg sub-char numarg) ;; The next thing had better be a list of two numbers. (let ((cnum (read stream t nil t))) - (when *read-suppress* (return-from sharp-c nil)) + (when *read-suppress* (return-from sharp-C nil)) (if (and (listp cnum) (= (length cnum) 2)) (complex (car cnum) (cadr cnum)) (%reader-error stream "illegal complex number format: #C~S" cnum)))) (defun sharp-O (stream sub-char numarg) (ignore-numarg sub-char numarg) - (sharp-r stream sub-char 8)) + (sharp-R stream sub-char 8)) (defun sharp-R (stream sub-char radix) (cond (*read-suppress* @@ -172,7 +208,7 @@ (defun sharp-X (stream sub-char numarg) (ignore-numarg sub-char numarg) - (sharp-r stream sub-char 16)) + (sharp-R stream sub-char 16)) ;;;; reading circular data: the #= and ## readmacros @@ -184,12 +220,13 @@ ;; substitutes in arrays and structures as well as lists. The first arg is an ;; alist of the things to be replaced assoc'd with the things to replace them. (defun circle-subst (old-new-alist tree) - (cond ((not (typep tree '(or cons (array t) structure-object))) + (cond ((not (typep tree + '(or cons (array t) structure-object standard-object))) (let ((entry (find tree old-new-alist :key #'second))) (if entry (third entry) tree))) ((null (gethash tree *sharp-equal-circle-table*)) (setf (gethash tree *sharp-equal-circle-table*) t) - (cond ((typep tree 'structure-object) + (cond ((typep tree '(or structure-object standard-object)) (do ((i 1 (1+ i)) (end (%instance-length tree))) ((= i end)) @@ -313,35 +350,41 @@ (defun sharp-vertical-bar (stream sub-char numarg) (ignore-numarg sub-char numarg) - (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream + (handler-bind + ((character-decoding-error + #'(lambda (decoding-error) + (declare (ignorable decoding-error)) + (style-warn "Character decoding error in a #|-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) + (invoke-restart 'attempt-resync)))) + (let ((stream (in-synonym-of stream))) + (if (ansi-stream-p stream) + (prepare-for-fast-read-char stream + (do ((level 1) + (prev (fast-read-char) char) + (char (fast-read-char) (fast-read-char))) + (()) + (cond ((and (char= prev #\|) (char= char #\#)) + (setq level (1- level)) + (when (zerop level) + (done-with-fast-read-char) + (return (values))) + (setq char (fast-read-char))) + ((and (char= prev #\#) (char= char #\|)) + (setq char (fast-read-char)) + (setq level (1+ level)))))) + ;; fundamental-stream (do ((level 1) - (prev (fast-read-char) char) - (char (fast-read-char) (fast-read-char))) + (prev (read-char stream t) char) + (char (read-char stream t) (read-char stream t))) (()) (cond ((and (char= prev #\|) (char= char #\#)) (setq level (1- level)) (when (zerop level) - (done-with-fast-read-char) (return (values))) - (setq char (fast-read-char))) + (setq char (read-char stream t))) ((and (char= prev #\#) (char= char #\|)) - (setq char (fast-read-char)) - (setq level (1+ level)))))) - ;; fundamental-stream - (do ((level 1) - (prev (read-char stream t) char) - (char (read-char stream t) (read-char stream t))) - (()) - (cond ((and (char= prev #\|) (char= char #\#)) - (setq level (1- level)) - (when (zerop level) - (return (values))) - (setq char (read-char stream t))) - ((and (char= prev #\#) (char= char #\|)) - (setq char (read-char stream t)) - (setq level (1+ level)))))))) + (setq char (read-char stream t)) + (setq level (1+ level))))))))) ;;;; a grab bag of other sharp readmacros: #', #:, and #. @@ -407,8 +450,8 @@ (set-dispatch-macro-character #\# #\C #'sharp-C) (set-dispatch-macro-character #\# #\c #'sharp-C) (set-dispatch-macro-character #\# #\| #'sharp-vertical-bar) - (set-dispatch-macro-character #\# #\p #'sharp-p) - (set-dispatch-macro-character #\# #\P #'sharp-p) + (set-dispatch-macro-character #\# #\p #'sharp-P) + (set-dispatch-macro-character #\# #\P #'sharp-P) (set-dispatch-macro-character #\# #\) #'sharp-illegal) (set-dispatch-macro-character #\# #\< #'sharp-illegal) (set-dispatch-macro-character #\# #\Space #'sharp-illegal)