X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/048d0b2d143b6a491ac73eed6ab972e97774391c..a42893dda5f4dd2b89fbfe4e497da261159225ca:/src/module-parse.lisp?ds=sidebyside diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 5d26760..f6d69ee 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -7,7 +7,7 @@ ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Sensble Object Design, an object system for C. +;;; This file is part of the Sensible Object Design, an object system for C. ;;; ;;; SOD is free software; you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License as published by @@ -28,8 +28,6 @@ ;;;-------------------------------------------------------------------------- ;;; Toplevel syntax. -(export 'module) - ;;; Type names. (define-pluggable-parser module typename (scanner pset) @@ -50,32 +48,43 @@ ;;; Fragments. (define-pluggable-parser module code (scanner pset) - ;; `code' id `:' id [constraints] `{' c-fragment `}' + ;; `code' id `:' item-name [constraints] `{' c-fragment `}' ;; ;; constrains ::= `[' constraint-list `]' - ;; constraint ::= id+ + ;; constraint ::= item-name+ + ;; item-name ::= id | `(' id+ `)' (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) - (parse (seq ("code" - (reason :id) - #\: - (name :id) - (constraints (? (seq (#\[ - (constraints (list (:min 1) - (list (:min 1) :id) - #\,)) - #\]) - constraints))) - (fragment (parse-delimited-fragment scanner #\{ #\}))) - (add-to-module *module* (make-instance 'code-fragment-item - :fragment fragment - :constraints constraints - :reason reason - :name name)))))) + (labels ((kw () + (parse (seq ((kw :id)) + (intern (frob-identifier kw) 'keyword)))) + (item () + (parse (or (kw) + (seq (#\( (names (list (:min 1) (kw))) #\)) + names))))) + (parse (seq ("code" + (reason (kw)) + #\: + (name (item)) + (constraints (? (seq (#\[ + (constraints (list (:min 1) + (list (:min 1) + (item)) + #\,)) + #\]) + constraints))) + (fragment (parse-delimited-fragment scanner #\{ #\}))) + (add-to-module *module* + (make-instance 'code-fragment-item + :fragment fragment + :constraints constraints + :reason reason + :name name))))))) ;;; External files. -(defun read-module (pathname &key (truename (truename pathname)) location) +(export 'read-module) +(defun read-module (pathname &key (truename nil truep) location) "Parse the file at PATHNAME as a module, returning it. This is the main entry point for parsing module files. You may well know @@ -86,6 +95,9 @@ `file-location' object, though it might be anything other than `t' which can be printed in the event of circular imports." + (setf pathname (merge-pathnames pathname + (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)) @@ -143,6 +155,29 @@ (cerror* "Error loading Lisp file ~S: ~A" path error))))))))))) +;;; Setting properties. + +(define-pluggable-parser module set (scanner pset) + ;; `set' property-list `;' + (with-parser-context (token-scanner-context :scanner scanner) + (parse (and "set" + (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)) + (setf (p-seenp prop) t)) + pset)) + (parse (skip-many (:min 0) + (error (:ignore-unconsumed t) + (parse-property scanner module-pset) + (skip-until (:keep-end t) #\, #\;)) + #\,)))) + #\;)))) + ;;; Lisp escape. (define-pluggable-parser module lisp (scanner pset) @@ -162,6 +197,17 @@ ;;;-------------------------------------------------------------------------- ;;; Class declarations. +(export 'class-item) + +(define-pluggable-parser class-item initfrags (scanner class pset) + ;; raw-class-item ::= frag-keyword `{' c-fragment `}' + ;; frag-keyword ::= `init' | `teardown' + (with-parser-context (token-scanner-context :scanner scanner) + (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))))) + (defun parse-class-body (scanner pset name supers) ;; class-body ::= `{' class-item* `}' ;; @@ -183,7 +229,8 @@ ;; names. (parse-declarator scanner base-type - :centre (parser () + :keywordp t + :kernel (parser () (seq ((name-a :id) (name-b (? (seq (#\. (id :id)) id)))) (if name-b (cons name-a name-b) @@ -192,9 +239,16 @@ (parse-message-item (sub-pset type name) ;; message-item ::= ;; declspec+ declarator -!- (method-body | `;') - (make-sod-message class name type sub-pset scanner) - (parse (or #\; (parse-method-item sub-pset - type nick name)))) + ;; + ;; 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))) + (if (varargs-message-p message) + (parse #\;) + (parse (or #\; (parse-method-item sub-pset + type nick name)))))) (parse-method-item (sub-pset type sub-nick name) ;; method-item ::= @@ -208,17 +262,12 @@ body sub-pset scanner)))) (parse-initializer () - ;; initializer ::= `=' c-fragment | `=' `{' c-fragment `}' + ;; initializer ::= `=' c-fragment ;; - ;; Return (VALUE-KIND . VALUE-FORM), ready for passing to a - ;; `sod-initializer' constructor. - (parse (or (peek (seq (#\= (frag (parse-delimited-fragment - scanner #\{ #\}))) - (cons :compound frag))) - (seq ((frag (parse-delimited-fragment - scanner #\= '(#\; #\,) - :keep-end t))) - (cons :simple frag))))) + ;; Return a VALUE, ready for passing to a `sod-initializer' + ;; constructor. + (parse-delimited-fragment scanner #\= (list #\, #\;) + :keep-end t)) (parse-slot-item (sub-pset base-type type name) ;; slot-item ::= @@ -232,8 +281,7 @@ sub-pset scanner) (when init (make-sod-instance-initializer - class nick name (car init) (cdr init) - sub-pset scanner))) + class nick name init sub-pset scanner))) (skip-many () (seq (#\, (ds (parse-declarator scanner @@ -243,8 +291,7 @@ sub-pset scanner) (when init (make-sod-instance-initializer - class nick (cdr ds) - (car init) (cdr init) + class nick (cdr ds) init sub-pset scanner)))) #\;))) @@ -257,8 +304,7 @@ (seq ((name-a :id) #\. (name-b :id) (init (parse-initializer))) (funcall constructor class - name-a name-b - (car init) (cdr init) + name-a name-b init sub-pset scanner)) #\,) #\;))) @@ -292,6 +338,7 @@ ;; | method-item ;; | slot-item ;; | initializer-item + ;; | initfrag-item ;; ;; Most of the above begin with declspecs and a declarator ;; (which might be dotted). So we parse that here and @@ -315,10 +362,9 @@ (parse (seq (#\{ (nil (skip-many () (seq ((sub-pset (parse-property-set scanner)) - (nil (error () - (parse-raw-class-item sub-pset)))) + (nil (parse-raw-class-item sub-pset))) (check-unused-properties sub-pset)))) - #\}) + (nil (error () #\}))) (finalize-sod-class class) (add-to-module *module* class)))))))