X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/239fa5bd3dff0b38b0cebdd3438311f21c24ba4f..5445420ed4158d4cd7aae4a4bb52f4a4e22ed1a2:/src/module-parse.lisp diff --git a/src/module-parse.lisp b/src/module-parse.lisp index f87c586..a339682 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,13 +28,11 @@ (in-package #:sod) ;;;-------------------------------------------------------------------------- ;;; Toplevel syntax. -(export 'module) - ;;; Type names. -(define-pluggable-parser module typename (scanner) - ;; `typename' ID ( `,' ID )* `;' - +(define-pluggable-parser module typename (scanner pset) + ;; `typename' id ( `,' id )* `;' + (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) (parse (and "typename" (skip-many (:min 1) @@ -49,30 +47,44 @@ (define-pluggable-parser module typename (scanner) ;;; Fragments. -(define-pluggable-parser module code (scanner) - ;; `code' ID `:' ID [ CONSTRAINTS ] `{' C-FRAGMENT `}' - +(define-pluggable-parser module code (scanner pset) + ;; `code' id `:' item-name [constraints] `{' c-fragment `}' + ;; + ;; constrains ::= `[' constraint-list `]' + ;; 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 @@ -83,28 +95,39 @@ (defun read-module (pathname &key (truename (truename pathname)) location) `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)) + (*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 () (plug module scanner))))))))) - -(define-pluggable-parser module test (scanner) - ;; `demo' STRING `;' + (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 `;' + (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) (parse (seq ("demo" (string :string) #\;) (format t ";; DEMO ~S~%" string))))) -(define-pluggable-parser module file (scanner) - ;; `import' STRING `;' - ;; `load' STRING `;' - +(define-pluggable-parser module file (scanner pset) + ;; `import' string `;' + ;; `load' string `;' + (declare (ignore pset)) (flet ((common (name type what thunk) (find-file scanner (merge-pathnames name @@ -136,11 +159,34 @@ (define-pluggable-parser module file (scanner) (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) +(define-pluggable-parser module lisp (scanner pset) ;; `lisp' s-expression `;' - + (declare (ignore pset)) (with-parser-context (token-scanner-context :scanner scanner) (parse (seq ((sexp (if (and (eql (token-type scanner) :id) (string= (token-value scanner) "lisp")) @@ -155,17 +201,217 @@ (define-pluggable-parser module lisp (scanner) ;;;-------------------------------------------------------------------------- ;;; Class declarations. -(define-pluggable-parser module class (scanner) - ;; `class' id [`:' id-list] `{' class-item* `}' +(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))))) + +(define-pluggable-parser class-item initargs (scanner class pset) + ;; initarg-item ::= `initarg' declspec+ init-declarator-list + ;; init-declarator ::= declarator [`=' initializer] + (with-parser-context (token-scanner-context :scanner scanner) + (parse (seq ("initarg" + (base-type (parse-c-type scanner)) + (nil (skip-many (:min 1) + (seq ((declarator (parse-declarator scanner + base-type)) + (init (? (parse-delimited-fragment + scanner #\= (list #\; #\,) + :keep-end t)))) + (make-sod-user-initarg class + (cdr declarator) + (car declarator) + pset init scanner)) + #\,)) + #\;))))) + +(defun parse-class-body (scanner pset name supers) + ;; class-body ::= `{' class-item* `}' + ;; + ;; class-item ::= property-set raw-class-item + (with-parser-context (token-scanner-context :scanner scanner) + (make-class-type name) + (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))) + + (labels ((parse-maybe-dotted-declarator (base-type) + ;; Parse a declarator or dotted-declarator, i.e., one whose + ;; centre is + ;; + ;; maybe-dotted-identifier ::= [id `.'] id + ;; + ;; A plain identifier is returned as a string, as usual; a + ;; dotted identifier is returned as a cons cell of the two + ;; names. + (parse-declarator + scanner base-type + :keywordp t + :kernel (parser () + (seq ((name-a :id) + (name-b (? (seq (#\. (id :id)) id)))) + (if name-b (cons name-a name-b) + name-a))))) + + (parse-message-item (sub-pset type name) + ;; message-item ::= + ;; declspec+ declarator -!- (method-body | `;') + ;; + ;; 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 ::= + ;; declspec+ dotted-declarator -!- method-body + ;; + ;; method-body ::= `{' c-fragment `}' | `extern' `;' + (parse (seq ((body (or (seq ("extern" #\;) nil) + (parse-delimited-fragment + scanner #\{ #\})))) + (make-sod-method class sub-nick name type + body sub-pset scanner)))) + + (parse-initializer () + ;; initializer ::= `=' c-fragment + ;; + ;; 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 ::= + ;; declspec+ declarator -!- [initializer] + ;; [`,' init-declarator-list] `;' + ;; + ;; init-declarator-list ::= + ;; declarator [initializer] [`,' init-declarator-list] + (parse (and (seq ((init (? (parse-initializer)))) + (make-sod-slot class name type + sub-pset scanner) + (when init + (make-sod-instance-initializer + class nick name init sub-pset scanner))) + (skip-many () + (seq (#\, + (ds (parse-declarator scanner + base-type)) + (init (? (parse-initializer)))) + (make-sod-slot class (cdr ds) (car ds) + sub-pset scanner) + (when init + (make-sod-instance-initializer + class nick (cdr ds) init + sub-pset scanner)))) + #\;))) + + (parse-initializer-item (sub-pset must-init-p constructor) + ;; initializer-item ::= + ;; [`class'] -!- slot-initializer-list `;' + ;; + ;; slot-initializer ::= id `.' id [initializer] + (let ((parse-init (if must-init-p #'parse-initializer + (parser () (? (parse-initializer)))))) + (parse (and (skip-many () + (seq ((name-a :id) #\. (name-b :id) + (init (funcall parse-init))) + (funcall constructor class + name-a name-b init + sub-pset scanner)) + #\,) + #\;)))) + + (class-item-dispatch (sub-pset base-type type name) + ;; Logically part of `parse-raw-class-item', but the + ;; indentation was getting crazy. We're currently at + ;; + ;; raw-class-item ::= + ;; declspec+ (declarator | dotted-declarator) -!- ... + ;; | other-items + ;; + ;; If the declarator is dotted then this must be a method + ;; definition; otherwise it might be a message or slot. + (cond ((not (typep type 'c-function-type)) + (when (consp name) + (cerror*-with-location + scanner + "Method declarations must have function type") + (setf name (cdr name))) + (parse-slot-item sub-pset base-type type name)) + ((consp name) + (parse-method-item sub-pset type + (car name) (cdr name))) + (t + (parse-message-item sub-pset type name)))) + + (parse-raw-class-item (sub-pset) + ;; raw-class-item ::= + ;; message-item + ;; | 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 + ;; dispatch based on what we find. + (parse (or (plug class-item scanner class sub-pset) + (peek + (seq ((ds (parse-c-type scanner)) + (dc (parse-maybe-dotted-declarator ds)) + (nil (commit)) + (nil (class-item-dispatch sub-pset + ds + (car dc) + (cdr dc)))))) + (and "class" + (parse-initializer-item sub-pset t + #'make-sod-class-initializer)) + (parse-initializer-item sub-pset nil + #'make-sod-instance-initializer))))) + + (parse (seq (#\{ + (nil (skip-many () + (seq ((sub-pset (parse-property-set scanner)) + (nil (parse-raw-class-item sub-pset))) + (check-unused-properties sub-pset)))) + (nil (error () #\}))) + (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 `;' (with-parser-context (token-scanner-context :scanner scanner) - (labels ((parse-item () - ;; class-item ::= property-set (parse (seq ("class" (name :id) - (supers (? (seq (#\: (supers (list (:min 1) :id #\,))) - supers))) - #\{ - + (nil (or (seq (#\;) + (make-class-type name)) + (seq ((supers (seq (#\: (ids (list () :id #\,))) + ids)) + (nil (parse-class-body + scanner + pset name supers))))))))))) ;;;----- That's all, folks --------------------------------------------------