(define-module (pathname :location location :truename truename)
(with-open-file (f-stream pathname :direction :input)
(let* ((*readtable* (copy-readtable))
+ (*package* (find-package '#:sod-user))
(char-scanner (make-instance 'charbuf-scanner
:stream f-stream))
(scanner (make-instance 'sod-token-scanner
:char-scanner char-scanner)))
(with-default-error-location (scanner)
(with-parser-context (token-scanner-context :scanner scanner)
- (parse (skip-many ()
- (seq ((pset (parse-property-set scanner))
- (nil (error ()
- (plug module scanner pset))))
- (check-unused-properties pset))))))))))
+ (multiple-value-bind (result winp consumedp)
+ (parse (skip-many ()
+ (seq ((pset (parse-property-set scanner))
+ (nil (error ()
+ (plug module scanner pset))))
+ (check-unused-properties pset))))
+ (declare (ignore consumedp))
+ (unless winp (syntax-error scanner result)))))))))
(define-pluggable-parser module test (scanner pset)
;; `demo' string `;'
(lisp (let ((module-pset (module-pset *module*)))
(when pset
(pset-map (lambda (prop)
- (add-property module-pset
- (p-name prop)
- (p-value prop)
- :type (p-type prop)
- :location (p-location prop))
+ (add-property
+ module-pset
+ (p-name prop) (p-value prop)
+ :type (p-type prop)
+ :location (p-location prop))
(setf (p-seenp prop) t))
pset))
(parse (skip-many (:min 0)
(error (:ignore-unconsumed t)
- (parse-property scanner module-pset)
+ (parse-property scanner module-pset)
(skip-until (:keep-end t) #\, #\;))
#\,))))
#\;))))
;; class-item ::= property-set raw-class-item
(with-parser-context (token-scanner-context :scanner scanner)
(make-class-type name)
- (let* ((class (make-sod-class name (mapcar #'find-sod-class supers)
+ (let* ((duff nil)
+ (class (make-sod-class name
+ (restart-case
+ (mapcar #'find-sod-class supers)
+ (continue ()
+ (setf duff t)
+ (list (find-sod-class "SodObject"))))
pset scanner))
(nick (sod-class-nickname class)))
;; [`class'] -!- slot-initializer-list `;'
;;
;; slot-initializer ::= id `.' id [initializer]
- (let ((parse-init (if must-init-p
- #'parse-initializer
+ (let ((parse-init (if must-init-p #'parse-initializer
(parser () (? (parse-initializer))))))
(parse (and (skip-many ()
(seq ((name-a :id) #\. (name-b :id)
(when (consp name)
(cerror*-with-location
scanner
- "Method declarations must have function type.")
+ "Method declarations must have function type")
(setf name (cdr name)))
(parse-slot-item sub-pset base-type type name))
((consp name)
(car dc)
(cdr dc))))))
(and "class"
- (parse-initializer-item
- sub-pset t
+ (parse-initializer-item sub-pset t
#'make-sod-class-initializer))
- (parse-initializer-item
- sub-pset nil
+ (parse-initializer-item sub-pset nil
#'make-sod-instance-initializer)))))
(parse (seq (#\{
(nil (parse-raw-class-item sub-pset)))
(check-unused-properties sub-pset))))
(nil (error () #\})))
- (finalize-sod-class class)
- (add-to-module *module* class)))))))
+ (unless (finalize-sod-class class)
+ (setf duff t))
+ (unless duff
+ (add-to-module *module* class))))))))
(define-pluggable-parser module class (scanner pset)
- ;; `class' id [`:' id-list] class-body
+ ;; `class' id `:' id-list class-body
;; `class' id `;'
(with-parser-context (token-scanner-context :scanner scanner)
(parse (seq ("class"
(name :id)
(nil (or (seq (#\;)
(make-class-type name))
- (seq ((supers (? (seq (#\: (ids (list () :id #\,)))
- ids)))
+ (seq ((supers (seq (#\: (ids (list () :id #\,)))
+ ids))
(nil (parse-class-body
scanner
pset name supers)))))))))))