X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/8152ead4c5c5980414d1a4f21a98e851cc25c9b1..refs/heads/mdw/progfmt:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index c5b28a6..43a49ad 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -52,6 +52,7 @@ (define-pluggable-parser module code (scanner pset) ;; `code' id `:' item-name [constraints] `{' c-fragment `}' + ;; `code' id `:' constraints `;' ;; ;; constraints ::= `[' list[constraint] `]' ;; constraint ::= item-name+ @@ -64,35 +65,42 @@ (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 @@ -107,33 +115,29 @@ (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 `;' @@ -141,7 +145,7 @@ (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)) @@ -153,9 +157,13 @@ (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*)))) @@ -170,7 +178,9 @@ (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))))))))))) @@ -215,6 +225,60 @@ (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. (export 'class-item) @@ -226,7 +290,7 @@ (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] @@ -243,7 +307,9 @@ (make-sod-user-initarg class (cdr declarator) (car declarator) - pset init scanner)) + pset + :default init + :location scanner)) #\,)) (nil (must #\;))))))) @@ -260,6 +326,21 @@ (with-parser-context (token-scanner-context :scanner scanner) (when name (make-class-type name)) (let* ((duff (null name)) + (superclasses + (let ((superclasses (restart-case + (mapcar #'find-sod-class + (or supers (list "SodObject"))) + (continue () + (setf duff t) + (list (find-sod-class "SodObject")))))) + (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 @@ -267,14 +348,8 @@ (unless (pset-get pset "nick") (add-property pset "nick" var :type :id)) var))) - (class (make-sod-class synthetic-name - (restart-case - (mapcar #'find-sod-class - (or supers (list "SodObject"))) - (continue () - (setf duff t) - (list (find-sod-class "SodObject")))) - pset scanner)) + (class (make-sod-class synthetic-name superclasses pset + :location scanner)) (nick (sod-class-nickname class))) (labels ((must-id () @@ -305,8 +380,8 @@ ;; 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 @@ -322,7 +397,8 @@ 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 () @@ -342,14 +418,12 @@ (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)))) @@ -380,7 +454,8 @@ (restart-case (funcall constructor class name-a name-b init - sub-pset scanner) + sub-pset + :location scanner) (continue () :report "Continue"))) (skip-until () #\, #\;)) #\,)