PROBE-FILE or similar, which drops the truename into your lap."
;; Deal with a module which is already in the map. If its state is a
- ;; file-location then it's in progress and we have a cyclic dependency.
+ ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
(let ((module (gethash truename *module-map*)))
- (cond ((typep (module-state module) 'file-location)
+ (cond ((null module))
+ ((typep (module-state module) 'file-location)
(error "Module ~A already being imported at ~A"
pathname (module-state module)))
(module
(with-default-error-location (lexer)
(next-char lexer)
(next-token lexer)
- (parse-module lexer *module*)))))))
+ (parse-module lexer)))))))
;;;--------------------------------------------------------------------------
;;; Module parsing protocol.
(defgeneric parse-module-declaration (tag lexer pset)
(:method (tag lexer pset)
- (error "Unexpected module declaration ~(~A~)" tag)))
+ (error "Unexpected module declaration ~(~A~)" tag))
+ (:method :before (tag lexer pset)
+ (next-token lexer)))
(defun parse-module (lexer)
"Main dispatching for module parser.
Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
- ;; A little fancy footwork is required because `class' is a reserved word.
(loop
- (flet ((dispatch (tag pset)
- (next-token lexer)
- (parse-module-declaration tag lexer pset)
- (check-unused-properties pset)))
- (restart-case
- (case (token-type lexer)
- (:eof (return))
- (#\; (next-token lexer))
- (t (let ((pset (parse-property-set lexer)))
- (case (token-type lexer)
- (:id (dispatch (string-to-symbol (token-value lexer)
- :keyword)
- pset))
- (t (error "Unexpected token ~A: ignoring"
- (format-token lexer)))))))
- (continue ()
- :report "Ignore the error and continue parsing."
- nil)))))
+ (restart-case
+ (case (token-type lexer)
+ (:eof (return))
+ (#\; (next-token lexer))
+ (t (let ((pset (parse-property-set lexer)))
+ (case (token-type lexer)
+ (:id (let ((tag (intern (frob-case (token-value lexer))
+ :keyword)))
+ (parse-module-declaration tag lexer pset)
+ (check-unused-properties pset)))
+ (t (error "Unexpected token ~A: ignoring"
+ (format-token lexer)))))))
+ (continue ()
+ :report "Ignore the error and continue parsing."
+ nil))))
;;;--------------------------------------------------------------------------
;;; Type definitions.
(defclass type-item ()
- ((name :initarg :name :type string :reader type-name)))
+ ((name :initarg :name :type string :reader type-name))
+ (:documentation
+ "A note that a module exports a type.
+
+ We can only export simple types, so we only need to remember the name.
+ The magic simple-type cache will ensure that we get the same type object
+ when we do the import."))
(defmethod module-import ((item type-item))
(let* ((name (type-name item))
(defmethod module-import ((class sod-class))
(record-sod-class class))
+(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
+ "module-decl ::= `typename' id-list `;'"
+ (loop (let ((name (require-token lexer :id)))
+ (unless name (return))
+ (if (gethash name *type-map*)
+ (cerror* "Type `~A' already defined" name)
+ (add-to-module *module* (make-instance 'type-item :name name)))
+ (unless (require-token lexer #\, :errorp nil) (return))))
+ (require-token lexer #\;))
+
+;;;--------------------------------------------------------------------------
+;;; Fragments.
+
+(defclass code-fragment-item ()
+ ((fragment :initarg :fragment :type c-fragment :reader code-fragment)
+ (reason :initarg :reason :type keyword :reader code-fragment-reason)
+ (name :initarg :name :type t :reader code-fragment-name)
+ (constraints :initarg :constraints :type list
+ :reader code-fragment-constraints))
+ (:documentation
+ "A plain fragment of C to be dropped in at top-level."))
+
+(defmacro define-fragment ((reason name) &body things)
+ (categorize (thing things)
+ ((constraints (listp thing))
+ (frags (typep thing '(or string c-fragment))))
+ (when (null frags)
+ (error "Missing code fragment"))
+ (when (cdr frags)
+ (error "Multiple code fragments"))
+ `(add-to-module
+ *module*
+ (make-instance 'code-fragment-item
+ :fragment ',(car frags)
+ :name ,name
+ :reason ,reason
+ :constraints (list ,@(mapcar (lambda (constraint)
+ (cons 'list constraint))
+ constraints))))))
+
+(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
+ "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
+ constraint ::= id*"
+ (labels ((parse-constraint ()
+ (let ((list nil))
+ (loop (let ((id (require-token lexer :id
+ :errorp (null list))))
+ (unless id (return))
+ (push id list)))
+ (nreverse list)))
+ (parse-constraints ()
+ (let ((list nil))
+ (when (require-token lexer #\[ :errorp nil)
+ (loop (let ((constraint (parse-constraint)))
+ (push constraint list)
+ (unless (require-token lexer #\, :errorp nil)
+ (return))))
+ (require-token lexer #\]))
+ (nreverse list)))
+ (keywordify (id)
+ (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
+ (let* ((reason (prog1 (keywordify (require-token lexer :id))
+ (require-token lexer #\:)))
+ (name (keywordify (require-token lexer :id)))
+ (constraints (parse-constraints)))
+ (when (require-token lexer #\{ :consumep nil)
+ (let ((frag (scan-c-fragment lexer '(#\}))))
+ (next-token lexer)
+ (require-token lexer #\})
+ (add-to-module *module*
+ (make-instance 'code-fragment-item
+ :name name
+ :reason reason
+ :constraints constraints
+ :fragment frag)))))))
+
;;;--------------------------------------------------------------------------
;;; File searching.
(error "Error searching for ~A ~S: ~A" what (namestring name) error))
(:no-error (path probe)
(cond ((null path)
- (error "Failed to find ~A ~S" what name))
+ (error "Failed to find ~A ~S" what (namestring name)))
(t
(funcall thunk path probe))))))
(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
+ "module-decl ::= `import' string `;'"
(let ((name (require-token lexer :string)))
(when name
(find-file lexer
(require-token lexer #\;))))
(defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
+ "module-decl ::= `load' string `;'"
(let ((name (require-token lexer :string)))
(when name
(find-file lexer
path error)))))
(require-token lexer #\;))))
+;;;--------------------------------------------------------------------------
+;;; Lisp escapes.
+
+(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
+ "module-decl ::= `lisp' s-expression `;'"
+ (let ((form (with-lexer-stream (stream lexer) (read stream t))))
+ (eval form))
+ (next-token lexer)
+ (require-token lexer #\;))
+
+;;;--------------------------------------------------------------------------
+;;; Class declarations.
+
+(defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
+ "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
+ (let* ((location (file-location lexer))
+ (name (let ((name (require-token lexer :id)))
+ (make-class-type name location)
+ (when (require-token lexer #\; :errorp nil)
+ (return-from parse-module-declaration))
+ name))
+ (supers (when (require-token lexer #\: :errorp nil)
+ (let ((list nil))
+ (loop (let ((id (require-token lexer :id)))
+ (unless id (return))
+ (push id list)
+ (unless (require-token lexer #\, :errorp nil)
+ (return))))
+ (nreverse list))))
+ (class (make-sod-class name (mapcar #'find-sod-class supers)
+ pset location))
+ (nick (sod-class-nickname class)))
+ (require-token lexer #\{)
+
+ (labels ((parse-item ()
+ "Try to work out what kind of item this is. Messy."
+ (let* ((pset (parse-property-set lexer))
+ (location (file-location lexer)))
+ (cond ((declaration-specifier-p lexer)
+ (let ((declspec (parse-c-type lexer)))
+ (multiple-value-bind (type name)
+ (parse-c-declarator lexer declspec :dottedp t)
+ (cond ((null type)
+ nil)
+ ((consp name)
+ (parse-method type (car name) (cdr name)
+ pset location))
+ ((typep type 'c-function-type)
+ (parse-message type name pset location))
+ (t
+ (parse-slots declspec type name
+ pset location))))))
+ ((not (eq (token-type lexer) :id))
+ (cerror* "Expected <class-item>; found ~A (skipped)"
+ (format-token lexer))
+ (next-token lexer))
+ ((string= (token-value lexer) "class")
+ (next-token lexer)
+ (parse-initializers #'make-sod-class-initializer
+ pset location))
+ (t
+ (parse-initializers #'make-sod-instance-initializer
+ pset location)))))
+
+ (parse-method (type nick name pset location)
+ "class-item ::= declspec+ dotted-declarator -!- method-body
+
+ method-body ::= `{' c-fragment `}' | `extern' `;'
+
+ The dotted-declarator must describe a function type."
+ (let ((body (cond ((eq (token-type lexer) #\{)
+ (prog1 (scan-c-fragment lexer '(#\}))
+ (next-token lexer)
+ (require-token lexer #\})))
+ ((and (eq (token-type lexer) :id)
+ (string= (token-value lexer)
+ "extern"))
+ (next-token lexer)
+ (require-token lexer #\;)
+ nil)
+ (t
+ (cerror* "Expected <method-body>; ~
+ found ~A"
+ (format-token lexer))))))
+ (make-sod-method class nick name type body pset location)))
+
+ (parse-message (type name pset location)
+ "class-item ::= declspec+ declarator -!- (method-body | `;')
+
+ The declarator must describe a function type."
+ (make-sod-message class name type pset location)
+ (unless (require-token lexer #\; :errorp nil)
+ (parse-method type nick name nil location)))
+
+ (parse-initializer-body ()
+ "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
+ (let ((char (lexer-char lexer)))
+ (loop
+ (when (or (null char) (not (whitespace-char-p char)))
+ (return))
+ (setf char (next-char lexer)))
+ (cond ((eql char #\{)
+ (next-char lexer)
+ (let ((frag (scan-c-fragment lexer '(#\}))))
+ (next-token lexer)
+ (require-token lexer #\})
+ (values :compound frag)))
+ (t
+ (let ((frag (scan-c-fragment lexer '(#\, #\;))))
+ (next-token lexer)
+ (values :simple frag))))))
+
+ (parse-slots (declspec type name pset location)
+ "class-item ::=
+ declspec+ init-declarator [`,' init-declarator-list] `;'
+
+ init-declarator ::= declarator -!- [initializer]"
+ (loop
+ (make-sod-slot class name type pset location)
+ (when (eql (token-type lexer) #\=)
+ (multiple-value-bind (kind form) (parse-initializer-body)
+ (make-sod-instance-initializer class nick name
+ kind form nil
+ location)))
+ (unless (require-token lexer #\, :errorp nil)
+ (return))
+ (setf (values type name)
+ (parse-c-declarator lexer declspec)
+ location (file-location lexer)))
+ (require-token lexer #\;))
+
+ (parse-initializers (constructor pset location)
+ "class-item ::= [`class'] -!- slot-initializer-list `;'
+
+ slot-initializer ::= id `.' id initializer"
+ (loop
+ (let ((nick (prog1 (require-token lexer :id)
+ (require-token lexer #\.)))
+ (name (require-token lexer :id)))
+ (require-token lexer #\=)
+ (multiple-value-bind (kind form)
+ (parse-initializer-body)
+ (funcall constructor class nick name kind form
+ pset location)))
+ (unless (require-token lexer #\, :errorp nil)
+ (return))
+ (setf location (file-location lexer)))
+ (require-token lexer #\;)))
+
+ (loop
+ (when (require-token lexer #\} :errorp nil)
+ (return))
+ (parse-item)))
+
+ (finalize-sod-class class)
+ (add-to-module *module* class)))
+
;;;--------------------------------------------------------------------------
;;; Modules.
;;
;; Process an in-line Lisp form immediately.
(:lisp
- (let ((form (with-lexer-stream (stream lexer)
- (read stream t))))
- (handler-case
- (eval form)
- (error (error)
- (cerror* "Error in Lisp form: ~A" error))))
+
(next-token lexer)
(go top))
~mdw / sod / blobdiff