--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Builtin module provides basic definitions
+;;;
+;;; (c) 2009 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Simple Object Definition system.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Output of class instances.
+
+(defun output-imprint-function (class stream)
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__imprint(void *p)
+{
+ struct ~A *sod__obj = p;
+
+ ~:{sod__obj.~A._vt = &~A;~:^~% ~}
+ return (p);
+}~2%"
+ class
+ (ilayout-struct-tag class)
+ (mapcar (lambda (ichain)
+ (list (sod-class-nickname (ichain-head ichain))
+ (vtable-name class (ichain-head ichain))))
+ (ilayout-ichains ilayout)))))
+
+(defun output-init-function (class stream)
+ ;; FIXME this needs a metaobject protocol
+ (let ((ilayout (sod-class-ilayout class)))
+ (format stream "~&~:
+static void *~A__init(void *p)
+{
+ struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
+ class
+ (ilayout-struct-tag class))
+ (dolist (ichain (ilayout-ichains ilayout))
+ (let ((ich (format nil "sod__obj.~A"
+ (sod-class-nickname (ichain-head ichain)))))
+ (dolist (item (ichain-body ichain))
+ (etypecase item
+ (vtable-pointer
+ (format stream " ~A._vt = &~A;~%"
+ ich (vtable-name class (ichain-head ichain))))
+ (islots
+ (let ((isl (format nil "~A.~A"
+ ich
+ (sod-class-nickname (islots-class item)))))
+ (dolist (slot (islots-slots item))
+ (let ((dslot (effective-slot-direct-slot slot))
+ (init (effective-slot-initializer slot)))
+ (when init
+ (ecase (sod-initializer-value-kind init)
+ (:single
+ (format stream " ~A = ~A;~%"
+ isl (sod-initializer-value-form slot)))
+ (:compound
+ (format stream " ~A = (~A)~A;~%"
+ isl (sod-slot-type dslot)
+ (sod-initializer-value-form slot)))))))))))))
+ (format stream "~&~:
+ return (p);
+}~2%")))
+
+(defun output-supers-vector (class stream)
+ (let ((supers (sod-class-direct-superclasses class)))
+ (when supers
+ (format stream "~&~:
+static const SodClass *const ~A__supers[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class supers))))
+
+(defun output-cpl-vector (class stream)
+ (format stream "~&~:
+static const SodClass *const ~A__cpl[] = {
+ ~{~A__class~^,~% ~}
+};~2%"
+ class (sod-class-precedence-list class)))
+
+(defun output-chains-vector (class stream)
+ (let ((chains (sod-class-chains class)))
+ (format stream "~&~:
+~1@*~:{static const SodClass *const ~A__chain_~A[] = {
+~{ ~A__class~^,~%~}
+};~:^~2%~}
+
+~0@*static const struct sod_chain ~A__chains[] = {
+~:{ { ~3@*~A,
+ ~0@*&~A__chain_~A,
+ ~4@*offsetof(struct ~A, ~A),
+ (const struct sod_vtable *)&~A,
+ sizeof(struct ~A) }~:^,~%~}
+};~2%"
+ class ;0
+ (mapcar (lambda (chain) ;1
+ (let* ((head (sod-class-chain-head (car chain)))
+ (chain-nick (sod-class-nickname head)))
+ (list class chain-nick ;0 1
+ (reverse chain) ;2
+ (length chain) ;3
+ (ilayout-struct-tag class) chain-nick ;4 5
+ (vtable-name class head) ;6
+ (ichain-struct-tag class head)))) ;7
+ chains))))
+
+(defclass sod-class-slot (sod-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader sod-slot-initializer-function)
+ (prepare-function :initarg :prepare-function :type (or symbol function)
+ :reader sod-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on SodClass.
+
+ These slots need class-specific initialization. It's easier to keep all
+ of the information (name, type, and how to initialize them) about these
+ slots in one place, so that's what we do here."))
+
+(defmethod shared-initialize :after
+ ((slot sod-class-slot) slot-names &key pset)
+ (declare (ignore slot-names))
+ (default-slot (slot 'initializer-function)
+ (get-property pset :initializer-function t nil))
+ (default-slot (slot 'prepare-function)
+ (get-property pset :prepare-function t nil)))
+
+(defclass sod-class-effective-slot (effective-slot)
+ ((initializer-function :initarg :initializer-function
+ :type (or symbol function)
+ :reader effective-slot-initializer-function)
+ (prepare-function :initarg :prepare-function :type (or symbol function)
+ :reader effective-slot-prepare-function))
+ (:documentation
+ "Special class for slots defined on SodClass.
+
+ This class ignores any explicit initializers and computes initializer
+ values using the slot's INIT-FUNC slot and a magical protocol during
+ metaclass instance construction."))
+
+(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
+ (make-instance 'sod-class-effective-slot
+ :slot slot
+ :initializer-function (sod-slot-initializer-function slot)
+ :prepare-function (sod-slot-prepare-function slot)
+ :initializer (find-slot-initializer class slot)))
+
+;;;--------------------------------------------------------------------------
+;;; Class slots table.
+
+(defparameter *sod-class-slots*
+ `(
+
+ ;; Basic informtion.
+ ("name" ,(c-type const-string)
+ :initializer-function
+ ,(lambda (class)
+ (prin1-to-string (sod-class-name class))))
+ ("nick" ,(c-type const-string)
+ :initializer-function
+ ,(lambda (class)
+ (prin1-to-string (sod-class-nickname class))))
+
+ ;; Instance allocation and initialization.
+ ("instsz" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "sizeof(struct ~A)"
+ (ilayout-struct-tag class))))
+ ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
+ :prepare-function 'output-imprint-function
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__imprint" class)))
+ ("init" ,(c-type (* (fun (* void) ("p" (* void)))))
+ :prepare-function 'output-init-function
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__init" class)))
+
+ ;; Superclass structure.
+ ("n_supers" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-direct-superclasses class))))
+ ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
+ :prepare-function 'output-supers-vector
+ :initializer-function
+ ,(lambda (class)
+ (if (sod-class-direct-superclasses class)
+ (format nil "~A__supers" class)
+ 0)))
+ ("n_cpl" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-precedence-list class))))
+ ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
+ :prepare-function 'output-cpl-vector
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__cpl" class)))
+
+ ;; Chain structure.
+ ("link" ,(c-type (* (class "SodClass" :const)))
+ :initializer-function
+ ,(lambda (class)
+ (let ((link (sod-class-chain-link class)))
+ (if link
+ (format nil "~A__class" link)
+ 0))))
+ ("head" ,(c-type (* (class "SodClass" :const)))
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__class" (sod-class-chain-head class))))
+ ("level" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (position class (reverse (sod-class-chain class)))))
+ ("n_chains" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (length (sod-class-chains class))))
+ ("chains" ,(c-type (* (struct "sod_chain" :const)))
+ :prepare-function 'output-chains-vector
+ :initializer-function
+ ,(lambda (class)
+ (format nil "~A__chains" class)))
+
+ ;; Class-specific layout.
+ ("off_islots" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "offsetof(struct ~A, ~A)"
+ (ichain-struct-tag class
+ (sod-class-chain-head class))
+ (sod-class-nickname class))))
+ ("islotsz" ,(c-type size-t)
+ :initializer-function
+ ,(lambda (class)
+ (format nil "sizeof(struct ~A)"
+ (islots-struct-tag class))))))
+
+;;;--------------------------------------------------------------------------
+;;; Bootstrapping the class graph.
+
+(defun bootstrap-classes (module)
+ (let* ((sod-object (make-sod-class "SodObject" nil
+ (make-property-set :nick 'obj)))
+ (sod-class (make-sod-class "SodClass" (list sod-object)
+ (make-property-set :nick 'cls)))
+ (classes (list sod-object sod-class)))
+
+ ;; Sort out the recursion.
+ (setf (slot-value sod-class 'chain-link) sod-object)
+ (dolist (class classes)
+ (setf (slot-value class 'metaclass) sod-class))
+
+ ;; Predeclare the class types.
+ (dolist (class classes)
+ (make-class-type (sod-class-name class)))
+
+ ;; Attach the class slots.
+ (loop for (name type . plist) in *sod-class-slots*
+ do (make-sod-slot sod-class name type
+ (apply #'make-property-set
+ :lisp-class 'sod-class-slot
+ plist)))
+
+ ;; These classes are too closely intertwined. We must partially finalize
+ ;; them together by hand. This is cloned from FINALIZE-SOD-CLASS.
+ (dolist (class classes)
+ (with-slots (class-precedence-list chain-head chain chains) class
+ (setf class-precedence-list (compute-cpl class))
+ (setf (values chain-head chain chains) (compute-chains class))))
+
+ ;; Done.
+ (dolist (class classes)
+ (finalize-sod-class class)
+ (add-to-module module class))))
+
+(defun make-builtin-module ()
+ (let ((module (make-instance 'module
+ :name (make-pathname :name "BUILTIN"
+ :type "SOD"
+ :case :common)
+ :state nil))
+ (*type-map* (make-hash-table :test #'equal)))
+ (dolist (name '("va_list" "size_t" "ptrdiff_t"))
+ (add-to-module module (make-instance 'type-item :name name)))
+ (bootstrap-classes module)
+ module))
+
+(defun reset-builtin-module ()
+ (setf *builtin-module* (make-builtin-module))
+ (module-import *builtin-module*))
+
+;;;--------------------------------------------------------------------------
+;;; Testing.
+
+#+test
+(define-sod-class "AbstractStack" ("SodObject")
+ :nick 'abstk
+ (message "emptyp" (fun int))
+ (message "push" (fun void ("item" (* void))))
+ (message "pop" (fun (* void)))
+ (method "abstk" "pop" (fun void) #{
+ assert(!me->_vt.emptyp());
+ }
+ :role :before))
+
+;;;----- That's all, folks --------------------------------------------------
(check-method-type method message type)))
;;;--------------------------------------------------------------------------
-;;; Bootstrapping the class graph.
-;;;
-;;; FIXME: This is a daft place for this function. It's also accumulating
-;;; all of the magic associated with initializing class instances.
-
-(defun output-imprint-function (class stream)
- (let ((ilayout (sod-class-ilayout class)))
- (format stream "~&~:
-static void *~A__imprint(void *p)
-{
- struct ~A *sod__obj = p;
-
- ~:{sod__obj.~A._vt = &~A;~:^~% ~}
- return (p);
-}~2%"
- class
- (ilayout-struct-tag class)
- (mapcar (lambda (ichain)
- (list (sod-class-nickname (ichain-head ichain))
- (vtable-name class (ichain-head ichain))))
- (ilayout-ichains ilayout)))))
-
-(defun output-init-function (class stream)
- ;; FIXME this needs a metaobject protocol
- (let ((ilayout (sod-class-ilayout class)))
- (format stream "~&~:
-static void *~A__init(void *p)
-{
- struct ~A *sod__obj = ~0@*~A__imprint(p);~2%"
- class
- (ilayout-struct-tag class))
- (dolist (ichain (ilayout-ichains ilayout))
- (let ((ich (format nil "sod__obj.~A"
- (sod-class-nickname (ichain-head ichain)))))
- (dolist (item (ichain-body ichain))
- (etypecase item
- (vtable-pointer
- (format stream " ~A._vt = &~A;~%"
- ich (vtable-name class (ichain-head ichain))))
- (islots
- (let ((isl (format nil "~A.~A"
- ich
- (sod-class-nickname (islots-class item)))))
- (dolist (slot (islots-slots item))
- (let ((dslot (effective-slot-direct-slot slot))
- (init (effective-slot-initializer slot)))
- (when init
- (ecase (sod-initializer-value-kind init)
- (:single
- (format stream " ~A = ~A;~%"
- isl (sod-initializer-value-form slot)))
- (:compound
- (format stream " ~A = (~A)~A;~%"
- isl (sod-slot-type dslot)
- (sod-initializer-value-form slot)))))))))))))
- (format stream "~&~:
- return (p);
-}~2%")))
-
-(defun output-supers-vector (class stream)
- (let ((supers (sod-class-direct-superclasses class)))
- (when supers
- (format stream "~&~:
-static const SodClass *const ~A__supers[] = {
- ~{~A__class~^,~% ~}
-};~2%"
- class supers))))
-
-(defun output-cpl-vector (class stream)
- (format stream "~&~:
-static const SodClass *const ~A__cpl[] = {
- ~{~A__class~^,~% ~}
-};~2%"
- class (sod-class-precedence-list class)))
-
-(defun output-chains-vector (class stream)
- (let ((chains (sod-class-chains class)))
- (format stream "~&~:
-~1@*~:{static const SodClass *const ~A__chain_~A[] = {
-~{ ~A__class~^,~%~}
-};~:^~2%~}
-
-~0@*static const struct sod_chain ~A__chains[] = {
-~:{ { ~3@*~A,
- ~0@*&~A__chain_~A,
- ~4@*offsetof(struct ~A, ~A),
- (const struct sod_vtable *)&~A,
- sizeof(struct ~A) }~:^,~%~}
-};~2%"
- class ;0
- (mapcar (lambda (chain) ;1
- (let* ((head (sod-class-chain-head (car chain)))
- (chain-nick (sod-class-nickname head)))
- (list class chain-nick ;0 1
- (reverse chain) ;2
- (length chain) ;3
- (ilayout-struct-tag class) chain-nick ;4 5
- (vtable-name class head) ;6
- (ichain-struct-tag class head)))) ;7
- chains))))
-
-(defparameter *sod-class-slots*
- `(
-
- ;; Basic informtion.
- ("name" ,(c-type const-string)
- :initializer-function
- ,(lambda (class)
- (prin1-to-string (sod-class-name class))))
- ("nick" ,(c-type const-string)
- :initializer-function
- ,(lambda (class)
- (prin1-to-string (sod-class-nickname class))))
-
- ;; Instance allocation and initialization.
- ("instsz" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (format nil "sizeof(struct ~A)"
- (ilayout-struct-tag class))))
- ("imprint" ,(c-type (* (fun (* void) ("p" (* void)))))
- :prepare-function 'output-imprint-function
- :initializer-function
- ,(lambda (class)
- (format nil "~A__imprint" class)))
- ("init" ,(c-type (* (fun (* void) ("p" (* void)))))
- :prepare-function 'output-init-function
- :initializer-function
- ,(lambda (class)
- (format nil "~A__init" class)))
-
- ;; Superclass structure.
- ("n_supers" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (length (sod-class-direct-superclasses class))))
- ("supers" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function 'output-supers-vector
- :initializer-function
- ,(lambda (class)
- (if (sod-class-direct-superclasses class)
- (format nil "~A__supers" class)
- 0)))
- ("n_cpl" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (length (sod-class-precedence-list class))))
- ("cpl" ,(c-type (* (* (class "SodClass" :const) :const)))
- :prepare-function 'output-cpl-vector
- :initializer-function
- ,(lambda (class)
- (format nil "~A__cpl" class)))
-
- ;; Chain structure.
- ("link" ,(c-type (* (class "SodClass" :const)))
- :initializer-function
- ,(lambda (class)
- (let ((link (sod-class-chain-link class)))
- (if link
- (format nil "~A__class" link)
- 0))))
- ("head" ,(c-type (* (class "SodClass" :const)))
- :initializer-function
- ,(lambda (class)
- (format nil "~A__class" (sod-class-chain-head class))))
- ("level" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (position class (reverse (sod-class-chain class)))))
- ("n_chains" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (length (sod-class-chains class))))
- ("chains" ,(c-type (* (struct "sod_chain" :const)))
- :prepare-function 'output-chains-vector
- :initializer-function
- ,(lambda (class)
- (format nil "~A__chains" class)))
-
- ;; Class-specific layout.
- ("off_islots" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (format nil "offsetof(struct ~A, ~A)"
- (ichain-struct-tag class
- (sod-class-chain-head class))
- (sod-class-nickname class))))
- ("islotsz" ,(c-type size-t)
- :initializer-function
- ,(lambda (class)
- (format nil "sizeof(struct ~A)"
- (islots-struct-tag class))))))
-
-(defclass sod-class-slot (sod-slot)
- ((initializer-function :initarg :initializer-function
- :type (or symbol function)
- :reader sod-slot-initializer-function)
- (prepare-function :initarg :prepare-function
- :type (or symbol function)
- :reader sod-slot-prepare-function))
- (:documentation
- "Special class for slots defined on sod_object.
-
- These slots need class-specific initialization. It's easier to keep all
- of the information (name, type, and how to initialize them) about these
- slots in one place, so that's what we do here."))
-
-(defmethod shared-initialize :after
- ((slot sod-class-slot) slot-names &key pset)
- (declare (ignore slot-names))
- (default-slot (slot 'initializer-function)
- (get-property pset :initializer-function t nil))
- (default-slot (slot 'prepare-function)
- (get-property pset :prepare-function t nil)))
-
-(defclass sod-class-effective-slot (effective-slot)
- ((initializer-function :initarg :initializer-function
- :type (or symbol function)
- :reader effective-slot-initializer-function)
- (prepare-function :initarg :prepare-function
- :type (or symbol function)
- :reader effective-slot-prepare-function))
- (:documentation
- "Special class for slots defined on slot_object.
-
- This class ignores any explicit initializers and computes initializer
- values using the slot's INIT-FUNC slot and a magical protocol during
- metaclass instance construction."))
-
-(defmethod compute-effective-slot ((class sod-class) (slot sod-class-slot))
- (make-instance 'sod-class-effective-slot
- :slot slot
- :initializer-function (sod-slot-initializer-function slot)
- :prepare-function (sod-slot-prepare-function slot)
- :initializer (find-slot-initializer class slot)))
-
-(defun bootstrap-classes ()
- (let* ((sod-object (make-sod-class "SodObject" nil
- (make-property-set :nick 'obj)))
- (sod-class (make-sod-class "SodClass" (list sod-object)
- (make-property-set :nick 'cls)))
- (classes (list sod-object sod-class)))
-
- ;; Sort out the recursion.
- (setf (slot-value sod-class 'chain-link) sod-object)
- (dolist (class classes)
- (setf (slot-value class 'metaclass) sod-class))
-
- ;; Predeclare the class types.
- (dolist (class classes)
- (make-class-type (sod-class-name class)))
-
- ;; Attach the class slots.
- (loop for (name type . plist) in *sod-class-slots*
- do (make-sod-slot sod-class name type
- (apply #'make-property-set
- :lisp-class 'sod-class-slot
- plist)))
-
- ;; These classes are too closely intertwined. We must partially finalize
- ;; them together by hand. This is cloned from FINALIZE-SOD-CLASS.
- (dolist (class classes)
- (with-slots (class-precedence-list chain-head chain chains) class
- (setf class-precedence-list (compute-cpl class))
- (setf (values chain-head chain chains) (compute-chains class))))
-
- ;; Done.
- (dolist (class classes)
- (finalize-sod-class class)
- (record-sod-class class))))
-
-;;;--------------------------------------------------------------------------
;;; Builder macro.
(defmacro define-sod-class (name (&rest superclasses) &body body)
(defparameter *sod-keywords*
(make-keyword-table
- ;; Words with important meanings to us.
- "class"
- "import" "load" "lisp" "typename"
- "code"
- "extern"
-
;; Words with a meaning to C's type system.
"char" "int" "float" "void"
"long" "short" "signed" "unsigned" "double"
(cl:in-package #:sod)
;;;--------------------------------------------------------------------------
+;;; Module basics.
+
+(defclass module ()
+ ((name :initarg :name :type pathname :reader module-name)
+ (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset)
+ (items :initarg :items :initform nil :type list :accessor module-items)
+ (dependencies :initarg :dependencies :initform nil
+ :type list :accessor module-dependencies)
+ (state :initarg :state :initform nil :accessor module-state))
+ (:documentation
+ "A module is a container for the definitions made in a source file.
+
+ Modules are the fundamental units of translation. The main job of a
+ module is to remember which definitions it contains, so that they can be
+ translated and written to output files. The module contains the following
+ handy bits of information:
+
+ * A (path) name, which is the filename we used to find it. The default
+ output filenames are derived from this. (We use the file's truename
+ as the hash key to prevent multiple inclusion, and that's a different
+ thing.)
+
+ * A property list containing other useful things.
+
+ * A list of the classes defined in the source file.
+
+ * Lists of C fragments to be included in the output header and C source
+ files.
+
+ * A list of other modules that this one depends on.
+
+ Modules are usually constructed by the PARSE-MODULE function, which is in
+ turn usually invoked by IMPORT-MODULE, though there's nothing to stop
+ fancy extensions building modules programmatically."))
+
+(defparameter *module* nil
+ "The current module under construction.
+
+ This is always an instance of MODULE. Once we've finished constructing
+ it, we'll call CHANGE-CLASS to turn it into an instance of whatever type
+ is requested in the module's :LISP-CLASS property.")
+
+(defgeneric module-import (object)
+ (:documentation
+ "Import definitions into the current environment.
+
+ Instructs the OBJECT to import its definitions into the current
+ environment. Modules pass the request on to their constituents. There's
+ a default method which does nothing at all.
+
+ It's not usual to modify the current module. Inserting things into the
+ *TYPE-MAP* is a good plan.")
+ (:method (object) nil))
+
+(defgeneric add-to-module (module item)
+ (:documentation
+ "Add ITEM to the MODULE's list of accumulated items.
+
+ The module items participate in the MODULE-IMPORT and ADD-OUTPUT-HOOKS
+ protocols."))
+
+(defgeneric finalize-module (module)
+ (:documentation
+ "Finalizes a module, setting everything which needs setting.
+
+ This isn't necessary if you made the module by hand. If you've
+ constructed it incrementally, then it might be a good plan. In
+ particular, it will change the class (using CHANGE-CLASS) of the module
+ according to the class choice set in the module's :LISP-CLASS property.
+ This has the side effects of calling SHARED-INITIALIZE, setting the
+ module's state to T, and checking for unrecognized properties. (Therefore
+ subclasses should add a method to SHARED-INITIALIZE should take care of
+ looking at interesting properties, just to make sure they're ticked
+ off.)"))
+
+(defmethod module-import ((module module))
+ (dolist (item (module-items module))
+ (module-import item)))
+
+(defmethod add-to-module ((module module) item)
+ (setf (module-items module)
+ (nconc (module-items module) (list item)))
+ (module-import item))
+
+(defmethod shared-initialize :after ((module module) slot-names &key pset)
+ "Tick off known properties on the property set."
+ (declare (ignore slot-names))
+ (when pset
+ (dolist (prop '(:guard))
+ (get-property pset prop nil))))
+
+(defmethod finalize-module ((module module))
+ (let* ((pset (module-pset module))
+ (class (get-property pset :lisp-class :symbol 'module)))
+
+ ;; Always call CHANGE-CLASS, even if it's the same one; this will
+ ;; exercise the property-set fiddling in SHARED-INITIALIZE and we can
+ ;; catch unknown-property errors.
+ (change-class module class :state t :pset pset)
+ (check-unused-properties pset)
+ module))
+
+;;;--------------------------------------------------------------------------
+;;; Module importing.
+
+(defun read-module (pathname &key (truename (truename pathname)) location)
+ "Reads a module.
+
+ The module is returned if all went well; NIL is returned if an error
+ occurred.
+
+ The PATHNAME argument is the file to read. TRUENAME should be the file's
+ truename, if known: often, the file will have been searched for using
+ 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.
+ (let ((module (gethash truename *module-map*)))
+ (cond ((typep (module-state module) 'file-location)
+ (error "Module ~A already being imported at ~A"
+ pathname (module-state module)))
+ (module
+ (return-from read-module module))))
+
+ ;; Make a new module. Be careful to remove the module from the map if we
+ ;; didn't succeed in constructing it.
+ (let ((*module* (make-instance 'module
+ :name pathname
+ :state (file-location location)))
+ (*type-map* (make-hash-table :test #'equal)))
+ (module-import *builtin-module*)
+ (setf (gethash truename *module-map*) *module*)
+ (unwind-protect
+ (with-open-file (f-stream pathname :direction :input)
+ (let* ((*module* (make-instance 'module :name pathname))
+ (pai-stream (make-instance 'position-aware-input-stream
+ :stream f-stream
+ :file pathname))
+ (lexer (make-instance 'sod-lexer :stream pai-stream)))
+ (with-default-error-location (lexer)
+ (next-char lexer)
+ (next-token lexer)
+ (parse-module lexer *module*)
+ (finalize-module *module*))))
+ (unless (eq (module-state *module*) t)
+ (remhash truename *module-map*)))))
+
+;;;--------------------------------------------------------------------------
+;;; Module parsing protocol.
+
+(defgeneric parse-module-declaration (tag lexer pset)
+ (:method (tag lexer pset)
+ (error "Unexpected module declaration ~(~A~)" tag)))
+
+(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)))))
+
+;;;--------------------------------------------------------------------------
+;;; Type definitions.
+
+(defclass type-item ()
+ ((name :initarg :name :type string :reader type-name)))
+
+(defmethod module-import ((item type-item))
+ (let* ((name (type-name item))
+ (def (gethash name *type-map*))
+ (type (make-simple-type name)))
+ (cond ((not def)
+ (setf (gethash name *type-map*) type))
+ ((not (eq def type))
+ (error "Conflicting types `~A'" name)))))
+
+(defmethod module-import ((class sod-class))
+ (record-sod-class class))
+
+;;;--------------------------------------------------------------------------
;;; File searching.
(defparameter *module-dirs* nil
(t
(funcall thunk path probe))))))
+(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
+ (let ((name (require-token lexer :string)))
+ (when name
+ (find-file lexer
+ (merge-pathnames name
+ (make-pathname :type "SOD" :case :common))
+ "module"
+ (lambda (path true)
+ (handler-case
+ (let ((module (read-module path :truename true)))
+ (when module
+ (module-import module)
+ (pushnew module (module-dependencies *module*))))
+ (file-error (error)
+ (cerror* "Error reading module ~S: ~A"
+ path error)))))
+ (require-token lexer #\;))))
+
+(defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
+ (let ((name (require-token lexer :string)))
+ (when name
+ (find-file lexer
+ (merge-pathnames name
+ (make-pathname :type "LISP" :case :common))
+ "Lisp file"
+ (lambda (path true)
+ (handler-case (load true :verbose nil :print nil)
+ (error (error)
+ (cerror* "Error loading Lisp file ~S: ~A"
+ path error)))))
+ (require-token lexer #\;))))
+
;;;--------------------------------------------------------------------------
;;; Modules.
-(defclass module ()
- ((name :initarg :name
- :type pathname
- :accessor module-name)
- (plist :initform nil
- :initarg :plist
- :type list
- :accessor module-plist)
- (classes :initform nil
- :initarg :classes
- :type list
- :accessor module-classes)
- (source-fragments :initform nil
- :initarg :source-fragments
- :type list
- :accessor module-source-fragments)
- (header-fragments :initform nil
- :initarg :header-fragments
- :type list
- :accessor module-header-fragments)
- (dependencies :initform nil
- :initarg :dependencies
- :type list
- :accessor module-dependencies))
- (:documentation
- "A module is a container for the definitions made in a source file.
-
- Modules are the fundamental units of translation. The main job of a
- module is to remember which definitions it contains, so that they can be
- translated and written to output files. The module contains the following
- handy bits of information:
-
- * A (path) name, which is the filename we used to find it. The default
- output filenames are derived from this. (We use the file's truename
- as the hash key to prevent multiple inclusion, and that's a different
- thing.)
-
- * A property list containing other useful things.
-
- * A list of the classes defined in the source file.
-
- * Lists of C fragments to be included in the output header and C source
- files.
-
- * A list of other modules that this one depends on.
-
- Modules are usually constructed by the PARSE-MODULE function, which is in
- turn usually invoked by IMPORT-MODULE, though there's nothing to stop
- fancy extensions building modules programmatically."))
-
-(defun import-module (pathname &key (truename (truename pathname)))
- "Import a module.
-
- The module is returned if all went well; NIL is returned if an error
- occurred.
-
- The PATHNAME argument is the file to read. TRUENAME should be the file's
- truename, if known: often, the file will have been searched for using
- PROBE-FILE or similar, which drops the truename into your lap."
-
- (let ((module (gethash truename *module-map*)))
- (cond
-
- ;; The module's not there. (The *MODULE-MAP* never maps things to
- ;; NIL.)
- ((null module)
-
- ;; Mark the module as being in progress. Another attempt to import it
- ;; will fail.
- (setf (gethash truename *module-map*) :in-progress)
-
- ;; Be careful to restore the state of the module map on exit.
- (unwind-protect
-
- ;; Open the module file and parse it.
- (with-open-file (f-stream pathname :direction :input)
- (let* ((pai-stream (make-instance 'position-aware-input-stream
- :stream f-stream
- :file pathname))
- (lexer (make-instance 'sod-lexer :stream pai-stream)))
- (with-default-error-location (lexer)
- (restart-case
- (progn
- (next-char lexer)
- (next-token lexer)
- (setf module (parse-module lexer)))
- (continue ()
- :report "Ignore the import and continue"
- nil))))))
-
- ;; If we successfully parsed the module, then store it in the table;
- ;; otherwise remove it because we might want to try again. (That
- ;; might not work very well, but it could be worth a shot.)
- (if module
- (setf (gethash truename *module-map*) module)
- (remhash truename *module-map*)))
-
- ;; A module which is being read can't be included again.
- ((eql module :in-progress)
- (error "Cyclic module dependency involving module ~A" pathname))
-
- ;; A module which was successfully read. Just return it.
- (t
- module))))
-
+#+(or)
(defun parse-module (lexer)
"Parse a module from the given LEXER.
(next-token lexer)
(go top))
- ;; module-def : `import' string `;'
- ;;
- ;; Read another module of definitions from a file.
- (:import
- (next-token lexer)
- (let ((name (require-token lexer :string)))
- (when name
- (find-file lexer
- (merge-pathnames name (make-pathname
- :type "SOD"
- :case :common))
- "module"
- (lambda (path true)
- (handler-case
- (let ((module (import-module path
- :truename true)))
- (when module
- (push module deps)))
- (file-error (error)
- (cerror* "Error reading module ~S: ~A"
- path error)))))))
- (go semicolon))
-
- ;; module-def : `load' string `;'
- ;;
- ;; Load a Lisp extension from a file.
- (:load
- (next-token lexer)
- (let ((name (require-token lexer :string)))
- (when name
- (find-file lexer
- (merge-pathnames name
- (make-pathname :type "LISP"
- :case :common))
- "Lisp file"
- (lambda (path true)
- (handler-case (load true
- :verbose nil
- :print nil)
- (error (error)
- (cerror* "Error loading Lisp file ~S: ~A"
- path error)))))))
- (go semicolon))
-
;; module-def : `lisp' sexp
;;
;; Process an in-line Lisp form immediately.
(defun store-property
(pset name value &key (type (property-type value)) location)
"Store a property in PSET."
- (%pset-store pset
- (make-property name value :type type :location location)))
+ (pset-store pset
+ (make-property name value :type type :location location)))
(defun get-property (pset name type &optional default)
"Fetch a property from a property set.
If PSET is nil, then return DEFAULT."
- (let ((prop (and pset (%pset-get pset (property-key name)))))
+ (let ((prop (and pset (pset-get pset (property-key name)))))
(with-default-error-location ((and prop (p-location prop)))
(cond ((not prop)
(values default nil))
alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing
into the set."
- (do ((pset (%make-pset))
+ (do ((pset (make-pset))
(plist plist (cddr plist)))
((endp plist) pset)
(add-property pset (car plist) (cadr plist))))
(print-unreadable-object (pset stream :type t)
(pprint-logical-block (stream nil)
(let ((firstp t))
- (%pset-map (lambda (prop)
- (cond (firstp (setf firstp nil))
- (t (write-char #\space stream)
- (pprint-newline :linear stream)))
- (format stream "~:@<~S ~@_~S ~@_~S~:>"
- (p-name prop) (p-type prop) (p-value prop)))
- pset)))))
+ (pset-map (lambda (prop)
+ (cond (firstp (setf firstp nil))
+ (t (write-char #\space stream)
+ (pprint-newline :linear stream)))
+ (format stream "~:@<~S ~@_~S ~@_~S~:>"
+ (p-name prop) (p-type prop) (p-value prop)))
+ pset)))))
(defun check-unused-properties (pset)
"Issue errors about unused properties in PSET."
- (%pset-map (lambda (prop)
- (unless (p-seenp prop)
- (cerror*-with-location (p-location prop)
- "Unknown property `~A'"
- (p-name prop))))
- pset))
+ (when pset
+ (pset-map (lambda (prop)
+ (unless (p-seenp prop)
+ (cerror*-with-location (p-location prop)
+ "Unknown property `~A'"
+ (p-name prop))))
+ pset)))
;;;--------------------------------------------------------------------------
;;; Expression parser.
object. This is how we find classes by name: the C-CLASS-TYPE object has
a reference to the underlying SOD-CLASS instance.")
+(defparameter *builtin-module* nil
+ "Built-in module; populated later.")
+
;;;--------------------------------------------------------------------------
;;; Utilities.
(defparameter *clear-the-decks-functions*
'(reset-type-and-module-map
- populate-type-map
- bootstrap-classes))
+ reset-builtin-module))
(defun reset-type-and-module-map ()
"Reset the main hash tables, clearing the translator's state.
~mdw / sod / commitdiff