(define-pluggable-parser module code (scanner pset)
;; `code' id `:' item-name [constraints] `{' c-fragment `}'
+ ;; `code' id `:' constraints `;'
;;
;; constraints ::= `[' list[constraint] `]'
;; constraint ::= item-name+
(item ()
(parse (or (kw)
(seq (#\( (names (list (:min 1) (kw))) #\))
- names)))))
+ names))))
+ (constraints ()
+ (parse (seq (#\[
+ (constraints
+ (list ()
+ (list (:min 1)
+ (error (:ignore-unconsumed t) (item)
+ (skip-until () :id #\( #\, #\])))
+ #\,))
+ #\])
+ constraints)))
+ (fragment ()
+ (parse-delimited-fragment scanner #\{ #\})))
(parse (seq ("code"
(reason (must (kw)))
(nil (must #\:))
- (name (must (item)))
- (constraints (? (seq (#\[
- (constraints
- (list ()
- (list (:min 1)
- (error (:ignore-unconsumed t)
- (item)
- (skip-until ()
- :id #\( #\, #\])))
- #\,))
- #\])
- constraints)))
- (fragment (parse-delimited-fragment scanner #\{ #\})))
- (when name
- (add-to-module *module*
- (make-instance 'code-fragment-item
- :fragment fragment
- :constraints constraints
- :reason reason
- :name name))))))))
+ (item (or (seq ((constraints (constraints))
+ (nil (must #\;)))
+ (make-instance 'code-fragment-item
+ :reason reason
+ :constraints constraints))
+ (seq ((name (must (item)))
+ (constraints (? (constraints)))
+ (fragment (fragment)))
+ (and name
+ (make-instance 'code-fragment-item
+ :reason reason
+ :constraints constraints
+ :name name
+ :fragment fragment))))))
+ (when item (add-to-module *module* item)))))))
;;; External files.
(export 'read-module)
-(defun read-module (pathname &key (truename nil truep) location)
+(defun read-module (pathname &key (truename nil truep) location stream)
"Parse the file at PATHNAME as a module, returning it.
This is the main entry point for parsing module files. You may well know
(make-pathname :type "SOD" :case :common)))
(unless truep (setf truename (truename pathname)))
(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
- :filename (namestring pathname)))
- (scanner (make-instance 'sod-token-scanner
- :char-scanner char-scanner)))
- (with-default-error-location (scanner)
- (with-parser-context (token-scanner-context :scanner scanner)
- (multiple-value-bind (result winp consumedp)
- (parse (skip-many ()
- (seq ((pset (parse-property-set scanner))
- (nil (error ()
- (plug module scanner pset)
- (skip-until (:keep-end nil)
- #\; #\}))))
- (check-unused-properties pset))))
- (declare (ignore consumedp))
- (unless winp (syntax-error scanner result)))))))))
-
-(define-pluggable-parser module test (scanner pset)
- ;; `demo' string `;'
- (declare (ignore pset))
- (with-parser-context (token-scanner-context :scanner scanner)
- (parse (seq ("demo" (string (must :string)) (nil (must #\;)))
- (format t ";; DEMO ~S~%" string)))))
+ (flet ((parse (f-stream)
+ (let* ((char-scanner
+ (make-instance 'charbuf-scanner
+ :stream f-stream
+ :filename (namestring pathname)))
+ (scanner (make-instance 'sod-token-scanner
+ :char-scanner char-scanner)))
+ (with-default-error-location (scanner)
+ (with-parser-context
+ (token-scanner-context :scanner scanner)
+ (multiple-value-bind (result winp consumedp)
+ (parse (skip-many ()
+ (seq ((pset (parse-property-set scanner))
+ (nil (error ()
+ (plug module scanner pset)
+ (skip-until (:keep-end nil)
+ #\; #\}))))
+ (check-unused-properties pset))))
+ (declare (ignore consumedp))
+ (unless winp (syntax-error scanner result))))))))
+ (if stream (parse stream)
+ (with-open-file (stream pathname :direction :input)
+ (parse stream))))))
(define-pluggable-parser module file (scanner pset)
;; `import' string `;'
(declare (ignore pset))
(flet ((common (name type what thunk)
(when name
- (find-file scanner
+ (find-file (pathname (scanner-filename scanner))
(merge-pathnames name
(make-pathname :type type
:case :common))
(lambda (path true)
(handler-case
(let ((module (read-module path
- :truename true)))
+ :truename true
+ :location
+ (file-location
+ scanner))))
(when module
(module-import module)
+ (pushnew path (module-files *module*))
(pushnew module
(module-dependencies
*module*))))
(common name "LISP" "Lisp file"
(lambda (path true)
(handler-case
- (load true :verbose nil :print nil)
+ (progn
+ (pushnew path (module-files *module*))
+ (load true :verbose nil :print nil))
(error (error)
(cerror* "Error loading Lisp file ~S: ~A"
path error)))))))))))
(nil (must #\;)))
(eval sexp)))))
+;;;--------------------------------------------------------------------------
+;;; Static instances.
+
+(define-pluggable-parser module instance (scanner pset)
+ ;; `instance' id id list[slot-initializer] `;'
+ (with-parser-context (token-scanner-context :scanner scanner)
+ (let ((duff nil)
+ (floc nil)
+ (empty-pset (make-property-set)))
+ (parse (seq ("instance"
+ (class (seq ((class-name (must :id)))
+ (setf floc (file-location scanner))
+ (restart-case (find-sod-class class-name)
+ (continue ()
+ (setf duff t)
+ nil))))
+ (name (must :id))
+ (inits (? (seq (#\:
+ (inits (list (:min 0)
+ (seq ((nick (must :id))
+ #\.
+ (name (must :id))
+ (value
+ (parse-delimited-fragment
+ scanner #\= '(#\, #\;)
+ :keep-end t)))
+ (make-sod-instance-initializer
+ class nick name value
+ empty-pset
+ :add-to-class nil
+ :location scanner))
+ #\,)))
+ inits)))
+ #\;)
+ (unless duff
+ (acond ((find-if (lambda (item)
+ (and (typep item 'static-instance)
+ (string= (static-instance-name item)
+ name)))
+ (module-items *module*))
+ (cerror*-with-location floc
+ "Instance with name `~A' ~
+ already defined."
+ name)
+ (info-with-location (file-location it)
+ "Previous definition was ~
+ here."))
+ (t
+ (add-to-module *module*
+ (make-static-instance class name
+ inits
+ pset
+ floc))))))))))
+
;;;--------------------------------------------------------------------------
;;; Class declarations.
(parse (seq ((make (or (seq ("init") #'make-sod-class-initfrag)
(seq ("teardown") #'make-sod-class-tearfrag)))
(frag (parse-delimited-fragment scanner #\{ #\})))
- (funcall make class frag pset scanner)))))
+ (funcall make class frag pset :location scanner)))))
(define-pluggable-parser class-item initargs (scanner class pset)
;; initarg-item ::= `initarg' declspec+ list[init-declarator]
(make-sod-user-initarg class
(cdr declarator)
(car declarator)
- pset init scanner))
+ pset
+ :default init
+ :location scanner))
#\,))
(nil (must #\;)))))))
(continue ()
(setf duff t)
(list (find-sod-class "SodObject"))))))
- superclasses))
+ (find-duplicates (lambda (first second)
+ (declare (ignore second))
+ (setf duff t)
+ (cerror* "Class `~A' has duplicate ~
+ direct superclass `~A'"
+ name first))
+ superclasses)
+ (delete-duplicates superclasses)))
(synthetic-name (or name
(let ((var (synthetic-name)))
(unless pset
(unless (pset-get pset "nick")
(add-property pset "nick" var :type :id))
var)))
- (class (make-sod-class synthetic-name superclasses pset scanner))
+ (class (make-sod-class synthetic-name superclasses pset
+ :location scanner))
(nick (sod-class-nickname class)))
(labels ((must-id ()
;; Don't allow a method-body here if the message takes a
;; varargs list, because we don't have a name for the
;; `va_list' parameter.
- (let ((message (make-sod-message class name type
- sub-pset scanner)))
+ (let ((message (make-sod-message class name type sub-pset
+ :location scanner)))
(if (varargs-message-p message)
(parse #\;)
(parse (or #\; (parse-method-item sub-pset
scanner #\{ #\}))))
(restart-case
(make-sod-method class sub-nick name type
- body sub-pset scanner)
+ body sub-pset
+ :location scanner)
(continue () :report "Continue")))))
(parse-initializer ()
(flet ((make-it (name type init)
(restart-case
(progn
- (make-sod-slot class name type
- sub-pset scanner)
+ (make-sod-slot class name type sub-pset
+ :location scanner)
(when init
- (make-sod-instance-initializer class
- nick name
- init
- sub-pset
- scanner)))
+ (make-sod-instance-initializer
+ class nick name init sub-pset
+ :location scanner)))
(continue () :report "Continue"))))
(parse (and (error ()
(seq ((init (? (parse-initializer))))
(restart-case
(funcall constructor class
name-a name-b init
- sub-pset scanner)
+ sub-pset
+ :location scanner)
(continue () :report "Continue")))
(skip-until () #\, #\;))
#\,)
~mdw / sod / blobdiff