From dea4d05507e59ab779ed4bb209e05971d87e260c Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Fri, 2 Jul 2010 10:11:35 +0100 Subject: [PATCH] Massive reorganization in progress. The code is a complete disaster area right now. --- .skelrc | 2 +- NOTES | 38 - builtin.lisp | 350 -------- class-builder.lisp | 505 ------------ class-finalize.lisp | 291 ------- class-layout.lisp | 657 --------------- combination.lisp | 129 --- cutting-room-floor.lisp | 195 ----- sod-backg.tex => doc/sod-backg.tex | 0 doc/sod-protocol.tex | 695 ++++++++++++++++ sod-tut.tex => doc/sod-tut.tex | 0 sod.tex => doc/sod.tex | 99 ++- .../standard-method-combination.svg | 0 emacs-hacks.el | 14 + layout.org | 141 ---- sod.c => lib/sod.c | 6 +- sod.h => lib/sod.h | 16 +- output.lisp | 259 ------ pre-reorg/builtin.lisp | 42 + pre-reorg/c-types.lisp | 79 ++ pre-reorg/class-builder.lisp | 129 +++ class-defs.lisp => pre-reorg/class-defs.lisp | 0 pre-reorg/class-finalize.lisp | 31 + pre-reorg/class-layout.lisp | 80 ++ class-output.lisp => pre-reorg/class-output.lisp | 201 +++-- pre-reorg/codegen.lisp | 89 +++ pre-reorg/combination.lisp | 34 + pre-reorg/cpl.lisp | 133 +++ pre-reorg/cutting-room-floor.lisp | 491 ++++++++++++ errors.lisp => pre-reorg/errors.lisp | 7 +- examples.lisp => pre-reorg/examples.lisp | 0 pre-reorg/foo.lisp | 2 + lex.lisp => pre-reorg/lex.lisp | 70 +- pre-reorg/methods.lisp | 43 + module-output.lisp => pre-reorg/module-output.lisp | 0 module.lisp => pre-reorg/module.lisp | 276 ------- pre-reorg/output.lisp | 63 ++ parse-c-types.lisp => pre-reorg/parse-c-types.lisp | 0 posn-stream.lisp => pre-reorg/posn-stream.lisp | 0 pset.lisp => pre-reorg/pset.lisp | 248 ------ pre-reorg/sift.lisp | 333 ++++++++ sod.asd => pre-reorg/sod.asd | 9 +- tables.lisp => pre-reorg/tables.lisp | 0 src/builtin.lisp | 306 +++++++ src/class-utilities.lisp | 199 +++++ src/classes.lisp | 445 +++++++++++ src/foo.lisp | 7 + src/impl-c-types-class.lisp | 145 ++++ c-types.lisp => src/impl-c-types.lisp | 545 ++++++------- cpl.lisp => src/impl-class-finalize.lisp | 331 +++++--- src/impl-class-layout.lisp | 395 +++++++++ src/impl-class-make.lisp | 240 ++++++ src/impl-codegen.lisp | 199 +++++ src/impl-lexer.lisp | 297 +++++++ methods.lisp => src/impl-method.lisp | 537 ++++--------- src/impl-module.lisp | 189 +++++ src/impl-output.lisp | 58 ++ src/impl-pset.lisp | 83 ++ src/lexer-bits.lisp | 98 +++ src/output-class.lisp | 576 +++++++++++++ src/package.lisp | 31 + src/parse-c-types.lisp | 314 ++++++++ src/parse-lexical.lisp | 198 +++++ src/parser/impl-floc.lisp | 47 ++ src/parser/impl-parser-expr.lisp | 219 +++++ src/parser/impl-parser-plug.lisp | 31 + src/parser/impl-parser.lisp | 166 ++++ src/parser/impl-scanner-charbuf.lisp | 433 ++++++++++ src/parser/impl-scanner-context.lisp | 88 ++ src/parser/impl-scanner-token.lisp | 78 ++ src/parser/impl-scanner.lisp | 120 +++ src/parser/impl-streams.lisp | 382 +++++++++ src/parser/opprec.lisp | 6 + package.lisp => src/parser/package.lisp | 14 +- src/parser/proto-floc.lisp | 299 +++++++ src/parser/proto-parser-expr.lisp | 253 ++++++ src/parser/proto-parser.lisp | 890 +++++++++++++++++++++ src/parser/proto-scanner.lisp | 258 ++++++ src/parser/proto-streams.lisp | 46 ++ src/parser/test-parser.lisp | 444 ++++++++++ src/parser/test-scanner-charbuf.lisp | 353 ++++++++ src/proto-c-types.lisp | 259 ++++++ src/proto-class-finalize.lisp | 96 +++ src/proto-class-layout.lisp | 320 ++++++++ src/proto-class-make.lisp | 293 +++++++ codegen.lisp => src/proto-codegen.lisp | 311 +++---- src/proto-lexer.lisp | 216 +++++ src/proto-method.lisp | 399 +++++++++ src/proto-module.lisp | 202 +++++ src/proto-output.lisp | 171 ++++ src/proto-pset.lisp | 320 ++++++++ src/scratch.lisp | 16 + src/sod-test.asd | 76 ++ src/sod.asd | 162 ++++ src/test-base.lisp | 58 ++ src/test-c-types.lisp | 235 ++++++ src/test-codegen.lisp | 121 +++ src/utilities.lisp | 690 ++++++++++++++++ chimaera.sod => test/chimaera.sod | 10 +- utilities.lisp | 411 ---------- 100 files changed, 14713 insertions(+), 4730 deletions(-) delete mode 100644 NOTES delete mode 100644 builtin.lisp delete mode 100644 class-builder.lisp delete mode 100644 class-finalize.lisp delete mode 100644 class-layout.lisp delete mode 100644 combination.lisp delete mode 100644 cutting-room-floor.lisp rename sod-backg.tex => doc/sod-backg.tex (100%) create mode 100644 doc/sod-protocol.tex rename sod-tut.tex => doc/sod-tut.tex (100%) rename sod.tex => doc/sod.tex (91%) rename standard-method-combination.svg => doc/standard-method-combination.svg (100%) create mode 100644 emacs-hacks.el delete mode 100644 layout.org rename sod.c => lib/sod.c (95%) rename sod.h => lib/sod.h (91%) delete mode 100644 output.lisp create mode 100644 pre-reorg/builtin.lisp create mode 100644 pre-reorg/c-types.lisp create mode 100644 pre-reorg/class-builder.lisp rename class-defs.lisp => pre-reorg/class-defs.lisp (100%) create mode 100644 pre-reorg/class-finalize.lisp create mode 100644 pre-reorg/class-layout.lisp rename class-output.lisp => pre-reorg/class-output.lisp (78%) create mode 100644 pre-reorg/codegen.lisp create mode 100644 pre-reorg/combination.lisp create mode 100644 pre-reorg/cpl.lisp create mode 100644 pre-reorg/cutting-room-floor.lisp rename errors.lisp => pre-reorg/errors.lisp (98%) rename examples.lisp => pre-reorg/examples.lisp (100%) create mode 100644 pre-reorg/foo.lisp rename lex.lisp => pre-reorg/lex.lisp (88%) create mode 100644 pre-reorg/methods.lisp rename module-output.lisp => pre-reorg/module-output.lisp (100%) rename module.lisp => pre-reorg/module.lisp (60%) create mode 100644 pre-reorg/output.lisp rename parse-c-types.lisp => pre-reorg/parse-c-types.lisp (100%) rename posn-stream.lisp => pre-reorg/posn-stream.lisp (100%) rename pset.lisp => pre-reorg/pset.lisp (52%) create mode 100644 pre-reorg/sift.lisp rename sod.asd => pre-reorg/sod.asd (89%) rename tables.lisp => pre-reorg/tables.lisp (100%) create mode 100644 src/builtin.lisp create mode 100644 src/class-utilities.lisp create mode 100644 src/classes.lisp create mode 100644 src/foo.lisp create mode 100644 src/impl-c-types-class.lisp rename c-types.lisp => src/impl-c-types.lisp (54%) rename cpl.lisp => src/impl-class-finalize.lisp (59%) create mode 100644 src/impl-class-layout.lisp create mode 100644 src/impl-class-make.lisp create mode 100644 src/impl-codegen.lisp create mode 100644 src/impl-lexer.lisp rename methods.lisp => src/impl-method.lisp (53%) create mode 100644 src/impl-module.lisp create mode 100644 src/impl-output.lisp create mode 100644 src/impl-pset.lisp create mode 100644 src/lexer-bits.lisp create mode 100644 src/output-class.lisp create mode 100644 src/package.lisp create mode 100644 src/parse-c-types.lisp create mode 100644 src/parse-lexical.lisp create mode 100644 src/parser/impl-floc.lisp create mode 100644 src/parser/impl-parser-expr.lisp create mode 100644 src/parser/impl-parser-plug.lisp create mode 100644 src/parser/impl-parser.lisp create mode 100644 src/parser/impl-scanner-charbuf.lisp create mode 100644 src/parser/impl-scanner-context.lisp create mode 100644 src/parser/impl-scanner-token.lisp create mode 100644 src/parser/impl-scanner.lisp create mode 100644 src/parser/impl-streams.lisp create mode 100644 src/parser/opprec.lisp rename package.lisp => src/parser/package.lisp (82%) create mode 100644 src/parser/proto-floc.lisp create mode 100644 src/parser/proto-parser-expr.lisp create mode 100644 src/parser/proto-parser.lisp create mode 100644 src/parser/proto-scanner.lisp create mode 100644 src/parser/proto-streams.lisp create mode 100644 src/parser/test-parser.lisp create mode 100644 src/parser/test-scanner-charbuf.lisp create mode 100644 src/proto-c-types.lisp create mode 100644 src/proto-class-finalize.lisp create mode 100644 src/proto-class-layout.lisp create mode 100644 src/proto-class-make.lisp rename codegen.lisp => src/proto-codegen.lisp (66%) create mode 100644 src/proto-lexer.lisp create mode 100644 src/proto-method.lisp create mode 100644 src/proto-module.lisp create mode 100644 src/proto-output.lisp create mode 100644 src/proto-pset.lisp create mode 100644 src/scratch.lisp create mode 100644 src/sod-test.asd create mode 100644 src/sod.asd create mode 100644 src/test-base.lisp create mode 100644 src/test-c-types.lisp create mode 100644 src/test-codegen.lisp create mode 100644 src/utilities.lisp rename chimaera.sod => test/chimaera.sod (80%) delete mode 100644 utilities.lisp diff --git a/.skelrc b/.skelrc index d27ff69..c1d8aa7 100644 --- a/.skelrc +++ b/.skelrc @@ -3,7 +3,7 @@ (setq skel-alist (append '((author . "Straylight/Edgeware") - (full-title . "the Simple Object Definition system") + (full-title . "the Sensble Object Design, an object system for C") (program . "SOD") (licence-text . skelrc-gpl)) skel-alist)) diff --git a/NOTES b/NOTES deleted file mode 100644 index c22622c..0000000 --- a/NOTES +++ /dev/null @@ -1,38 +0,0 @@ -* Stuff from the ABI spec - -** Notation - - * sizeof(O) :: size of an object O - * align(O) :: alignment of the object O - * offset(C) :: offset of the component C within O - * dsize(O) :: data size of the object O (without tail padding) - * nvsize(O) :: the /non-virtual/ size of the object O (i.e., - without virtual bases) - * nvalign(O) :: the non-virtual alignment of the object O - -** Other concepts - - * POD for the purpose of layout :: - - -* Order of stuff in output files - -** Header - - * Multiple inclusion and C++ guards - * Forward declarations of structs and typedef names. - * User code - * Structure definitions - * Macros - * Function declarations for methods - -** Implementation - - * User code - * Method and table definitions - -* COMMENT - -# Local variables: -# mode: org -# End: diff --git a/builtin.lisp b/builtin.lisp deleted file mode 100644 index 9309581..0000000 --- a/builtin.lisp +++ /dev/null @@ -1,350 +0,0 @@ -;;; -*-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 "~&~: -/* Imprint raw memory with instance structure. */ -static void *~A__imprint(void *p) -{ - struct ~A *sod__obj = p; - - ~:{sod__obj.~A.~A._vt = &~A;~:^~% ~} - return (p); -}~2%" - class - (ilayout-struct-tag class) - (mapcar (lambda (ichain) - (let* ((head (ichain-head ichain)) - (tail (ichain-tail ichain))) - (list (sod-class-nickname head) - (sod-class-nickname tail) - (vtable-name class head)))) - (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.~A" - (sod-class-nickname (ichain-head ichain)) - (sod-class-nickname (ichain-tail ichain))))) - (dolist (item (ichain-body ichain)) - (etypecase item - (vtable-pointer - nil) - (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 - (format stream " ~A =" isl) - (ecase (sod-initializer-value-kind init) - (:simple (write (sod-initializer-value-form init) - :stream stream - :pretty nil :escape nil) - (format stream ";~%")) - (:compound (format stream " (~A) {" - (sod-slot-type dslot)) - (write (sod-initializer-value-form init) - :stream stream - :pretty nil :escape nil) - (format stream "};~%")))))))))))) - (format stream "~&~: - return (p); -}~2%"))) - -(defun output-supers-vector (class stream) - (let ((supers (sod-class-direct-superclasses class))) - (when supers - (format stream "~&~: -/* Direct superclasses. */ -static const SodClass *const ~A__supers[] = { - ~{~A__class~^,~% ~} -};~2%" - class supers)))) - -(defun output-cpl-vector (class stream) - (format stream "~&~: -/* Class precedence list. */ -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 "~&~: -/* Chain structure. */ -~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.")) - -(defclass sod-magic-class-initializer (sod-class-initializer) - ((initializer-function :initarg :initializer-function - :type (or symbol function) - :reader sod-initializer-function) - (prepare-function :initarg :prepare-function - :type (or symbol function) - :reader sod-initializer-prepare-function))) - -(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 - :class class :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 "SOD-BASE" - :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 -------------------------------------------------- diff --git a/class-builder.lisp b/class-builder.lisp deleted file mode 100644 index 59dd4ee..0000000 --- a/class-builder.lisp +++ /dev/null @@ -1,505 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Equipment for building classes and friends -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Finding things by name - -(defun find-superclass-by-nick (class nick) - "Returns the superclass of CLASS with nickname NICK, or signals an error." - - ;; Slightly tricky. The class almost certainly hasn't been finalized, so - ;; trundle through its superclasses and hope for the best. - (if (string= nick (sod-class-nickname class)) - class - (or (some (lambda (super) - (find nick (sod-class-precedence-list super) - :key #'sod-class-nickname - :test #'string=)) - (sod-class-direct-superclasses class)) - (error "No superclass of `~A' with nickname `~A'" class nick)))) - -(flet ((find-item-by-name (what class list name key) - (or (find name list :key key :test #'string=) - (error "No ~A in class `~A' with name `~A'" what class name)))) - - (defun find-instance-slot-by-name (class super-nick slot-name) - (let ((super (find-superclass-by-nick class super-nick))) - (find-item-by-name "slot" super (sod-class-slots super) - slot-name #'sod-slot-name))) - - (defun find-class-slot-by-name (class super-nick slot-name) - (let* ((meta (sod-class-metaclass class)) - (super (find-superclass-by-nick meta super-nick))) - (find-item-by-name "slot" super (sod-class-slots super) - slot-name #'sod-slot-name))) - - (defun find-message-by-name (class super-nick message-name) - (let ((super (find-superclass-by-nick class super-nick))) - (find-item-by-name "message" super (sod-class-messages super) - message-name #'sod-message-name)))) - -;;;-------------------------------------------------------------------------- -;;; Class construction. - -(defun make-sod-class (name superclasses pset &optional location) - "Construct and return a new SOD class with the given NAME and SUPERCLASSES. - - This is the main constructor function for classes. The protocol works as - follows. The :LISP-CLASS property in PSET is checked: if it exists, it - must be a symbol naming a (CLOS) class, which is used in place of - SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further - behaviour is left to the standard CLOS instance construction protocol; for - example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE. - - Minimal sanity checking is done during class construction; most of it is - left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS). - - Unused properties in PSET are diagnosed as errors." - - (with-default-error-location (location) - (let ((class (make-instance (get-property pset :lisp-class :symbol - 'sod-class) - :name name - :superclasses superclasses - :location (file-location location) - :pset pset))) - (check-unused-properties pset) - class))) - -(defgeneric guess-metaclass (class) - (:documentation - "Determine a suitable metaclass for the CLASS. - - The default behaviour is to choose the most specific metaclass of any of - the direct superclasses of CLASS, or to signal an error if that failed.")) - -(defmethod guess-metaclass ((class sod-class)) - "Default metaclass-guessing function for classes. - - Return the most specific metaclass of any of the CLASS's direct - superclasses." - (do ((supers (sod-class-direct-superclasses class) (cdr supers)) - (meta nil (let ((candidate (sod-class-metaclass (car supers)))) - (cond ((null meta) candidate) - ((sod-subclass-p meta candidate) meta) - ((sod-subclass-p candidate meta) candidate) - (t (error "Unable to choose metaclass for `~A'" - class)))))) - ((endp supers) meta))) - -(defmethod shared-initialize :after ((class sod-class) slot-names &key pset) - "Specific behaviour for SOD class initialization. - - Properties inspected are as follows: - - * :METACLASS names the metaclass to use. If unspecified, NIL is stored, - and (unless you intervene later) GUESS-METACLASS will be called by - FINALIZE-SOD-CLASS to find a suitable default. - - * :NICK provides a nickname for the class. If unspecified, a default - (the class's name, forced to lowercase) will be chosen in - FINALIZE-SOD-CLASS. - - * :LINK names the chained superclass. If unspecified, this class will - be left at the head of its chain." - - ;; If no nickname, copy the class name. It won't be pretty, though. - (default-slot (class 'nickname) - (get-property pset :nick :id (string-downcase (slot-value class 'name)))) - - ;; If no metaclass, guess one in a (Lisp) class-specific way. - (default-slot (class 'metaclass) - (multiple-value-bind (name floc) (get-property pset :metaclass :id) - (if floc - (find-sod-class name floc) - (guess-metaclass class)))) - - ;; If no chain-link, then start a new chain here. - (default-slot (class 'chain-link) - (multiple-value-bind (name floc) (get-property pset :link :id) - (if floc - (find-sod-class name floc) - nil)))) - -;;;-------------------------------------------------------------------------- -;;; Slot construction. - -(defgeneric make-sod-slot (class name type pset &optional location) - (:documentation - "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. - - This is the main constructor function for slots. This is a generic - function primarily so that the CLASS can intervene in the construction - process. The default method uses the :LISP-CLASS property (defaulting to - SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then - constructed by MAKE-INSTANCE passing the arguments as initargs; further - behaviour is left to the standard CLOS instance construction protocol; for - example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE. - - Unused properties on PSET are diagnosed as errors.")) - -(defmethod make-sod-slot - ((class sod-class) name type pset &optional location) - (with-default-error-location (location) - (let ((slot (make-instance (get-property pset :lisp-class :symbol - 'sod-slot) - :class class - :name name - :type type - :location (file-location location) - :pset pset))) - (with-slots (slots) class - (setf slots (append slots (list slot)))) - (check-unused-properties pset)))) - -(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) - "This method exists so that it isn't an error to provide a :PSET initarg - to (make-instance 'sod-slot ...). It does nothing." - (declare (ignore slot-names pset)) - nil) - -;;;-------------------------------------------------------------------------- -;;; Slot initializer construction. - -(defgeneric make-sod-instance-initializer - (class nick name value-kind value-form pset &optional location) - (:documentation - "Construct and attach an instance slot initializer, to CLASS. - - This is the main constructor function for instance initializers. This is - a generic function primarily so that the CLASS can intervene in the - construction process. The default method looks up the slot using - FIND-INSTANCE-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to - actually make the initializer object, and adds it to the appropriate list - in CLASS. - - Unused properties on PSET are diagnosed as errors.")) - -(defgeneric make-sod-class-initializer - (class nick name value-kind value-form pset &optional location) - (:documentation - "Construct and attach a class slot initializer, to CLASS. - - This is the main constructor function for class initializers. This is a - generic function primarily so that the CLASS can intervene in the - construction process. The default method looks up the slot using - FIND-CLASS-SLOT-BY-NAME, calls MAKE-SOD-INITIALIZER-USING-SLOT to actually - make the initializer object, and adds it to the appropriate list in CLASS. - - Unused properties on PSET are diagnosed as errors.")) - -(defgeneric make-sod-initializer-using-slot - (class slot init-class value-kind value-form pset location) - (:documentation - "Common construction protocol for slot initializers. - - This generic function does the common work for constructing instance and - class initializers. It can usefully be specialized according to both the - class and slot types. The default method uses the :LISP-CLASS property - (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The - slot is then constructed by MAKE-INSTANCE passing the arguments as - initargs; further behaviour is left to the standard CLOS instance - construction protocol; for example, SOD-INITIALIZER defines - an :AFTER-method on SHARED-INITIALIZE. - - Diagnosing unused properties is left for the caller (usually - MAKE-SOD-INSTANCE-INITIALIZER or MAKE-SOD-CLASS-INITIALIZER) to do. The - caller is also expected to have set WITH-DEFAULT-ERROR-LOCATION if - appropriate. - - You are not expected to call this generic function directly; it's more - useful as a place to hang methods for custom initializer classes.")) - -(defmethod make-sod-instance-initializer - ((class sod-class) nick name value-kind value-form pset - &optional location) - (with-default-error-location (location) - (let* ((slot (find-instance-slot-by-name class nick name)) - (initializer (make-sod-initializer-using-slot - class slot 'sod-instance-initializer - value-kind value-form pset - (file-location location)))) - (with-slots (instance-initializers) class - (setf instance-initializers (append instance-initializers - (list initializer)))) - (check-unused-properties pset)))) - -(defmethod make-sod-class-initializer - ((class sod-class) nick name value-kind value-form pset - &optional location) - (with-default-error-location (location) - (let* ((slot (find-class-slot-by-name class nick name)) - (initializer (make-sod-initializer-using-slot - class slot 'sod-class-initializer - value-kind value-form pset - (file-location location)))) - (with-slots (class-initializers) class - (setf class-initializers (append class-initializers - (list initializer)))) - (check-unused-properties pset)))) - -(defmethod make-sod-initializer-using-slot - ((class sod-class) (slot sod-slot) - init-class value-kind value-form pset location) - (make-instance (get-property pset :lisp-class :symbol init-class) - :class class - :slot slot - :value-kind value-kind - :value-form value-form - :location location - :pset pset)) - -(defmethod shared-initialize :after - ((init sod-initializer) slot-names &key pset) - "This method exists so that it isn't an error to provide a :PSET initarg - to (make-instance 'sod-initializer ...). It does nothing." - (declare (ignore slot-names pset)) - nil) - -;;;-------------------------------------------------------------------------- -;;; Message construction. - -(defgeneric make-sod-message (class name type pset &optional location) - (:documentation - "Construct and attach a new message with given NAME and TYPE, to CLASS. - - This is the main constructor function for messages. This is a generic - function primarily so that the CLASS can intervene in the construction - process. The default method uses the :LISP-CLASS property (defaulting to - SOD-MESSAGE) to choose a (CLOS) class to instantiate. The message is then - constructed by MAKE-INSTANCE passing the arguments as initargs; further - behaviour is left to the standard CLOS instance construction protocol; for - example, SOD-MESSAGE defines an :AFTER-method on SHARED-INITIALIZE. - - Unused properties on PSET are diagnosed as errors.")) - -(defgeneric check-message-type (message type) - (:documentation - "Check that TYPE is a suitable type for MESSAGE. Signal errors if not. - - This is separated out of SHARED-INITIALIZE, where it's called, so that it - can be overridden conveniently by subclasses.")) - -(defmethod make-sod-message - ((class sod-class) name type pset &optional location) - (with-default-error-location (location) - (let ((message (make-instance (get-property pset :lisp-class :symbol - 'standard-message) - :class class - :name name - :type type - :location (file-location location) - :pset pset))) - (with-slots (messages) class - (setf messages (append messages (list message)))) - (check-unused-properties pset)))) - -(defmethod check-message-type ((message sod-message) (type c-function-type)) - nil) -(defmethod check-message-type ((message sod-message) (type c-type)) - (error "Messages must have function type, not ~A" type)) - -(defmethod shared-initialize :after - ((message sod-message) slot-names &key pset) - (declare (ignore slot-names pset)) - (with-slots (type) message - (check-message-type message type))) - -;;;-------------------------------------------------------------------------- -;;; Method construction. - -(defgeneric make-sod-method - (class nick name type body pset &optional location) - (:documentation - "Construct and attach a new method to CLASS. - - This is the main constructor function for methods. This is a generic - function primarily so that the CLASS can intervene in the message lookup - process, though this is actually a fairly unlikely occurrence. - - The default method looks up the message using FIND-MESSAGE-BY-NAME, - invokes MAKE-SOD-METHOD-USING-MESSAGE to make the method object, and then - adds the method to the class's list of methods. This split allows the - message class to intervene in the class selection process, for example. - - Unused properties on PSET are diagnosed as errors.")) - -(defgeneric make-sod-method-using-message - (message class type body pset location) - (:documentation - "Main construction subroutine for method construction. - - This is a generic function so that it can be specialized according to both - a class and -- more particularly -- a message. The default method uses - the :LISP-CLASS property (defaulting to calling SOD-MESSAGE-METHOD-CLASS) - to choose a (CLOS) class to instantiate. The method is then constructed - by MAKE-INSTANCE passing the arguments as initargs; further behaviour is - left to the standard CLOS instance construction protocol; for example, - SOD-METHOD defines an :AFTER-method on SHARED-INITIALIZE. - - Diagnosing unused properties is left for the caller (usually - MAKE-SOD-METHOD) to do. The caller is also expected to have set - WITH-DEFAULT-ERROR-LOCATION if appropriate. - - You are not expected to call this generic function directly; it's more - useful as a place to hang methods for custom initializer classes.")) - -(defgeneric sod-message-method-class (message class pset) - (:documentation - "Return the preferred class for methods on MESSAGE. - - The message can inspect the PSET to decide on a particular message. A - :LISP-CLASS property will usually override this decision: it's then the - programmer's responsibility to ensure that the selected method class is - appropriate.")) - -(defgeneric check-method-type (method message type) - (:documentation - "Check that TYPE is a suitable type for METHOD. Signal errors if not. - - This is separated out of SHARED-INITIALIZE, where it's called, so that it - can be overridden conveniently by subclasses.")) - -(defmethod make-sod-method - ((class sod-class) nick name type body pset &optional location) - (with-default-error-location (location) - (let* ((message (find-message-by-name class nick name)) - (method (make-sod-method-using-message message class - type body pset - (file-location location)))) - (with-slots (methods) class - (setf methods (append methods (list method))))) - (check-unused-properties pset))) - -(defmethod make-sod-method-using-message - ((message sod-message) (class sod-class) type body pset location) - (make-instance (or (get-property pset :lisp-class :symbol) - (sod-message-method-class message class pset)) - :message message - :class class - :type type - :body body - :location location - :pset pset)) - -(defmethod sod-message-method-class - ((message sod-message) (class sod-class) pset) - (declare (ignore pset)) - 'sod-method) - -(defmethod check-method-type - ((method sod-method) (message sod-message) (type c-type)) - (error "Methods must have function type, not ~A" type)) - -(defun argument-lists-compatible-p (message-args method-args) - "Compare argument lists for compatibility. - - Return true if METHOD-ARGS is a suitable method argument list - corresponding to the message argument list MESSAGE-ARGS. This is the case - if the lists are the same length, each message argument has a - corresponding method argument with the same type, and if the message - arguments end in an ellpisis, the method arguments must end with a - `va_list' argument. (We can't pass actual variable argument lists around, - except as `va_list' objects, which are devilish inconvenient things and - require much hacking. See the method combination machinery for details.)" - - (and (= (length message-args) (length method-args)) - (every (lambda (message-arg method-arg) - (if (eq message-arg :ellipsis) - (eq method-arg (c-type va-list)) - (c-type-equal-p (argument-type message-arg) - (argument-type method-arg)))) - message-args method-args))) - -(defmethod check-method-type - ((method sod-method) (message sod-message) (type c-function-type)) - (with-slots ((msgtype type)) message - (unless (c-type-equal-p (c-type-subtype msgtype) - (c-type-subtype type)) - (error "Method return type ~A doesn't match message ~A" - (c-type-subtype msgtype) (c-type-subtype type))) - (unless (argument-lists-compatible-p (c-function-arguments msgtype) - (c-function-arguments type)) - (error "Method arguments ~A don't match message ~A" type msgtype)))) - -(defmethod shared-initialize :after - ((method sod-method) slot-names &key pset) - (declare (ignore slot-names pset)) - - ;; Check that the arguments are named if we have a method body. - (with-slots (body type) method - (unless (or (not body) - (every #'argument-name (c-function-arguments type))) - (error "Abstract declarators not permitted in method definitions"))) - - ;; Check the method type. - (with-slots (message type) method - (check-method-type method message type))) - -;;;-------------------------------------------------------------------------- -;;; Builder macros. - -(defmacro define-sod-class (name (&rest superclasses) &body body) - (let ((plist nil) - (classvar (gensym "CLASS"))) - (loop - (when (or (null body) - (not (keywordp (car body)))) - (return)) - (push (pop body) plist) - (push (pop body) plist)) - `(let ((,classvar (make-sod-class ,name - (mapcar #'find-sod-class - (list ,@superclasses)) - (make-property-set - ,@(nreverse plist))))) - (macrolet ((message (name type &rest plist) - `(make-sod-message ,',classvar ,name (c-type ,type) - (make-property-set ,@plist))) - (method (nick name type body &rest plist) - `(make-sod-method ,',classvar ,nick ,name (c-type ,type) - ,body (make-property-set ,@plist))) - (slot (name type &rest plist) - `(make-sod-slot ,',classvar ,name (c-type ,type) - (make-property-set ,@plist))) - (instance-initializer - (nick name value-kind value-form &rest plist) - `(make-sod-instance-initializer ,',classvar ,nick ,name - ,value-kind ,value-form - (make-property-set - ,@plist))) - (class-initializer - (nick name value-kind value-form &rest plist) - `(make-sod-class-initializer ,',classvar ,nick ,name - ,value-kind ,value-form - (make-property-set - ,@plist)))) - ,@body - (finalize-sod-class ,classvar) - (add-to-module *module* ,classvar))))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/class-finalize.lisp b/class-finalize.lisp deleted file mode 100644 index fa8cc7d..0000000 --- a/class-finalize.lisp +++ /dev/null @@ -1,291 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Class finalization -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Class finalization. - -;; Protocol. - -(defgeneric compute-chains (class) - (:documentation - "Compute the layout chains for CLASS. - - Returns the following three values. - - * the head of the class's primary chain; - - * the class's primary chain as a list, most- to least-specific; and - - * the complete collection of chains, as a list of lists, each most- to - least-specific, with the primary chain first. - - These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots. - - If the chains are ill-formed (i.e., not distinct) then an error is - signalled.")) - -(defgeneric check-sod-class (class) - (:documentation - "Check the CLASS for validity. - - This is done as part of class finalization. The checks performed are as - follows. - - * The class name and nickname, and the names of messages, obey the - rules (see VALID-NAME-P). - - * The messages and slots have distinct names. - - * The classes in the class-precedence-list have distinct nicknames. - - * The chain-link is actually a proper (though not necessarily direct) - superclass. - - * The chosen metaclass is actually a subclass of all of the - superclasses' metaclasses. - - Returns true if all is well; false (and signals errors) if anything was - wrong.")) - -(defgeneric finalize-sod-class (class) - (:documentation - "Computes all of the gory details about a class. - - Once one has stopped inserting methods and slots and so on into a class, - one needs to finalize it to determine the layout structure and the class - precedence list and so on. More precisely that gets done is this: - - * Related classes (i.e., direct superclasses and the metaclass) are - finalized if they haven't been already. - - * If you've been naughty and failed to store a list of slots or - whatever, then an empty list is inserted. - - * The class precedence list is computed and stored. - - * The class is checked for compiance with the well-formedness rules. - - * The layout chains are computed. - - Other stuff will need to happen later, but it's not been done yet. In - particular: - - * Actually computing the layout of the instance and the virtual tables. - - * Combining the applicable methods into effective methods. - - FIXME this needs doing.")) - -;; Implementation. - -(defun sod-subclass-p (class-a class-b) - "Return whether CLASS-A is a descendent of CLASS-B." - (member class-b (sod-class-precedence-list class-a))) - -(defun valid-name-p (name) - "Checks whether NAME is a valid name. - - The rules are: - - * the name must be a string - * which is nonempty - * whose first character is alphabetic - * all of whose characters are alphanumeric or underscores - * and which doesn't contain two consecutive underscores." - - (and (stringp name) - (plusp (length name)) - (alpha-char-p (char name 0)) - (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name) - (not (search "__" name)))) - -(defmethod compute-chains ((class sod-class)) - (with-default-error-location (class) - (with-slots (chain-link class-precedence-list) class - (let* ((head (if chain-link - (sod-class-chain-head chain-link) - class)) - (chain (cons class (and chain-link - (sod-class-chain chain-link)))) - (table (make-hash-table))) - - ;; Check the chains. We work through each superclass, maintaining a - ;; hash table keyed by class. If we encounter a class C which links - ;; to L, then we store C as L's value; if L already has a value then - ;; we've found an error. By the end of all of this, the classes - ;; which don't have an entry are the chain tails. - (dolist (super class-precedence-list) - (let ((link (sod-class-chain-link super))) - (when link - (when (gethash link table) - (error "Conflicting chains in class ~A: ~ - (~A and ~A both link to ~A)" - class super (gethash link table) link)) - (setf (gethash link table) super)))) - - ;; Done. - (values head chain - (cons chain - (mapcar #'sod-class-chain - (remove-if (lambda (super) - (gethash super table)) - (cdr class-precedence-list))))))))) - -(defmethod check-sod-class ((class sod-class)) - (with-default-error-location (class) - - ;; Check the names of things are valid. - (with-slots (name nickname messages) class - (unless (valid-name-p name) - (error "Invalid class name `~A'" class)) - (unless (valid-name-p nickname) - (error "Invalid class nickname `~A' on class `~A'" nickname class)) - (dolist (message messages) - (unless (valid-name-p (sod-message-name message)) - (error "Invalid message name `~A' on class `~A'" - (sod-message-name message) class)))) - - ;; Check that the slots and messages have distinct names. - (with-slots (slots messages class-precedence-list) class - (flet ((check-list (list what namefunc) - (let ((table (make-hash-table :test #'equal))) - (dolist (item list) - (let ((name (funcall namefunc item))) - (if (gethash name table) - (error "Duplicate ~A name `~A' on class `~A'" - what name class) - (setf (gethash name table) item))))))) - (check-list slots "slot" #'sod-slot-name) - (check-list messages "message" #'sod-message-name) - (check-list class-precedence-list "nickname" #'sod-class-name))) - - ;; Check that the CHAIN-TO class is actually a proper superclass. (This - ;; eliminates hairy things like a class being its own link.) - (with-slots (class-precedence-list chain-link) class - (unless (or (not chain-link) - (member chain-link (cdr class-precedence-list))) - (error "In `~A~, chain-to class `~A' is not a proper superclass" - class chain-link))) - - ;; Check for circularity in the superclass graph. Since the superclasses - ;; should already be acyclic, it suffices to check that our class is not - ;; a superclass of any of its own direct superclasses. - (let ((circle (find-if (lambda (super) - (sod-subclass-p super class)) - (sod-class-direct-superclasses class)))) - (when circle - (error "Circularity: ~A is already a superclass of ~A" - class circle))) - - ;; Check that the class has a unique root superclass. - (find-root-superclass class) - - ;; Check that the metaclass is a subclass of each direct superclass's - ;; metaclass. - (with-slots (metaclass direct-superclasses) class - (dolist (super direct-superclasses) - (unless (sod-subclass-p metaclass (sod-class-metaclass super)) - (error "Incompatible metaclass for `~A': ~ - `~A' isn't a subclass of `~A' (of `~A')" - class metaclass (sod-class-metaclass super) super)))))) - -(defmethod finalize-sod-class ((class sod-class)) - - ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief) - ;; clone of the CPL and chain establishment code. If the interface changes - ;; then BOOTSTRAP-CLASSES will need to be changed too. - - (with-default-error-location (class) - (ecase (sod-class-state class) - ((nil) - - ;; If this fails, mark the class as a loss. - (setf (sod-class-state class) :broken) - - ;; Finalize all of the superclasses. There's some special pleading - ;; here to make bootstrapping work: we don't try to finalize the - ;; metaclass if we're a root class (no direct superclasses -- because - ;; in that case the metaclass will have to be a subclass of us!), or - ;; if it's equal to us. This is enough to tie the knot at the top of - ;; the class graph. - (with-slots (name direct-superclasses metaclass) class - (dolist (super direct-superclasses) - (finalize-sod-class super)) - (unless (or (null direct-superclasses) - (eq class metaclass)) - (finalize-sod-class metaclass))) - - ;; Stash the class's type. - (setf (sod-class-type class) - (make-class-type (sod-class-name class))) - - ;; Clobber the lists of items if they've not been set. - (dolist (slot '(slots instance-initializers class-initializers - messages methods)) - (unless (slot-boundp class slot) - (setf (slot-value class slot) nil))) - - ;; If the CPL hasn't been done yet, compute it. - (with-slots (class-precedence-list) class - (unless (slot-boundp class 'class-precedence-list) - (setf class-precedence-list (compute-cpl class)))) - - ;; If no metaclass has been established, then choose one. - (with-slots (metaclass) class - (unless (and (slot-boundp class 'metaclass) metaclass) - (setf metaclass (guess-metaclass class)))) - - ;; If no nickname has been set, choose a default. This might cause - ;; conflicts, but, well, the user should have chosen an explicit - ;; nickname. - (with-slots (name nickname) class - (unless (and (slot-boundp class 'nickname) nickname) - (setf nickname (string-downcase name)))) - - ;; Check that the class is fairly sane. - (check-sod-class class) - - ;; Determine the class's layout. - (with-slots (chain-head chain chains) class - (setf (values chain-head chain chains) (compute-chains class))) - - (with-slots (ilayout effective-methods vtables) class - (setf ilayout (compute-ilayout class)) - (setf effective-methods (compute-effective-methods class)) - (setf vtables (compute-vtables class))) - - ;; Done. - (setf (sod-class-state class) :finalized) - t) - - (:broken - nil) - - (:finalized - t)))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/class-layout.lisp b/class-layout.lisp deleted file mode 100644 index 8770739..0000000 --- a/class-layout.lisp +++ /dev/null @@ -1,657 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Layout for instances and vtables -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Effective slot objects. - -(defclass effective-slot () - ((class :initarg :class :type sod-slot :reader effective-slot-class) - (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot) - (initializer :initarg :initializer :type (or sod-initializer null) - :reader effective-slot-initializer)) - (:documentation - "Describes a slot and how it's meant to be initialized. - - Effective slot objects are usually attached to layouts.")) - -(defgeneric find-slot-initializer (class slot) - (:documentation - "Return the most specific initializer for SLOT, starting from CLASS.")) - -(defgeneric compute-effective-slot (class slot) - (:documentation - "Construct an effective slot from the supplied direct slot. - - SLOT is a direct slot defined on CLASS or one of its superclasses. - (Metaclass initializers are handled using a different mechanism.)")) - -(defmethod print-object ((slot effective-slot) stream) - (maybe-print-unreadable-object (slot stream :type t) - (format stream "~A~@[ = ~@_~A~]" - (effective-slot-direct-slot slot) - (effective-slot-initializer slot)))) - -(defmethod find-slot-initializer ((class sod-class) (slot sod-slot)) - (some (lambda (super) - (find slot - (sod-class-instance-initializers super) - :key #'sod-initializer-slot)) - (sod-class-precedence-list class))) - -(defmethod compute-effective-slot ((class sod-class) (slot sod-slot)) - (make-instance 'effective-slot - :slot slot - :class class - :initializer (find-slot-initializer class slot))) - -;;;-------------------------------------------------------------------------- -;;; Instance layout objects. - -;;; islots - -(defclass islots () - ((class :initarg :class :type sod-class :reader islots-class) - (subclass :initarg :subclass :type sod-class :reader islots-subclass) - (slots :initarg :slots :type list :reader islots-slots)) - (:documentation - "The collection of effective SLOTS defined by an instance of CLASS.")) - -(defmethod print-object ((islots islots) stream) - (print-unreadable-object (islots stream :type t) - (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" - (islots-subclass islots) - (islots-class islots) - (islots-slots islots)))) - -(defgeneric compute-islots (class subclass) - (:documentation - "Return ISLOTS containing EFFECTIVE-SLOTs for a particular CLASS. - - Initializers for the slots should be taken from the most specific - superclass of SUBCLASS.")) - -;;; vtable-pointer - -(defclass vtable-pointer () - ((class :initarg :class :type sod-class :reader vtable-pointer-class) - (chain-head :initarg :chain-head :type sod-class - :reader vtable-pointer-chain-head) - (chain-tail :initarg :chain-tail :type sod-class - :reader vtable-pointer-chain-tail)) - (:documentation - "A pointer to the vtable for CLASS corresponding to a particular CHAIN.")) - -(defmethod print-object ((vtp vtable-pointer) stream) - (print-unreadable-object (vtp stream :type t) - (format stream "~A:~A" - (vtable-pointer-class vtp) - (sod-class-nickname (vtable-pointer-chain-head vtp))))) - -;;; ichain - -(defclass ichain () - ((class :initarg :class :type sod-class :reader ichain-class) - (chain-head :initarg :chain-head :type sod-class :reader ichain-head) - (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail) - (body :initarg :body :type list :reader ichain-body)) - (:documentation - "All of the instance layout for CLASS corresponding to a particular CHAIN. - - The BODY is a list of things to include in the finished structure. By - default, it contains a VTABLE-POINTER and ISLOTS for each class in the - chain.")) - -(defmethod print-object ((ichain ichain) stream) - (print-unreadable-object (ichain stream :type t) - (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" - (ichain-class ichain) - (sod-class-nickname (ichain-head ichain)) - (ichain-body ichain)))) - -(defgeneric compute-ichain (class chain) - (:documentation - "Return an ICHAIN for a particular CHAIN of CLASS's superclasses. - - The CHAIN is a list of classes, with the least specific first -- so the - chain head is the first element.")) - -;;; ilayout - -(defclass ilayout () - ((class :initarg :class :type sod-class :reader ilayout-class) - (ichains :initarg :ichains :type list :reader ilayout-ichains)) - (:documentation - "All of the instance layout for a CLASS. - - Consists of an ICHAIN for each distinct chain.")) - -(defmethod print-object ((ilayout ilayout) stream) - (print-unreadable-object (ilayout stream :type t) - (format stream "~A ~_~:<~@{~S~^ ~_~}~:>" - (ilayout-class ilayout) - (ilayout-ichains ilayout)))) - -(defgeneric compute-ilayout (class) - (:documentation - "Compute and return an instance layout for CLASS.")) - -;;; Standard implementation. - -(defmethod compute-islots ((class sod-class) (subclass sod-class)) - (make-instance 'islots - :class class - :subclass subclass - :slots (mapcar (lambda (slot) - (compute-effective-slot subclass slot)) - (sod-class-slots class)))) - -(defmethod compute-ichain ((class sod-class) chain) - (let* ((chain-head (car chain)) - (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) - :key #'sod-class-chain-head)) - (vtable-pointer (make-instance 'vtable-pointer - :class class - :chain-head chain-head - :chain-tail chain-tail)) - (islots (remove-if-not #'islots-slots - (mapcar (lambda (super) - (compute-islots super class)) - chain)))) - (make-instance 'ichain - :class class - :chain-head chain-head - :chain-tail chain-tail - :body (cons vtable-pointer islots)))) - -(defmethod compute-ilayout ((class sod-class)) - (make-instance 'ilayout - :class class - :ichains (mapcar (lambda (chain) - (compute-ichain class - (reverse chain))) - (sod-class-chains class)))) - -;;;-------------------------------------------------------------------------- -;;; Effective methods. - -(defclass effective-method () - ((message :initarg :message :type sod-message - :reader effective-method-message) - (class :initarg :class :type sod-class :reader effective-method-class)) - (:documentation - "The effective method invoked by sending MESSAGE to an instance of CLASS. - - This is not a useful class by itself. Message classes are expected to - define their own effective-method classes. - - An effective method class must accept a :DIRECT-METHODS initarg, which - will be a list of applicable methods sorted in most-to-least specific - order.")) - -(defmethod print-object ((method effective-method) stream) - (maybe-print-unreadable-object (method stream :type t) - (format stream "~A ~A" - (effective-method-message method) - (effective-method-class method)))) - -(defgeneric message-effective-method-class (message) - (:documentation - "Return the effective method class for the given MESSAGE.")) - -(defgeneric compute-sod-effective-method (message class) - (:documentation - "Return the effective method when a CLASS instance receives MESSAGE. - - The default method constructs an instance of the message's chosen - MESSAGE-EFFECTIVE-METHOD-CLASS, passing the MESSAGE, the CLASS and the - list of applicable methods as initargs to MAKE-INSTANCE.")) - -(defmethod compute-sod-effective-method - ((message sod-message) (class sod-class)) - (let ((direct-methods (mappend (lambda (super) - (remove message - (sod-class-methods super) - :key #'sod-method-message - :test-not #'eql)) - (sod-class-precedence-list class)))) - (make-instance (message-effective-method-class message) - :message message - :class class - :direct-methods direct-methods))) - -;;;-------------------------------------------------------------------------- -;;; Vtable layout. - -;;; method-entry - -(defclass method-entry () - ((method :initarg :method :type effective-method - :reader method-entry-effective-method) - (chain-head :initarg :chain-head :type sod-class - :reader method-entry-chain-head) - (chain-tail :initarg :chain-tail :type sod-class - :reader method-entry-chain-tail)) - (:documentation - "An entry point into an effective method. - - Calls to an effective method via different vtable chains will have their - `me' pointers pointing to different ichains within the instance layout. - Rather than (necessarily) duplicating the entire effective method for each - chain, we insert an entry veneer (the method entry) to fix up the pointer. - Exactly how it does this is up to the effective method -- and duplication - under some circumstances is probably a reasonable approach -- e.g., if the - effective method is just going to call a direct method immediately.")) - -(defmethod print-object ((entry method-entry) stream) - (maybe-print-unreadable-object (entry stream :type t) - (format stream "~A:~A" - (method-entry-effective-method entry) - (sod-class-nickname (method-entry-chain-head entry))))) - -(defgeneric make-method-entry (effective-method chain-head chain-tail) - (:documentation - "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. - - There is no default method for this function. (Maybe when the - effective-method/method-entry output protocol has settled down I'll know - what a sensible default action would be.)")) - -;;; vtmsgs - -(defclass vtmsgs () - ((class :initarg :class :type sod-class :reader vtmsgs-class) - (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass) - (chain-head :initarg :chain-head :type sod-class - :reader vtmsgs-chain-head) - (chain-tail :initarg :chain-tail :type sod-class - :reader vtmsgs-chain-tail) - (entries :initarg :entries :type list :reader vtmsgs-entries)) - (:documentation - "The message dispatch table for a particular CLASS. - - The BODY contains a list of effective method entry objects for the - messages defined on CLASS, customized for calling from the chain headed by - CHAIN-HEAD.")) - -(defmethod print-object ((vtmsgs vtmsgs) stream) - (print-unreadable-object (vtmsgs stream :type t) - (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" - (vtmsgs-subclass vtmsgs) - (vtmsgs-class vtmsgs) - (vtmsgs-entries vtmsgs)))) - -(defgeneric compute-vtmsgs (class subclass chain-head chain-tail) - (:documentation - "Return a VTMSGS object containing method entries for CLASS. - - The CHAIN-HEAD describes which chain the method entries should be - constructed for. - - The default method simply calls MAKE-METHOD-ENTRY for each of the methods - and wraps a VTMSGS object around them. This ought to be enough for almost - all purposes.")) - -;;; class-pointer - -(defclass class-pointer () - ((class :initarg :class :type sod-class :reader class-pointer-class) - (chain-head :initarg :chain-head :type sod-class - :reader class-pointer-chain-head) - (metaclass :initarg :metaclass :type sod-class - :reader class-pointer-metaclass) - (meta-chain-head :initarg :meta-chain-head :type sod-class - :reader class-pointer-meta-chain-head)) - (:documentation - "Represents a pointer to a class object for the instance's class. - - A class instance can have multiple chains. It may be useful to find any - of those chains from an instance of the class. Therefore the vtable - stores a pointer to each separate chain of the class instance.")) - -(defmethod print-object ((cptr class-pointer) stream) - (print-unreadable-object (cptr stream :type t) - (format stream "~A:~A" - (class-pointer-metaclass cptr) - (sod-class-nickname (class-pointer-meta-chain-head cptr))))) - -(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head) - (:documentation - "Return a class pointer to a metaclass chain.")) - -;;; base-offset - -(defclass base-offset () - ((class :initarg :class :type sod-class :reader base-offset-class) - (chain-head :initarg :chain-head :type sod-class - :reader base-offset-chain-head)) - (:documentation - "The offset of this chain to the ilayout base. - - There's only one of these per vtable.")) - -(defmethod print-object ((boff base-offset) stream) - (print-unreadable-object (boff stream :type t) - (format stream "~A:~A" - (base-offset-class boff) - (sod-class-nickname (base-offset-chain-head boff))))) - -(defgeneric make-base-offset (class chain-head) - (:documentation - "Return the base offset object for CHAIN-HEAD ichain.")) - -;;; chain-offset - -(defclass chain-offset () - ((class :initarg :class :type sod-class :reader chain-offset-class) - (chain-head :initarg :chain-head :type sod-class - :reader chain-offset-chain-head) - (target-head :initarg :target-head :type sod-class - :reader chain-offset-target-head)) - (:documentation - "The offset from the CHAIN-HEAD ichain to the TARGET-HEAD ichain.")) - -(defmethod print-object ((choff chain-offset) stream) - (print-unreadable-object (choff stream :type t) - (format stream "~A:~A->~A" - (chain-offset-class choff) - (sod-class-nickname (chain-offset-chain-head choff)) - (sod-class-nickname (chain-offset-target-head choff))))) - -(defgeneric make-chain-offset (class chain-head target-head) - (:documentation - "Return the offset from CHAIN-HEAD to TARGET-HEAD.")) - -;;; vtable - -(defclass vtable () - ((class :initarg :class :type sod-class :reader vtable-class) - (chain-head :initarg :chain-head :type sod-class - :reader vtable-chain-head) - (chain-tail :initarg :chain-tail :type sod-class - :reader vtable-chain-tail) - (body :initarg :body :type list :reader vtable-body)) - (:documentation - "VTABLEs hold all of the per-chain static information for a class. - - There is one vtable for each chain of each class. The vtables for a class - are prefixes of the corresponding chains of its subclasses. - - Vtables contain method entry pointers, pointers to class objects, and - the offset information used for cross-chain slot access.")) - -(defmethod print-object ((vtable vtable) stream) - (print-unreadable-object (vtable stream :type t) - (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" - (vtable-class vtable) - (sod-class-nickname (vtable-chain-head vtable)) - (vtable-body vtable)))) - -(defgeneric compute-vtable (class chain) - (:documentation - "Compute the vtable layout for a chain of CLASS. - - The CHAIN is a list of classes, with the least specific first.")) - -(defgeneric compute-vtables (class) - (:documentation - "Compute the vtable layouts for CLASS. - - Returns a list of VTABLE objects in the order of CLASS's chains.")) - -;;; Implementation. - -(defmethod compute-vtmsgs - ((class sod-class) - (subclass sod-class) - (chain-head sod-class) - (chain-tail sod-class)) - (flet ((make-entry (message) - (let ((method (find message - (sod-class-effective-methods subclass) - :key #'effective-method-message))) - (make-method-entry method chain-head chain-tail)))) - (make-instance 'vtmsgs - :class class - :subclass subclass - :chain-head chain-head - :chain-tail chain-tail - :entries (mapcar #'make-entry - (sod-class-messages class))))) - -(defmethod make-class-pointer - ((class sod-class) (chain-head sod-class) - (metaclass sod-class) (meta-chain-head sod-class)) - - ;; Slightly tricky. We don't necessarily want a pointer to the metaclass, - ;; but to its most specific subclass on the given chain. Fortunately, CL - ;; is good at this game. - (let* ((meta-chains (sod-class-chains metaclass)) - (meta-chain-tails (mapcar #'car meta-chains)) - (meta-chain-tail (find meta-chain-head meta-chain-tails - :key #'sod-class-chain-head))) - (make-instance 'class-pointer - :class class - :chain-head chain-head - :metaclass meta-chain-tail - :meta-chain-head meta-chain-head))) - -(defmethod make-base-offset ((class sod-class) (chain-head sod-class)) - (make-instance 'base-offset - :class class - :chain-head chain-head)) - -(defmethod make-chain-offset - ((class sod-class) (chain-head sod-class) (target-head sod-class)) - (make-instance 'chain-offset - :class class - :chain-head chain-head - :target-head target-head)) - -;; Special variables used by COMPUTE-VTABLE. -(defvar *done-metaclass-chains*) -(defvar *done-instance-chains*) - -(defgeneric compute-vtable-items (class super chain-head chain-tail emit) - (:documentation - "Emit vtable items for a superclass of CLASS. - - This function is called for each superclass SUPER of CLASS reached on the - chain headed by CHAIN-HEAD. The function should call EMIT for each - vtable item it wants to write. - - The right way to check to see whether items have already been emitted - (e.g., has an offset to some other chain been emitted?) is as follows: - - * In a method on COMPUTE-VTABLE, bind a special variable to an empty - list or hash table. - - * In a method on this function, check the variable or hash table. - - This function is the real business end of COMPUTE-VTABLE.")) - -(defmethod compute-vtable-items - ((class sod-class) (super sod-class) (chain-head sod-class) - (chain-tail sod-class) (emit function)) - - ;; If this class introduces new metaclass chains, then emit pointers to - ;; them. - (let* ((metasuper (sod-class-metaclass super)) - (metasuper-chains (sod-class-chains metasuper)) - (metasuper-chain-heads (mapcar (lambda (chain) - (sod-class-chain-head (car chain))) - metasuper-chains))) - (dolist (metasuper-chain-head metasuper-chain-heads) - (unless (member metasuper-chain-head *done-metaclass-chains*) - (funcall emit (make-class-pointer class - chain-head - metasuper - metasuper-chain-head)) - (push metasuper-chain-head *done-metaclass-chains*)))) - - ;; If there are new instance chains, then emit offsets to them. - (let* ((chains (sod-class-chains super)) - (chain-heads (mapcar (lambda (chain) - (sod-class-chain-head (car chain))) - chains))) - (dolist (head chain-heads) - (unless (member head *done-instance-chains*) - (funcall emit (make-chain-offset class chain-head head)) - (push head *done-instance-chains*)))) - - ;; Finally, if there are interesting methods, emit those too. - (when (sod-class-messages super) - (funcall emit (compute-vtmsgs super class chain-head chain-tail)))) - -(defun find-root-superclass (class) - "Returns the `root' superclass of CLASS. - - The root superclass is the superclass which itself has no direct - superclasses. In universes not based on the provided builtin module, the - root class may not be our beloved SodObject; however, there must be one - (otherwise the class graph is cyclic, which should be forbidden), and we - instist that it be unique." - - ;; The root superclass must be a chain head since the chains partition the - ;; superclasses; the root has no superclasses so it can't have a link and - ;; must therefore be a head. This narrows the field down quite a lot. - ;; - ;; Note! This function gets called from CHECK-SOD-CLASS before the class's - ;; chains have been computed. Therefore we iterate over the direct - ;; superclass's chains rather than the class's own. This misses a chain - ;; only in the case where the class is its own chain head. There are two - ;; subcases: if there are no direct superclasses at all, then the class is - ;; its own root; otherwise, it clearly can't be the root and the omission - ;; is harmless. - (let* ((supers (sod-class-direct-superclasses class)) - (roots (if supers - (remove-duplicates - (remove-if #'sod-class-direct-superclasses - (mappend (lambda (super) - (mapcar (lambda (chain) - (sod-class-chain-head - (car chain))) - (sod-class-chains super))) - supers))) - (list class)))) - (cond ((null roots) (error "Class ~A has no root class!" class)) - ((cdr roots) (error "Class ~A has multiple root classes ~ - ~{~A~#[~; and ~;, ~]~}" - class roots)) - (t (car roots))))) - -(defun find-root-metaclass (class) - "Returns the `root' metaclass of CLASS. - - The root metaclass is the metaclass of the root superclass -- see - FIND-ROOT-SUPERCLASS." - (sod-class-metaclass (find-root-superclass class))) - -(defmethod compute-vtable ((class sod-class) (chain list)) - (let* ((chain-head (car chain)) - (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) - :key #'sod-class-chain-head)) - (*done-metaclass-chains* nil) - (*done-instance-chains* (list chain-head)) - (done-superclasses nil) - (items nil)) - (flet ((emit (item) - (push item items))) - - ;; Find the root chain in the metaclass and write a pointer. - (let* ((metaclass (sod-class-metaclass class)) - (metaclass-root (find-root-metaclass class)) - (metaclass-root-head (sod-class-chain-head metaclass-root))) - (emit (make-class-pointer class chain-head metaclass - metaclass-root-head)) - (push metaclass-root-head *done-metaclass-chains*)) - - ;; Write an offset to the instance base. - (emit (make-base-offset class chain-head)) - - ;; Now walk the chain. As we ascend the chain, scan the class - ;; precedence list of each class in reverse to ensure that we have - ;; everything interesting. - (dolist (super chain) - (dolist (sub (reverse (sod-class-precedence-list super))) - (unless (member sub done-superclasses) - (compute-vtable-items class - sub - chain-head - chain-tail - #'emit) - (push sub done-superclasses)))) - - ;; We're through. - (make-instance 'vtable - :class class - :chain-head chain-head - :chain-tail chain-tail - :body (nreverse items))))) - -(defgeneric compute-effective-methods (class) - (:documentation - "Return a list of all of the effective methods needed for CLASS. - - The list needn't be in any particular order.")) - -(defmethod compute-effective-methods ((class sod-class)) - (mapcan (lambda (super) - (mapcar (lambda (message) - (compute-sod-effective-method message class)) - (sod-class-messages super))) - (sod-class-precedence-list class))) - -(defmethod compute-vtables ((class sod-class)) - (mapcar (lambda (chain) - (compute-vtable class (reverse chain))) - (sod-class-chains class))) - -;;;-------------------------------------------------------------------------- -;;; Names of things. - -(defun islots-struct-tag (class) - (format nil "~A__islots" class)) - -(defun ichain-struct-tag (class chain-head) - (format nil "~A__ichain_~A" class (sod-class-nickname chain-head))) - -(defun ichain-union-tag (class chain-head) - (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head))) - -(defun ilayout-struct-tag (class) - (format nil "~A__ilayout" class)) - -(defun vtmsgs-struct-tag (class super) - (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) - -(defun vtable-struct-tag (class chain-head) - (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) - -(defun vtable-name (class chain-head) - (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/combination.lisp b/combination.lisp deleted file mode 100644 index b700993..0000000 --- a/combination.lisp +++ /dev/null @@ -1,129 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Method combinations -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Common behaviour. - -(defclass simple-message (basic-message) - () - (:documentation - "Base class for messages with `simple' method combinations. - - A simple method combination is one which has only one method role other - than the `before', `after' and `around' methods provided by BASIC-MESSAGE. - We call these `primary' methods, and the programmer designates them by not - specifying an explicit role. - - If the programmer doesn't define any primary methods then the effective - method is null -- i.e., the method entry pointer shows up as a null - pointer.")) - -(defclass simple-effective-method (basic-effective-method) - ((primary-methods :initarg :primary-methods :initform nil - :type list :reader effective-method-primary-methods)) - (:documentation - "Effective method counterpart to SIMPLE-MESSAGE.")) - -(defgeneric primary-method-class (message) - (:documentation - "Return the name of the primary direct method class for MESSAGE.")) - -(defgeneric simple-method-body (method codegen target) - (:documentation - "Generate the body of a simple effective method. - - The function is invoked on an effective METHOD, with a CODEGEN to which it - should emit code delivering the method's value to TARGET.")) - -(defmethod sod-message-method-class - ((message standard-message) (class sod-class) pset) - (if (get-property pset :role :keyword nil) - (call-next-method) - (primary-method-class message))) - -(defmethod shared-initialize :after - ((method simple-effective-method) slot-names &key direct-methods) - (declare (ignore slot-names)) - (categorize (method direct-methods :bind ((role (sod-method-role method)))) - ((primary (null role)) - (before (eq role :before)) - (after (eq role :after)) - (around (eq role :around))) - (with-slots (primary-methods before-methods after-methods around-methods) - method - (setf primary-methods primary - before-methods before - after-methods (reverse after) - around-methods around)))) - -(defmethod compute-effective-method-entry-functions - ((method standard-effective-method)) - (if (effective-method-primary-methods method) - (call-next-method) - nil)) - -(defmethod compute-effective-method-body - ((method simple-effective-method) codegen target) - (with-slots (message basic-argument-names primary-methods) method - (basic-effective-method-body codegen target method - (lambda (target) - (simple-method-body method - codegen - target))))) - -;;;-------------------------------------------------------------------------- -;;; Standard method combination. - -(defclass standard-message (simple-message) - () - (:documentation - "Message class for standard method combination. - - Standard method combination is a simple method combination where the - primary methods are invoked as a delegation chain, from most- to - least-specific.")) - -(defclass standard-effective-method (simple-effective-method) - () - (:documentation - "Effective method counterpart to STANDARD-MESSAGE.")) - -(defmethod primary-method-class ((message standard-message)) - 'delegating-direct-method) - -(defmethod message-effective-method-class ((message standard-message)) - 'standard-effective-method) - -(defmethod simple-method-body - ((method standard-effective-method) codegen target) - (invoke-delegation-chain codegen - target - (effective-method-basic-argument-names method) - (effective-method-primary-methods method) - nil)) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/cutting-room-floor.lisp b/cutting-room-floor.lisp deleted file mode 100644 index 2f82c65..0000000 --- a/cutting-room-floor.lisp +++ /dev/null @@ -1,195 +0,0 @@ -;;;-------------------------------------------------------------------------- -;;; C types stuff. - -(cl:defpackage #:c-types - (:use #:common-lisp - #+sbcl #:sb-mop - #+(or cmu clisp) #:mop - #+ecl #:clos) - (:export #:c-type - #:c-declarator-priority #:maybe-parenthesize - #:pprint-c-type - #:c-type-subtype #:compount-type-declaration - #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers - #:simple-c-type #:c-type-name - #:c-pointer-type - #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type - #:tagged-c-type-kind - #:c-array-type #:c-array-dimensions - #:make-argument #:argument-name #:argument-type - #:c-function-type #:c-function-arguments - - #:define-c-type-syntax #:c-type-alias #:defctype - #:print-c-type - #:qualifier #:declare-qualifier - #:define-simple-c-type - - #:const #:volatile #:static #:restrict - #:char #:unsigned-char #:uchar #:signed-char #:schar - #:int #:signed #:signed-int #:sint - #:unsigned #:unsigned-int #:uint - #:short #:signed-short #:short-int #:signed-short-int #:sshort - #:unsigned-short #:unsigned-short-int #:ushort - #:long #:signed-long #:long-int #:signed-long-int #:slong - #:unsigned-long #:unsigned-long-int #:ulong - #:float #:double #:long-double - #:pointer #:ptr - #:[] #:vec - #:fun #:func #:fn)) - - -;;;-------------------------------------------------------------------------- -;;; Convenient syntax for C types. - -;; Basic machinery. - -;; Qualifiers. They have hairy syntax and need to be implemented by hand. - -;; Simple types. - -;; Pointers. - -;; Tagged types. - -;; Arrays. - -;; Functions. - - -(progn - (defconstant q-byte (byte 3 0)) - (defconstant q-const 1) - (defconstant q-volatile 2) - (defconstant q-restrict 4) - - (defconstant z-byte (byte 3 3)) - (defconstant z-unspec 0) - (defconstant z-short 1) - (defconstant z-long 2) - (defconstant z-long-long 3) - (defconstant z-double 4) - (defconstant z-long-double 5) - - (defconstant s-byte (byte 2 6)) - (defconstant s-unspec 0) - (defconstant s-signed 1) - (defconstant s-unsigned 2) - - (defconstant t-byte (byte 3 8)) - (defconstant t-unspec 0) - (defconstant t-int 1) - (defconstant t-char 2) - (defconstant t-float 3) - (defconstant t-user 4)) - -(defun make-type-flags (size sign type &rest quals) - (let ((flags 0)) - (dolist (qual quals) - (setf flags (logior flags qual))) - (setf (ldb z-byte flags) size - (ldb s-byte flags) sign - (ldb t-byte flags) type) - flags)) - - -(defun expand-c-type (spec) - "Parse SPEC as a C type and return the result. - - The SPEC can be one of the following. - - * A C-TYPE object, which is returned immediately. - - * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser - function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX - or some other means is invoked on the ARGUMENTS, and the result is - returned. - - * A symbol, which is treated the same way as a singleton list would be." - - (flet ((interp (sym) - (or (get sym 'c-type) - (error "Unknown C type operator ~S." sym)))) - (etypecase spec - (c-type spec) - (symbol (funcall (interp spec))) - (list (apply (interp (car spec)) (cdr spec)))))) - -(defmacro c-type (spec) - "Evaluates to the type that EXPAND-C-TYPE would return. - - Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe - later it will do something more clever." - `(expand-c-type ',spec)) - -;; S-expression machinery. Qualifiers have hairy syntax and need to be -;; implemented by hand. - -(defun qualifier (qual &rest args) - "Parse a qualified C type. - - The ARGS consist of a number of qualifiers and exactly one C-type - S-expression. The result is a qualified version of this type, with the - given qualifiers attached." - (if (null args) - qual - (let* ((things (mapcar #'expand-c-type args)) - (quals (delete-duplicates - (sort (cons qual (remove-if-not #'keywordp things)) - #'string<))) - (types (remove-if-not (lambda (thing) (typep thing 'c-type)) - things))) - (when (or (null types) - (not (null (cdr types)))) - (error "Only one proper type expected in ~S." args)) - (qualify-type (car types) quals)))) -(setf (get 'qualifier 'c-type) #'qualifier) - -(defun declare-qualifier (qual) - "Defines QUAL as being a type qualifier. - - When used as a C-type operator, it applies that qualifier to the type that - is its argument." - (let ((kw (intern (string qual) :keyword))) - (setf (get qual 'c-type) - (lambda (&rest args) - (apply #'qualifier kw args))))) - -;; Define some initial qualifiers. -(dolist (qual '(const volatile restrict)) - (declare-qualifier qual)) - - -(define-c-type-syntax simple-c-type (name) - "Constructs a simple C type called NAME (a string or symbol)." - (make-simple-type (c-name-case name))) - -(defmethod print-c-type :around - (stream (type qualifiable-c-type) &optional colon atsign) - (if (c-type-qualifiers type) - (pprint-logical-block (stream nil :prefix "(" :suffix ")") - (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_" - (c-type-qualifiers type)) - (call-next-method stream type colon atsign)) - (call-next-method))) -;; S-expression syntax. - - -(define-c-type-syntax enum (tag) - "Construct an enumeration type named TAG." - (make-instance 'c-enum-type :tag (c-name-case tag))) -(define-c-type-syntax struct (tag) - "Construct a structure type named TAG." - (make-instance 'c-struct-type :tag (c-name-case tag))) -(define-c-type-syntax union (tag) - "Construct a union type named TAG." - (make-instance 'c-union-type :tag (c-name-case tag))) - -(defgeneric make-me-argument (message class) - (:documentation - "Return an ARGUMENT object for the `me' argument to MESSAGE, as - specialized to CLASS.")) - -(defmethod make-me-argument - ((message basic-message) (class sod-class)) - (make-argument "me" (make-instance 'c-pointer-type - :subtype (sod-class-type class)))) diff --git a/sod-backg.tex b/doc/sod-backg.tex similarity index 100% rename from sod-backg.tex rename to doc/sod-backg.tex diff --git a/doc/sod-protocol.tex b/doc/sod-protocol.tex new file mode 100644 index 0000000..f0bd115 --- /dev/null +++ b/doc/sod-protocol.tex @@ -0,0 +1,695 @@ +%%% -*-latex-*- +%%% +%%% Description of the internal class structure and protocol +%%% +%%% (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. + +\chapter{Protocol overview} \label{ch:proto} + +This chapter provides an overview of the Sod translator's internal object +model. It describes most of the important classes and generic functions, how +they are used to build a model of a Sod module and produce output code, and +how an extension might modify the translator's behaviour. + +I assume familiarity with the Common Lisp Object System (CLOS). Familiarity +with the CLOS Metaobject Protocol isn't necessary but may be instructive. + +%%%-------------------------------------------------------------------------- +\section{A tour through the translator} + +At the very highest level, the Sod translator works in two phases: it +\emph{parses} source files into an internal representation, and then it +\emph{generates} output files from the internal representation. + +The function @|read-module| is given a pathname for a file: it opens the +file, parses the program text, and returns a @|module| instance describing +the classes and other items found. + +At the other end, the main output function is @|output-module|, which is +given a module, an output stream and a + + +%%%-------------------------------------------------------------------------- +\section{Specification conventions} \label{sec:proto.conventions} + +Throughout this specification, the phrase `it is an error' indicates that a +particular circumstance is erroneous and results in unspecified and possibly +incorrect behaviour. In particular, the situation need not be immediately +diagnosed, and the consequences may be far-reaching. + +The following conventions apply throughout this specification. + +\begin{itemize} + +\item If a specification describes an argument as having a particular type or + syntax, then it is an error to provide an argument not having that + particular type or syntax. + +\item If a specification describes a function then that function might be + implemented as a generic function; it is an error to attempt to (re)define + it as a generic function, or to attempt to add methods to it. A function + specified as being a generic function will certainly be so; if user methods + are permitted on the generic function then this will be specified. + +\item Where a class precedence list is specified, either explicitly or + implicitly by a class hierarchy, the implementation may include additional + superclasses not specified here. Such additional superclasses will not + affect the order of specified classes in the class precedence lists either + of specified classes themselves or of user-defined subclasses of specified + classes. + +\item Unless otherwise specified, generic functions use the standard method + combination. + +\item The specifications for methods are frequently brief; they should be + read in conjunction with and in the context of the specification for the + generic function and specializing classes, if any. + +\item An object $o$ is a \emph{direct instance} of a class $c$ if @|(eq + (class-of $o$) $c$)|; $o$ is an \emph{instance} of $c$ if it is a direct + instance of any subclass of $c$. + +\item If a class is specified as being \emph{abstract} then it is an error to + construct direct instances of it, e.g., using @|make-instance|. + +\item If an object is specified as being \emph{immutable} then it is an error + to mutate it, e.g., using @|(setf (slot-value \ldots) \ldots)|. Programs + may rely on immutable objects retaining their state. + +\item A value is \emph{fresh} if it is guaranteed to be not @|eql| to any + previously existing value. + +\item Unless otherwise specified, it is an error to change the class of an + instance of any class described here; and it is an error to change the + class of an object to a class described here. + +\end{itemize} + +\subsection{Format of the entries} \label{sec:proto.conventions.format} + +Most symbols defined by the protocol have their own entries. An entry begins +with a header line, showing a synopsis of the symbol on the left, and the +category (function, class, macro, etc.) on the right. + +\begin{describe}{fun}{example-function @ + \&optional @ + \&rest @ + \&key :keyword} + The synopsis for a function, generic function or method describes the + function's lambda-list using the usual syntax. Note that keyword arguments + are shown by naming their keywords; in the description, the value passed + for the keyword argument @|keyword| is shown as @. + + For a method, specializers are shown using the usual @|defmethod| syntax, + e.g., + \begin{quote} + some-generic-function ((@ list) @) + \end{quote} +\end{describe} + +\begin{describe}{mac}{example-macro + ( @{ @ @! (@ @
) @}^* ) \\ \push + @[[ @^* @! @ @]] \\ + @^*} + The synopsis for a macro describes the acceptable syntax using the + following notation. + \begin{itemize} + \item Literal symbols, e.g., keywords and parenthesis, are shown in + @|monospace|. + \item Metasyntactic variables are shown in @. + \item Items are grouped together by braces `@{ $\dots$ @}'. The notation + `@{ $\dots$ @}^*' indicates that the enclosed items may be repeated zero + or more times; `@{ $\dots$ @}^+' indicates that the enclosed items may be + repeated one or more times. This notation may be applied to a single + item without the braces. + \item Optional items are shown enclosed in brackets `@[ $\dots$ @]'. + \item Alternatives are separated by vertical bars `@!'; the vertical bar + has low precedence, so alternatives extend as far as possible between + bars and up to the enclosing brackets if any. + \item A sequence of alternatives enclosed in double-brackets `@[[ $\ldots$ + @]]' indicates that the alternatives may occur in any order, but each may + appear at most once unless marked by a star. + \end{itemize} + For example, the notation at the head of this example describes syntax + for @|let|. +\end{describe} + + +\begin{describe}{cls}{example-class (direct-super other-direct-super) \&key + :initarg} + The synopsis for a class lists the class's direct superclasses, and the + acceptable initargs in the form of a lambda-list. The initargs may be + passed to @|make-instance| when constructing an instance of the class or a + subclass of it. If instances of the class may be reinitialized, or if + objects can be changed to be instances of the class, then these initargs + may also be passed to @|reinitialize-instance| and/or @|change-class| as + applicable; the class description will state explicitly when these + operations are allowed. +\end{describe} + +%%%-------------------------------------------------------------------------- +\section{C type representation} \label{sec:proto.c-types} + +\subsection{Overview} \label{sec:proto.c-types.over} + +The Sod translator represents C types in a fairly simple and direct way. +However, because it spends a fair amount of its time dealing with C types, it +provides a number of useful operations and macros. + +The class hierarchy is shown in~\xref{fig:proto.c-types}. + +\begin{figure} \centering + \parbox{10pt}{\begin{tabbing} + @|c-type| \\ \push + @|qualifiable-c-type| \\ \push + @|simple-c-type| \\ \push + @|c-class-type| \- \\ + @|tagged-c-type| \\ \push + @|c-struct-type| \\ + @|c-union-type| \\ + @|c-enum-type| \- \\ + @|c-pointer-type| \- \\ + @|c-array-type| \\ + @|c-function-type| + \end{tabbing}} + \caption{Classes representing C types} +\label{fig:proto.c-types} +\end{figure} + +C type objects are immutable unless otherwise specified. + +\subsubsection{Constructing C type objects} +There is a constructor function for each non-abstract class of C type object. +Note, however, that constructor functions need not generate a fresh type +object if a previously existing type object is suitable. In this case, we +say that the objects are \emph{interned}. Some constructor functions are +specified to return interned objects: programs may rely on receiving the same +(@|eq|) type object for similar (possibly merely @|equal|) arguments. Where +not specified, clients may still not rely on receiving fresh objects. + +A convenient S-expression notation is provided by the @|c-type| macro. Use +of this macro is merely an abbreviation for corresponding use of the various +constructor functions, and therefore interns type objects in the same manner. +The syntax accepted by the macro can be extended in order to support new +classes: see @|defctype|, @|c-type-alias| and @|define-c-type-syntax|. + +The descriptions of each of the various classes include descriptions of the +initargs which may be passed to @|make-instance| when constructing a new +instance of the class. However, the constructor functions and S-expression +syntax are strongly recommended over direct use of @|make-instance|. + +\subsubsection{Printing} +There are two protocols for printing C types. Unfortunately they have +similar names. +\begin{itemize} +\item The @|print-c-type| function prints a C type value using the + S-expression notation. It is mainly useful for diagnostic purposes. +\item The @|pprint-c-type| function prints a C type as a C-syntax + declaration. +\end{itemize} +Neither generic function defines a default primary method; subclasses of +@|c-type| must define their own methods in order to print correctly. + +\subsection{The C type root class} \label{sec:proto.c-types.root} + +\begin{describe}{cls}{c-type ()} + The class @|c-type| marks the root of the built-in C type hierarchy. + + Users may define subclasses of @|c-type|. All non-abstract subclasses must + have a primary method defined on @|pprint-c-type|; unless instances of the + subclass are interned, a method on @|c-type-equal-p| is also required. + + The class @|c-type| is abstract. +\end{describe} + +\subsection{C type S-expression notation} \label{sec:proto.c-types.sexp} + +The S-expression representation of a type is described syntactically as a +type specifier. Type specifiers fit into two syntactic categories. +\begin{itemize} +\item A \emph{symbolic type specifier} consists of a symbol. It has a + single, fixed meaning: if @ is a symbolic type specifier, then each + use of @ in a type specifier evaluates to the same (@|eq|) type + object, until the @ is redefined. +\item A \emph{type operator} is a symbol; the corresponding specifier is a + list whose @|car| is the operator. The remaining items in the list are + arguments to the type operator. +\end{itemize} + +\begin{describe}{mac}{c-type @ @to @} + Evaluates to a C type object, as described by the type specifier + @. +\end{describe} + +\begin{describe}{mac}{ + defctype @{ @ @! (@^*) @} @ @to @} + Defines a new symbolic type specifier @; if a list of @s is + given, then all are defined in the same way. The type constructed by using + any of the @s is as described by the type specifier @. + + The resulting type object is constructed once, at the time that the macro + expansion is evaluated; the same (@|eq|) value is used each time any + @ is used in a type specifier. +\end{describe} + +\begin{describe}{mac}{c-type-alias @ @^* @to @} + Defines each @ as being a type operator identical in behaviour to + @. If @ is later redefined then the behaviour of the + @es changes too. +\end{describe} + +\begin{describe}{mac}{% + define-c-type-syntax @ @ \\ \push + @^* \-\\ + @to @} + Defines the symbol @ as a new type operator. When a list of the form + @|(@ @^*)| is used as a type specifier, the @s + are bound to fresh variables according to @ (a destructuring + lambda-list) and the @s evaluated in order in the resulting lexical + environment as an implicit @|progn|. The value should be a Lisp form which + will evaluate to the type specified by the arguments. + + The @s may call @|expand-c-type-spec| in order to recursively expand + type specifiers among its arguments. +\end{describe} + +\begin{describe}{fun}{expand-c-type-spec @ @to @} + Returns the Lisp form that @|(c-type @)| would expand into. +\end{describe} + +\begin{describe}{gf}{% + print-c-type @ @ \&optional @ @} + Print the C type object @ to @ in S-expression form. The + @ and @ arguments may be interpreted in any way which seems + appropriate: they are provided so that @|print-c-type| may be called via + @|format|'s @|\char`\~/\dots/| command; they are not set when + @|print-c-type| is called by Sod functions. + + There should be a method defined for every C type class; there is no + default method. +\end{describe} + +\subsection{Comparing C types} \label{sec:proto.c-types.cmp} + +It is necessary to compare C types for equality, for example when checking +argument lists for methods. This is done by @|c-type-equal-p|. + +\begin{describe}{gf}{c-type-equal-p @_1 @_2 @to @} + The generic function @|c-type-equal-p| compares two C types @_1 and + @_2 for equality; it returns true if the two types are equal and + false if they are not. + + Two types are equal if they are structurally similar, where this property + is defined by methods for each individual class; see the descriptions of + the classes for the details. + + The generic function @|c-type-equal-p| uses the @|and| method combination. + + \begin{describe}{meth}{c-type-equal-p @_1 @_2} + A default primary method for @|c-type-equal-p| is defined. It simply + returns @|nil|. This way, methods can specialize on both arguments + without fear that a call will fail because no methods are applicable. + \end{describe} + \begin{describe}{ar-meth}{c-type-equal-p @_1 @_2} + A default around-method for @|c-type-equal-p| is defined. It returns + true if @_1 and @_2 are @|eql|; otherwise it delegates to the + primary methods. Since several common kinds of C types are interned, + this is a common case worth optimizing. + \end{describe} +\end{describe} + +\subsection{Outputting C types} \label{sec:proto.c-types.output} + +\begin{describe}{gf}{pprint-c-type @ @ @} + The generic function @|pprint-c-type| pretty-prints to @ a C-syntax + declaration of an object or function of type @. The result is + written to @. + + A C declaration has two parts: a sequence of \emph{declaration specifiers} + and a \emph{declarator}. The declarator syntax involves parentheses and + operators, in order to reflect the operators applicable to the declared + variable. For example, the name of a pointer variable is preceded by @`*'; + the name of an array is followed by dimensions enclosed in @`['\dots @`]'. + + The @ argument must be a function designator (though see the + standard around-method); it is invoked as + \begin{quote} \codeface + (funcall @ @ @ @) + \end{quote} + It should write to @ -- which may not be the same stream originally + passed into the generic function -- the `kernel' of the declarator, i.e., + the part to which prefix and/or postfix operators are attached to form the + full declarator. + + The methods on @|pprint-c-type| specialized for compound types work by + recursively calling @|pprint-c-type| on the subtype, passing down a closure + which prints the necessary additional declarator operators before calling + the original @ function. The additional arguments @ and + @ support this implementation technique. + + The @ argument describes the surrounding operator context. It is + zero if no type operators are directly attached to the kernel (i.e., there + are no operators at all, or the kernel is enclosed in parentheses), one if + a prefix operator is directly attached, or two if a postfix operator is + directly attached. If the @ function intends to provide its own + additional declarator operators, it should check the @ in order + to determine whether parentheses are necessary. See also the + @|maybe-in-parens| macro (page~\pageref{mac:maybe-in-parens}). + + The @ argument indicates whether a space needs to be printed in + order to separate the declarator from the declaration specifiers. A kernel + which contains an identifier should insert a space before the identifier + when @ is non-nil. An `empty' kernel, as found in an abstract + declarator (one that specifies no name), looks more pleasing without a + trailing space. See also the @|c-type-space| function + (page~\pageref{fun:c-type-space}). + + Every concrete subclass of @|c-type| is expected to provide a primary + method on this function. There is no default primary method. + + \begin{describe}{ar-meth}{pprint-c-type @ @ @} + A default around method is defined on @|pprint-c-type| which `canonifies' + non-function @ arguments. In particular: + \begin{itemize} + \item if @ is nil, then @|pprint-c-type| is called recursively + with a @ function that does nothing; and + \item if @ is any other kind of object, then @|pprint-c-type| is + called recursively with a @ function that prints the object as + if by @|princ|, preceded if necessary by space using @|c-type-space|. + \end{itemize} + \end{describe} +\end{describe} + +\begin{describe}{fun}{c-type-space @} + Writes a space and other pretty-printing instructions to @ in order + visually to separate a declarator from the preceding declaration + specifiers. The precise details are subject to change. +\end{describe} + +\begin{describe}{mac}{% + maybe-in-parens (@ @) \\ \push + @^*} + The @ is evaluated, and then the @s are evaluated in + sequence within a pretty-printer logical block writing to the stream named + by the symbol @. If the @ evaluates to nil, then + the logical block has empty prefix and suffix strings; if it evaluates to a + non-nil value, then the logical block has prefix and suffix @`(' and @`)' + respectively. + + Note that this may cause @ to be bound to a different stream object + within the @s. +\end{describe} + +\subsection{Type qualifiers and qualifiable types} +\label{sec:proto.ctypes.qual} + +\begin{describe}{cls}{qualifiable-c-type (c-type) \&key :qualifiers} + The class @|qualifiable-c-type| describes C types which can bear + `qualifiers' (\Cplusplus\ calls them `cv-qualifiers'): @|const|, + @|restrict| and @|volatile|. + + The @ are a list of keyword symbols @|:const|, @|:restrict| and + @|:volatile|. There is no built-in limitation to these particular + qualifiers; others keywords may be used, though this isn't recommended. + + Two qualifiable types are equal only if they have \emph{matching + qualifiers}: i.e., every qualifier attached to one is also attached to + the other: order is not significant, and neither is multiplicity. + + The class @|qualifiable-c-type| is abstract. +\end{describe} + +\begin{describe}{gf}{c-type-qualifiers @ @to @} + Returns the qualifiers of the @|qualifiable-c-type| instance @ as an + immutable list. +\end{describe} + +\begin{describe}{fun}{qualify-type @ @} + The argument @ must be an instance of @|qualifiable-c-type|, + currently bearing no qualifiers, and @ a list of qualifier + keywords. The result is a C type object like @ except that it + bears the given @. + + The @ is not modified. If @ is interned, then the returned + type will be interned. +\end{describe} + +\begin{describe}{fun}{format-qualifiers @} + Returns a string containing the qualifiers listed in @ in C + syntax, with a space after each. In particular, if @ is + non-null then the final character of the returned string will be a space. +\end{describe} + +\subsection{Leaf types} \label{sec:proto.c-types.leaf} + +A \emph{leaf type} is a type which is not defined in terms of another type. +In Sod, the leaf types are +\begin{itemize} +\item \emph{simple types}, including builtin types like @|int| and @|char|, + as well as type names introduced by @|typename|, because Sod isn't + interested in what the type name means, merely that it names a type; and +\item \emph{tagged types}, i.e., enum, struct and union types which are named + by a keyword identifying the kind of type, and a \emph{tag}. +\end{itemize} + +\begin{describe}{cls}{simple-c-type (qualifiable-c-type) + \&key :qualifiers :name} + The class of `simple types'; an instance denotes the type @ + @. + + A simple type object maintains a \emph{name}, which is a string whose + contents are the C name for the type. The initarg @|:name| may be used to + provide this name when calling @|make-instance|. + + Two simple type objects are equal if and only if they have @|string=| names + and matching qualifiers. + + A number of symbolic type specifiers for builtin types are predefined as + shown in \xref{tab:proto.c-types.simple}. These are all defined as if by + @|define-simple-c-type|, so can be used to construct qualified types. +\end{describe} + +\begin{table} + \begin{tabular}[C]{|l|l|} \hlx{hv} + \textbf{C type} & \textbf{Specifiers} \\ \hlx{vhv} + @|void| & @|void| \\ \hlx{vhv} + @|char| & @|char| \\ \hlx{v} + @|unsigned char| & @|unsigned-char|, @|uchar| \\ \hlx{v} + @|signed char| & @|signed-char|, @|schar| \\ \hlx{vhv} + @|short| & @|short|, @|signed-short|, @|short-int|, + @|signed-short-int| @|sshort| \\ \hlx{v} + @|unsigned short| & @|unsigned-short|, @|unsigned-short-int|, + @|ushort| \\ \hlx{vhv} + @|int| & @|int|, @|signed|, @|signed-int|, + @|sint| \\ \hlx{v} + @|unsigned int| & @|unsigned|, @|unsigned-int|, @|uint| \\ \hlx{vhv} + @|long| & @|long|, @|signed-long|, @|long-int|, + @|signed-long-int|, @|slong| \\ \hlx{v} + @|unsigned long| & @|unsigned-long|, @|unsigned-long-int|, + @|ulong| \\ \hlx{vhv} + @|long long| & @|long-long|, @|signed-long-long|, + @|long-long-int|, \\ + & \qquad @|signed-long-long-int|, + @|llong|, @|sllong| \\ \hlx{v} + @|unsigned long long| + & @|unsigned-long-long|, @|unsigned-long-long-int|, + @|ullong| \\ \hlx{vhv} + @|float| & @|float| \\ \hlx{v} + @|double| & @|double| \\ \hlx{vhv} + @|va_list| & @|va-list| \\ \hlx{v} + @|size_t| & @|size-t| \\ \hlx{v} + @|ptrdiff_t| & @|ptrdiff-t| \\ \hlx{vh} + \end{tabular} + \caption{Builtin symbolic type specifiers for simple C types} + \label{tab:proto.c-types.simple} +\end{table} + +\begin{describe}{fun}{make-simple-type @ \&optional @} + Return the (unique interned) simple C type object for the C type whose name + is @ (a string) and which has the given @ (a list of + keywords). +\end{describe} + +\begin{describe}{gf}{c-type-name @} + Returns the name of a @|simple-c-type| instance @ as an immutable + string. +\end{describe} + +\begin{describe}{mac}{% + define-simple-c-type @{ @ @! (@^*) @} @} + Define type specifiers for a new simple C type. Each symbol @ is + defined as a symbolic type specifier for the (unique interned) simple C + type whose name is the value of @. Further, each @ is + defined to be a type operator: the type specifier @|(@ + @^*)| evaluates to the (unique interned) simple C type whose + name is @ and which has the @ (which are evaluated). +\end{describe} + +\begin{describe}{cls}{tagged-c-type (qualifiable-c-type) + \&key :qualifiers :tag} + Provides common behaviour for C tagged types. A @ is a string + containing a C identifier. + + Two tagged types are equal if and only if they have the same class, their + @s are @|string=|, and they have matching qualifiers. (User-defined + subclasses may have additional methods on @|c-type-equal-p| which impose + further restrictions.) +\end{describe} +\begin{boxy}[Bug] + Sod maintains distinct namespaces for the three kinds of tagged types. In + C, there is only one namespace for tags which is shared between enums, + structs and unions. +\end{boxy} + +\begin{describe}{gf}{c-tagged-type-kind @} + Returns a symbol classifying the tagged @: one of @|enum|, @|struct| + or @|union|. User-defined subclasses of @|tagged-c-type| should return + their own classification symbols. It is intended that @|(string-downcase + (c-tagged-type-kind @))| be valid C syntax.\footnote{% + Alas, C doesn't provide a syntactic category for these keywords; + \Cplusplus\ calls them a @.} % +\end{describe} + +\begin{describe}{cls}{c-enum-type (tagged-c-type) \&key :qualifiers :tag} + Represents a C enumerated type. An instance denotes the C type @|enum| + @. See the direct superclass @|tagged-c-type| for details. + + The type specifier @|(enum @ @^*)| returns the (unique + interned) enumerated type with the given @ and @s (all + evaluated). +\end{describe} +\begin{describe}{fun}{make-enum-type @ \&optional @} + Return the (unique interned) C type object for the enumerated C type whose + tag is @ (a string) and which has the given @ (a list of + keywords). +\end{describe} + +\begin{describe}{cls}{c-struct-type (tagged-c-type) \&key :qualifiers :tag} + Represents a C structured type. An instance denotes the C type @|struct| + @. See the direct superclass @|tagged-c-type| for details. + + The type specifier @|(struct @ @^*)| returns the (unique + interned) structured type with the given @ and @s (all + evaluated). +\end{describe} +\begin{describe}{fun}{make-struct-type @ \&optional @} + Return the (unique interned) C type object for the structured C type whose + tag is @ (a string) and which has the given @ (a list of + keywords). +\end{describe} + +\begin{describe}{cls}{c-union-type (tagged-c-type) \&key :qualifiers :tag} + Represents a C union type. An instance denotes the C type @|union| + @. See the direct superclass @|tagged-c-type| + for details. + + The type specifier @|(union @ @^*)| returns the (unique + interned) union type with the given @ and @s (all + evaluated). +\end{describe} +\begin{describe}{fun}{make-union-type @ \&optional @} + Return the (unique interned) C type object for the union C type whose tag + is @ (a string) and which has the given @ (a list of + keywords). +\end{describe} + +\subsection{Pointers and arrays} \label{sec:proto.c-types.ptr-array} + +Pointers and arrays are \emph{compound types}: they're defined in terms of +existing types. A pointer describes the type of objects it points to; an +array describes the type of array element. +\begin{describe}{gf}{c-type-subtype @} + Returns the underlying type of a compound type @. Precisely what + this means depends on the class of @. +\end{describe} + +\begin{describe}{cls}{c-pointer-type (qualifiable-c-type) + \&key :qualifiers :subtype} + Represents a C pointer type. An instance denotes the C type @ + @|*|@. + + The @ may be any C type. Two pointer types are equal if and only + if their subtypes are equal and they have matching qualifiers. + + The type specifier @|(* @ @^*)| returns a type + qualified pointer-to-@, where @ is the type specified by + @ and the @s are qualifier keywords (which are + evaluated). The synonyms @|ptr| and @|pointer| may be used in place of the + star @`*'. + + The symbol @|string| is a type specifier for the type of pointer to + characters; the symbol @|const-string| is a type specifier for the type + pointer to constant characters. +\end{describe} +\begin{describe}{fun}{make-pointer-type @ \&optional @} + Return an object describing the type of qualified pointers to @. + If @ is interned, then the returned pointer type object is + interned also. +\end{describe} + +\begin{describe}{cls}{c-array-type (c-type) \&key :subtype :dimensions} + Represents a multidimensional C array type. The @ are a list + of dimension specifiers $d_0$, $d_1$, \ldots, $d_{n-1}$; an instance then + denotes the C type @ @|[$d_0$][$d_1$]$\ldots$[$d_{n-1}$]|. An + individual dimension specifier is either a string containing a C integral + constant expression, or nil which is equivalent to an empty string. Only + the first (outermost) dimension $d_0$ should be empty. + + C doesn't actually have multidimensional arrays as a primitive notion; + rather, it permits an array (with known extent) to be the element type of + an array, which achieves an equivalent effect. C arrays are stored in + row-major order: i.e., if we write down the indices of the elements of an + array in order of ascending address, the rightmost index varies fastest; + hence, the type constructed is more accurately an array of $d_0$ arrays of + $d_1$ of \ldots\ arrays of $d_{n-1}$ elements of type @. We shall + continue to abuse terminology and refer to multidimensional arrays. + + The type specifier @|([] @ @^*)| constructs a + multidimensional array with the given @s whose elements have the + type specified by @. If no dimensions are given then a + single-dimensional array with unspecified extent. The synonyms @|array| + and @|vector| may be used in place of the brackets @`[]'. +\end{describe} +\begin{describe}{fun}{make-array-type @ @} + Return an object describing the type of arrays with given @ and + with element type @ (an instance of @|c-type|). The @ + argument is a list whose elements are strings or nil; see the description + of the class @|c-array-type| above for details. +\end{describe} +\begin{describe}{gf}{c-array-dimensions @} + Returns the dimensions of @, an array type, as an immutable list. +\end{describe} + +\subsection{Function types} \label{sec:proto.c-types.fun} + +\begin{describe}{cls}{c-function-type (c-type) \&key :subtype :arguments} + Represents C function types. An instance denotes the C type of a C + function which +\end{describe} + +%%%----- That's all, folks -------------------------------------------------- + +%%% Local variables: +%%% mode: LaTeX +%%% TeX-master: "sod.tex" +%%% TeX-PDF-mode: t +%%% End: diff --git a/sod-tut.tex b/doc/sod-tut.tex similarity index 100% rename from sod-tut.tex rename to doc/sod-tut.tex diff --git a/sod.tex b/doc/sod.tex similarity index 91% rename from sod.tex rename to doc/sod.tex index dfc4a10..50f6121 100644 --- a/sod.tex +++ b/doc/sod.tex @@ -5,28 +5,58 @@ \usepackage[palatino, helvetica, courier, maths=cmr]{mdwfonts} \usepackage{syntax} \usepackage{sverb} +\usepackage{mdwtab} +\usepackage{footnote} \usepackage{at} \usepackage{mdwref} \title{A Sensible Object Design for C} \author{Mark Wooding} +\makeatletter + +\errorcontextlines999 + \def\syntleft{\normalfont\itshape} \let\syntright\empty -\def\ulitleft{\normalfont\sffamily} +\let\codeface\sffamily + +\def\ulitleft{\normalfont\codeface} \let\ulitright\empty \let\listingsize\relax \let\epsilon\varepsilon -\atdef <#1>{\synt{#1}} -\atdef "#1"{\lit*{#1}} -\atdef `#1'{\lit{#1}} -\atdef |#1|{\textsf{#1}} - -\def\Cplusplus{C\kern-1pt++} +\atdef <#1>{\synt{#1}\@scripts} +\atdef "#1"{\lit*{#1}\@scripts} +\atdef `#1'{\lit{#1}\@scripts} +\atdef |#1|{\textsf{#1}\@scripts} +\def\dbl@maybe#1{\let\@tempa#1\futurelet\@ch\dbl@maybe@i} +\def\dbl@maybe@i{\m@maybe\ifx\@ch\@tempa\@tempa\!\@tempa% + \expandafter\@firstoftwo\expandafter\@scripts% + \else\@tempa\expandafter\@scripts\fi} +\atdef [{\dbl@maybe[} +\atdef ]{\dbl@maybe]} +\atdef {{\m@maybe\{\@scripts} +\atdef }{\m@maybe\}\@scripts} +\atdef ({\m@maybe(\@scripts} +\atdef ){\m@maybe)\@scripts} +\atdef !{\m@maybe|\@scripts} +\atdef to{\leavevmode\unskip\quad\m@maybe\longrightarrow\m@maybe@end\quad} +\let\m@maybe@end\relax +\def\m@maybe{\ifmmode\else$\let\m@maybe@end$\fi} +\def\@scripts{\futurelet\@ch\@scripts@i} + +\atdef ;#1\\{\normalfont\itshape;#1\\} + +\begingroup\lccode`\~=`\_\lowercase{\endgroup +\def\@scripts@i{\if1\ifx\@ch~1\else\ifx\@ch^1\else0\fi\fi% + \expandafter\@scripts@ii\else\expandafter\m@maybe@end\fi}} +\def\@scripts@ii#1#2{\m@maybe#1{#2}\@scripts} + +\def\Cplusplus{C\kern-\p@++} \def\Csharp{C\#} \def\man#1#2{\textbf{#1}(#2)} @@ -34,9 +64,9 @@ \lowercase{ \endgroup \def\prog{% - \sffamily% + \codeface% \quote% - \let\oldnl\\% + \let\old@nl\\% \obeylines% \tabbing% \global\let~\\% @@ -44,10 +74,59 @@ } \def\endprog{% \endtabbing% - \global\let\\\oldnl% + \global\let\\\old@nl% \endquote% }} +\newenvironment{boxy}[1][\q@]{% + \dimen@\linewidth\advance\dimen@-1.2pt\advance\dimen@-2ex% + \medskip% + \vbox\bgroup\hrule\hbox\bgroup\vrule% + \vbox\bgroup\vskip1ex\hbox\bgroup\hskip1ex\minipage\dimen@% + \def\@temp{#1}\ifx\@temp\q@\else\leavevmode{\headfam\bfseries#1\quad}\fi% +}{% + \endminipage\hskip1ex\egroup\vskip1ex\egroup% + \vrule\egroup\hrule\egroup% + \medskip% +} + +\def\definedescribecategory#1#2{\@namedef{cat!#1}{#2}} +\def\describecategoryname#1{% + \expandafter\let\expandafter\@tempa\csname cat!#1\endcsname% + \ifx\@tempa\relax#1\else\@tempa\fi} +\definedescribecategory{fun}{function} +\definedescribecategory{gf}{generic function} +\definedescribecategory{var}{variable} +\definedescribecategory{const}{constant} +\definedescribecategory{meth}{primary method} +\definedescribecategory{ar-meth}{around-method} +\definedescribecategory{be-meth}{before-method} +\definedescribecategory{af-meth}{after-method} +\definedescribecategory{cls}{class} +\definedescribecategory{ty}{type} +\definedescribecategory{mac}{macro} + +\def\q@{\q@} +\newenvironment{describe}[3][\q@]{% + \normalfont% + \par\goodbreak% + \vspace{\bigskipamount}% + \setbox\z@\hbox{\bfseries[\describecategoryname{#2}]}% + \dimen@\linewidth\advance\dimen@-\wd\z@% + \def\@temp##1 ##2\q@{\message{#2:##1}\label{#2:##1}}% + \def\@tempa{#1}\ifx\@tempa\q@\@temp#3 \q@\else\@temp{#1} \\\fi% + \edef\@temp{{\the\linewidth}{@{}p{\the\dimen@}% + @{\extracolsep{\fill}}l@{\extracolsep{0pt}}}}% + \noindent\csname tabular*\expandafter\endcsname\@temp% + \tabbing\codeface#3\endtabbing&\unhbox\z@\\\endtabular% +% \@afterheading% + \list{}{\rightmargin\z@}\item% +}{% + \endlist% +} + +\def\push{\quad\=\+\kill} + \begin{document} \maketitle diff --git a/standard-method-combination.svg b/doc/standard-method-combination.svg similarity index 100% rename from standard-method-combination.svg rename to doc/standard-method-combination.svg diff --git a/emacs-hacks.el b/emacs-hacks.el new file mode 100644 index 0000000..c807c28 --- /dev/null +++ b/emacs-hacks.el @@ -0,0 +1,14 @@ +(dolist (entry '((parse 0) + (many 1) + (skip-many 1) + (seq 1) + (lisp 0) + (if-parse 2) + (if-char 2) + (expr 1) + (acond . cond) + (define-class-slot 3))) + (put (car entry) 'common-lisp-indent-function + (if (symbolp (cdr entry)) + (get (cdr entry) 'common-lisp-indent-function) + (cadr entry)))) \ No newline at end of file diff --git a/layout.org b/layout.org deleted file mode 100644 index 2bc237a..0000000 --- a/layout.org +++ /dev/null @@ -1,141 +0,0 @@ -* Instance layout - -This is fairly easy. The superclasses are partitioned into chains. -Each chain is named after its head class (i.e., the class with no -successor). - -** Things in instance layouts - -An instance layout contains a chunk for each component chain. - - struct CLASS__ilayout { - struct CLASS__ichain_CHAINn NICKn; - /* ... */ - }; - -An ilayout is a C structure consisting of an ichain for each of the -class's chains, with the primary chain first. The others are in -direct-superclass order. - -** Instance slots - -An islots structure is a C structure consisting of a class's instance -slots, in order. - - struct CLASS__islots { - TYPEn SLOTn; - /* ... */ - }; - -If a class defines no slots then it has no islots structure. - -** Instance chains - - struct CLASS__ichain_CHAIN { - const struct CLASS__vt_CHAIN *_vt; - struct SUPERn__islots NICKn; - /* ... */ - }; - -A ichain is a C structure consisting of: - - * A pointer `_vt' to the chain's vtable structure. - - * An islots substructure, named after the class's nick for each class - on the chain, least-specific first. - -Because of the chain invariant, all of a class's ichains are prefixes of -the corresponding ichains of any of its subclasses. - -The type CLASS is an alias for the class's primary ichain -CLASS__ichain_CHAIN. One needs to do a cross-chain upcast to find slots -in non-primary chains. - -* Vtable layout - -This is more complicated. The vtable for a chain doesn't just contain -things directly relevant to the classes on the chain: because a vtable -is (assumed) immutable, we can have copies of values from other chains -where this is convenient. - -Note that effective methods are customized for particular classes: they -can assume that their argument points to a specific ichain of a an -instance of a specific class. This makes conversions in effective -methods very cheap. By including apparently effective-method pointers -for messages defined in other chains, we can speed up dispatch. - -** Things in a vtable chain - -There are three kinds of items to store in a vtable chain. - - * Class pointers - * The base offset - * Chain offsets - * Effective method pointers - - struct CLASS__vt_CHAIN { - struct METACLASS__ichain_sod_object *_class; - size_t _base; - struct METACLASS__ichain_METACHAINn *_cls_NICKn; - ptrdiff_t _off_CHAINn; - struct SUPERn__vtmsgs NICKn; - }; - -A class has a separate vtable chain for each of its chains. - -** The base offset - -There is a single member _base which is the offset of the chain's ichain -in the overall ilayout structure. This lets you find the bottom of the -ilayout given a pointer to any ichain as - - (CLASS__ilayout *)((char *)p - p->_vt._base) - -** Class pointers - -The class's metaclass may have multiple chains. For each chain of the -metaclass, there is a separate pointer to that metaclass's ichain, named -_cls_NICKn after the metaclass's chain head. Exception: _cls_cls is -called _class instead. - -** Chain offsets - -For each other chain, there is a member _off_NICKn named after the -chain's head giving the offset of that ichain from the current chain's -ichain. (There's a long way around, exploring the class's layout -information, but this provides a much easier way of doing cross-chain -upcasts.) - -** Effective method pointers - -For each class, there may be a structure - - struct CLASS__vtmsgs { - TYPEn (*MSGn)(ARGnn *, ...); - /* ... */ - }; - -of pointers to effective methods for the messages defined by the class. -If a class defines no messages then it won't have a vtmsgs structure. - -** Layout order - -The first two items are always _class and _base. After that: - - * for each class in the chain, from least to most specific, - - * for each of that class's superclasses, in reverse class-precedence- - list order, which has not yet been processed: - - * if the class is in a chain which hasn't been seen before (it must be - the chain head!), emit a chain offset for it; - - * if the class has a metaclass chain which hasn't been seen before, - emit a class pointer for it; - - * if the class has a vtmsgs structure, emit it. - -* Questions - -Are class-slot initializers inherited? No. We have instance -initializers on metaclasses for that. diff --git a/sod.c b/lib/sod.c similarity index 95% rename from sod.c rename to lib/sod.c index 24a6429..bd600f9 100644 --- a/sod.c +++ b/lib/sod.c @@ -7,7 +7,7 @@ /*----- Licensing notice --------------------------------------------------* * - * This file is part of the Simple Object Definition system. + * This file is part of the Sensble 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 @@ -79,8 +79,8 @@ static const struct sod_chain *find_chain(const SodClass *sub, * Returns: Nonzero if @sub@ is a subclass of @super@. */ -int sod_subclassp(const SodClass *c, const SodClass *d) - { return (!!find_chain(c, d)); } +int sod_subclassp(const SodClass *sub, const SodClass *super) + { return (!!find_chain(sub, super)); } /* --- @sod_convert@ --- * * diff --git a/sod.h b/lib/sod.h similarity index 91% rename from sod.h rename to lib/sod.h index 999c30e..12c7817 100644 --- a/sod.h +++ b/lib/sod.h @@ -7,7 +7,7 @@ /*----- Licensing notice --------------------------------------------------* * - * This file is part of the Simple Object Definition system. + * This file is part of the Sensble 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 @@ -44,7 +44,7 @@ * pointer to one of these. */ struct sod_vtable { - SodClass *_class; /* Pointer to class object */ + const SodClass *_class; /* Pointer to class object */ size_t _base; /* Offset to instance base */ }; @@ -141,12 +141,12 @@ struct sod_chain { /* --- @sod_subclassp@ --- * * - * Arguments: @const SodClass *c, *d@ = pointers to two classes + * Arguments: @const SodClass *sub, *super@ = pointers to two classes * * Returns: Nonzero if @c@ is a subclass of @d@. */ -extern int sod_subclassp(const SodClass */*c*/, const SodClass */*d*/); +extern int sod_subclassp(const SodClass */*sub*/, const SodClass */*super*/); /* --- @sod_convert@ --- * * @@ -159,19 +159,19 @@ extern int sod_subclassp(const SodClass */*c*/, const SodClass */*d*/); * Use: General down/cross-casting function. * * Upcasts can be performed efficiently using the automatically - * generated macros. In particular, upcasts with a chain are + * generated macros. In particular, upcasts within a chain are * trivial; cross-chain upcasts require information from vtables * but are fairly fast. This function is rather slower, but is * much more general. * * Suppose we have an instance of a class C, referred to by a - * pointer to an instance of one of C's superclasses S. If S' + * pointer to an instance of one of C's superclasses S. If T * is some other superclass of C then this function will return - * a pointer to C suitable for use as an instance of S'. If S' + * a pointer to C suitable for use as an instance of T. If T * is not a superclass of C, then the function returns null. * (If the pointer doesn't point to an instance of some class * then the behaviour is undefined.) Note that you don't need - * to know what C or S actually are. + * to know what either C or S actually are. */ extern void *sod_convert(const SodClass */*cls*/, void */*p*/); diff --git a/output.lisp b/output.lisp deleted file mode 100644 index b0df32b..0000000 --- a/output.lisp +++ /dev/null @@ -1,259 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Output driver for SOD translator -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Sequencing machinery. - -(defclass sequencer-item () - ((name :initarg :name :reader sequencer-item-name) - (functions :initarg :functions :initform nil - :type list :accessor sequencer-item-functions)) - (:documentation - "Represents a distinct item to be sequenced by a SEQUENCER. - - A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the - sequencer is invoked. This class is not intended to be subclassed.")) - -(defmethod print-object ((item sequencer-item) stream) - (print-unreadable-object (item stream :type t) - (prin1 (sequencer-item-name item) stream))) - -(defclass sequencer () - ((constraints :initarg :constraints :initform nil - :type list :accessor sequencer-constraints) - (table :initform (make-hash-table :test #'equal) - :reader sequencer-table)) - (:documentation - "A sequencer tracks items and invokes them in the proper order. - - The job of a SEQUENCER object is threefold. Firstly, it collects - sequencer items and stores them in its table indexed by name. Secondly, - it gathers CONSTRAINTS, which impose an ordering on the items. Thirdly, - it can be instructed to invoke the items in an order compatible with the - established constraints. - - Sequencer item names may may any kind of object which can be compared with - EQUAL. In particular, symbols, integers and strings are reasonable - choices for atomic names, and lists work well for compound names -- so - it's possible to construct a hierarchy.")) - -(defgeneric ensure-sequencer-item (sequencer name) - (:documentation - "Arrange that SEQUENCER has a sequencer-item called NAME. - - Returns the corresponding SEQUENCER-ITEM object.")) - -(defgeneric add-sequencer-constraint (sequencer constraint) - (:documentation - "Attach the given CONSTRAINT to an SEQUENCER. - - The CONSTRAINT should be a list of sequencer-item names; see - ENSURE-SEQUENCER-ITEM for what they look like. Note that the names - needn't have been declared in advance; indeed, they needn't be mentioned - anywhere else at all.")) - -(defgeneric add-sequencer-item-function (sequencer name function) - (:documentation - "Arranges to call FUNCTION when the item called NAME is traversed. - - More than one function can be associated with a given sequencer item. - They are called in the same order in which they were added. - - Note that an item must be mentioned in at least one constraint in order to - be traversed by INVOKE-SEQUENCER-ITEMS. If there are no special ordering - requirments for a particular item, then the trivial constraint (NAME) will - suffice.")) - -(defgeneric invoke-sequencer-items (sequencer &rest arguments) - (:documentation - "Invoke functions attached to the SEQUENCER's items in the right order. - - Each function is invoked in turn with the list of ARGUMENTS. The return - values of the functions are discarded.")) - -(defmethod ensure-sequencer-item ((sequencer sequencer) name) - (with-slots (table) sequencer - (or (gethash name table) - (setf (gethash name table) - (make-instance 'sequencer-item :name name))))) - -(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list)) - (let ((converted-constraint (mapcar (lambda (name) - (ensure-sequencer-item sequencer - name)) - constraint))) - (with-slots (constraints) sequencer - (pushnew converted-constraint constraints :test #'equal)))) - -(defmethod add-sequencer-item-function ((sequencer sequencer) name function) - (let ((item (ensure-sequencer-item sequencer name))) - (pushnew function (sequencer-item-functions item)))) - -(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments) - (dolist (item (merge-lists (reverse (sequencer-constraints sequencer)))) - (dolist (function (reverse (sequencer-item-functions item))) - (apply function arguments)))) - -;;;-------------------------------------------------------------------------- -;;; Output preparation. - -(defgeneric add-output-hooks (object reason sequencer) - (:documentation - "Announces the intention to write SEQUENCER, with a particular REASON. - - The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which - can be matched using an EQL-specializer. In response, OBJECT should add - any constrains and item functions that it wishes, and pass the - announcement to its sub-objects.") - (:method-combination progn) - (:method progn (object reason sequencer) - nil)) - -(defvar *seen-announcement*) ;Keep me unbound! -#+hmm -(defmethod add-output-hooks :around (object reason sequencer &rest stuff) - "Arrange not to invoke any object more than once during a particular - announcement." - (declare (ignore stuff)) - (cond ((not (boundp '*seen-announcement*)) - (let ((*seen-announcement* (make-hash-table))) - (setf (gethash object *seen-announcement*) t) - (call-next-method))) - ((gethash object *seen-announcement*) - nil) - (t - (setf (gethash object *seen-announcement*) t) - (call-next-method)))) - -;;;-------------------------------------------------------------------------- -;;; Utilities. - -;;;-------------------------------------------------------------------------- -;;; Header output. - -(defun write-module-header (module) - (let* ((file (merge-pathnames (make-pathname :type "H" :case :common) - (module-name module))) - (fakename (make-pathname :name (pathname-name file) - :type (pathname-type file)))) - (with-open-file (uoutput file - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (let ((output (make-instance 'position-aware-output-stream - :stream uoutput - :file fakename))) - - ;; Format the header and guards. - (format output "~ -/* -*-c-*- - * - * Header file generated by SOD for ~A - */ - -#ifndef ~A -#define ~:*~A - -#ifdef __cplusplus - extern \"C\" { -#endif~%" - (namestring (module-name module)) - (or (getf (module-plist module) 'include-guard) - )) - - ;; Forward declarations of all the structures and types. Nothing - ;; interesting gets said here; this is just so that the user code - ;; can talk meainingfully about the things we're meant to be - ;; defining here. - ;; - ;; FIXME - - ;; The user fragments. - (when (module-header-fragments module) - (banner "User code" output) - (dolist (frag (module-header-fragments module)) - (princ frag output))) - - ;; The definitions of the necessary structures. - ;; - ;; FIXME - - ;; The definitions of the necessary direct-methods. - ;; - ;; FIXME - - ;; The trailer section. - (banner "That's all, folks" output) - (format output "~ -#ifdef __cplusplus - } -#endif - -#endif~%"))))) - -;;;-------------------------------------------------------------------------- -;;; Source output. - -(defun write-module-source (module) - (let* ((file (merge-pathnames (make-pathname :type "C" :case :common) - (module-name module))) - (fakename (make-pathname :name (pathname-name file) - :type (pathname-type file)))) - (with-open-file (uoutput file - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (let ((output (make-instance 'position-aware-output-stream - :stream uoutput - :file fakename))) - - ;; Format the header. - (format output "~ -/* -*-c-*- - * - * Source file generated by SOD for ~A - */~%" - (namestring (module-name module))) - - ;; The user fragments. - (when (module-source-fragments module) - (banner "User code" output) - (dolist (frag (module-source-fragments module)) - (princ frag output))) - - ;; The definitions of the necessary tables. - ;; - ;; FIXME - - ;; The definitions of the necessary effective-methods. - ;; - ;; FIXME - - ;; The trailer section. - (banner "That's all, folks" output :blank-line-p nil))))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/builtin.lisp b/pre-reorg/builtin.lisp new file mode 100644 index 0000000..ef99571 --- /dev/null +++ b/pre-reorg/builtin.lisp @@ -0,0 +1,42 @@ +;;; -*-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) + +;;;-------------------------------------------------------------------------- +;;; 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 -------------------------------------------------- diff --git a/pre-reorg/c-types.lisp b/pre-reorg/c-types.lisp new file mode 100644 index 0000000..4a443cd --- /dev/null +++ b/pre-reorg/c-types.lisp @@ -0,0 +1,79 @@ +;;; -*-lisp-*- +;;; +;;; Dealing with C types +;;; +;;; (c) 2008 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) + +;;;-------------------------------------------------------------------------- +;;; Plain old C types. + +;; Class definition. + +;; Important protocol. + +;; Utility functions and macros. + +;; S-expression syntax machinery. + +;; Basic definitions. + +;; A handy utility. + +;;;-------------------------------------------------------------------------- +;;; Simple C types (e.g., built-in arithmetic types). + +;; Basic definitions. + +(let ((cache (make-hash-table :test #'equal))) + +;;;-------------------------------------------------------------------------- +;;; Tag types (structs, unions and enums). + +;; Definitions. + +;;;-------------------------------------------------------------------------- +;;; Pointer types. + +;; Definitions. + +(let ((cache (make-hash-table :test #'eql))) + +;; S-expression syntax. + +;;;-------------------------------------------------------------------------- +;;; Array types. + +;; Definitions. + + +;;;-------------------------------------------------------------------------- +;;; Function types. + +;; Arguments. + +;; Definitions. + +;; S-expression syntax. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/class-builder.lisp b/pre-reorg/class-builder.lisp new file mode 100644 index 0000000..5107ffb --- /dev/null +++ b/pre-reorg/class-builder.lisp @@ -0,0 +1,129 @@ +;;; -*-lisp-*- +;;; +;;; Equipment for building classes and friends +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Finding things by name + +(defun find-superclass-by-nick (class nick) + "Returns the superclass of CLASS with nickname NICK, or signals an error." + + ;; Slightly tricky. The class almost certainly hasn't been finalized, so + ;; trundle through its superclasses and hope for the best. + (if (string= nick (sod-class-nickname class)) + class + (or (some (lambda (super) + (find nick (sod-class-precedence-list super) + :key #'sod-class-nickname + :test #'string=)) + (sod-class-direct-superclasses class)) + (error "No superclass of `~A' with nickname `~A'" class nick)))) + +(flet ((find-item-by-name (what class list name key) + (or (find name list :key key :test #'string=) + (error "No ~A in class `~A' with name `~A'" what class name)))) + + (defun find-instance-slot-by-name (class super-nick slot-name) + (let ((super (find-superclass-by-nick class super-nick))) + (find-item-by-name "slot" super (sod-class-slots super) + slot-name #'sod-slot-name))) + + (defun find-class-slot-by-name (class super-nick slot-name) + (let* ((meta (sod-class-metaclass class)) + (super (find-superclass-by-nick meta super-nick))) + (find-item-by-name "slot" super (sod-class-slots super) + slot-name #'sod-slot-name))) + + (defun find-message-by-name (class super-nick message-name) + (let ((super (find-superclass-by-nick class super-nick))) + (find-item-by-name "message" super (sod-class-messages super) + message-name #'sod-message-name)))) + +;;;-------------------------------------------------------------------------- +;;; Class construction. + +(defun make-sod-class (name superclasses pset &optional location) + "Construct and return a new SOD class with the given NAME and SUPERCLASSES. + + This is the main constructor function for classes. The protocol works as + follows. The :LISP-CLASS property in PSET is checked: if it exists, it + must be a symbol naming a (CLOS) class, which is used in place of + SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further + behaviour is left to the standard CLOS instance construction protocol; for + example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE. + + Minimal sanity checking is done during class construction; most of it is + left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS). + + Unused properties in PSET are diagnosed as errors." + + (with-default-error-location (location) + (let ((class (make-instance (get-property pset :lisp-class :symbol + 'sod-class) + :name name + :superclasses superclasses + :location (file-location location) + :pset pset))) + (check-unused-properties pset) + class))) + +(defgeneric guess-metaclass (class) + (:documentation + "Determine a suitable metaclass for the CLASS. + + The default behaviour is to choose the most specific metaclass of any of + the direct superclasses of CLASS, or to signal an error if that failed.")) + +;;;-------------------------------------------------------------------------- +;;; Slot construction. + +(defgeneric make-sod-slot (class name type pset &optional location) + (:documentation + "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. + + This is the main constructor function for slots. This is a generic + function primarily so that the CLASS can intervene in the construction + process. The default method uses the :LISP-CLASS property (defaulting to + SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then + constructed by MAKE-INSTANCE passing the arguments as initargs; further + behaviour is left to the standard CLOS instance construction protocol; for + example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE. + + Unused properties on PSET are diagnosed as errors.")) + +;;;-------------------------------------------------------------------------- +;;; Slot initializer construction. + +;;;-------------------------------------------------------------------------- +;;; Message construction. + +;;;-------------------------------------------------------------------------- +;;; Method construction. + +;;;-------------------------------------------------------------------------- +;;; Builder macros. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/class-defs.lisp b/pre-reorg/class-defs.lisp similarity index 100% rename from class-defs.lisp rename to pre-reorg/class-defs.lisp diff --git a/pre-reorg/class-finalize.lisp b/pre-reorg/class-finalize.lisp new file mode 100644 index 0000000..fc2d967 --- /dev/null +++ b/pre-reorg/class-finalize.lisp @@ -0,0 +1,31 @@ +;;; -*-lisp-*- +;;; +;;; Class finalization +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Class finalization. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/class-layout.lisp b/pre-reorg/class-layout.lisp new file mode 100644 index 0000000..8b6b1eb --- /dev/null +++ b/pre-reorg/class-layout.lisp @@ -0,0 +1,80 @@ +;;; -*-lisp-*- +;;; +;;; Layout for instances and vtables +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Effective slot objects. + +(defclass effective-slot () + ((class :initarg :class :type sod-slot :reader effective-slot-class) + (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot) + (initializer :initarg :initializer :type (or sod-initializer null) + :reader effective-slot-initializer)) + (:documentation + "Describes a slot and how it's meant to be initialized. + + Effective slot objects are usually attached to layouts.")) + +(defgeneric find-slot-initializer (class slot) + (:documentation + "Return the most specific initializer for SLOT, starting from CLASS.")) + +(defgeneric compute-effective-slot (class slot) + (:documentation + "Construct an effective slot from the supplied direct slot. + + SLOT is a direct slot defined on CLASS or one of its superclasses. + (Metaclass initializers are handled using a different mechanism.)")) + +;;;-------------------------------------------------------------------------- +;;; Instance layout objects. + +(defclass islots () + ((class :initarg :class :type sod-class :reader islots-class) + (subclass :initarg :subclass :type sod-class :reader islots-subclass) + (slots :initarg :slots :type list :reader islots-slots)) + (:documentation + "The collection of effective SLOTS defined by an instance of CLASS.")) + +;;; Standard implementation. + +;;;-------------------------------------------------------------------------- +;;; Effective methods. + +;;;-------------------------------------------------------------------------- +;;; Vtable layout. + +;;; vtmsgs + +;;; base-offset + +;;; chain-offset + +;;; vtable + +;;; Implementation. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/class-output.lisp b/pre-reorg/class-output.lisp similarity index 78% rename from class-output.lisp rename to pre-reorg/class-output.lisp index da6531b..b93a0a0 100644 --- a/class-output.lisp +++ b/pre-reorg/class-output.lisp @@ -26,40 +26,10 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Utility macro. - -(defmacro sequence-output - ((streamvar sequencer) &body clauses) - (let ((seqvar (gensym "SEQ"))) - (labels ((convert-item-name (name) - (if (listp name) - (cons 'list name) - name)) - (convert-constraint (constraint) - (cons 'list (mapcar #'convert-item-name constraint))) - (process-body (clauses) - (if (eq (car clauses) :constraint) - (cons `(add-sequencer-constraint - ,seqvar - ,(convert-constraint (cadr clauses))) - (process-body (cddr clauses))) - (mapcar (lambda (clause) - (let ((name (car clause)) - (body (cdr clause))) - `(add-sequencer-item-function - ,seqvar - ,(convert-item-name name) - (lambda (,streamvar) - ,@body)))) - clauses)))) - `(let ((,seqvar ,sequencer)) - ,@(process-body clauses))))) - -;;;-------------------------------------------------------------------------- ;;; Classes. -(defmethod add-output-hooks progn - ((class sod-class) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((class sod-class) (reason (eql :h)) + sequencer) ;; Main output sequencing. (sequence-output (stream sequencer) @@ -103,7 +73,7 @@ ;; Maybe generate an islots structure. (when (sod-class-slots class) (dolist (slot (sod-class-slots class)) - (add-output-hooks slot 'populate-islots sequencer)) + (hook-output slot 'islots sequencer)) (sequence-output (stream sequencer) ((class :islots :start) (format stream "/* Instance slots. */~@ @@ -136,35 +106,39 @@ (terpri stream))))) ;; Generate vtmsgs structure for all superclasses. - (add-output-hooks (car (sod-class-vtables class)) - 'populate-vtmsgs + (hook-output (car (sod-class-vtables class)) + 'vtmsgs sequencer)) -(defmethod add-output-hooks progn ((class sod-class) reason sequencer) +(defmethod hook-output progn ((class sod-class) reason sequencer) (with-slots (ilayout vtables methods effective-methods) class - (add-output-hooks ilayout reason sequencer) - (dolist (method methods) (add-output-hooks method reason sequencer)) + (hook-output ilayout reason sequencer) + (dolist (method methods) (hook-output method reason sequencer)) (dolist (method effective-methods) - (add-output-hooks method reason sequencer)) - (dolist (vtable vtables) (add-output-hooks vtable reason sequencer)))) + (hook-output method reason sequencer)) + (dolist (vtable vtables) (hook-output vtable reason sequencer)))) ;;;-------------------------------------------------------------------------- ;;; Instance structure. -(defmethod add-output-hooks progn - ((slot sod-slot) (reason (eql 'populate-islots)) sequencer) +(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots)) + sequencer) (sequence-output (stream sequencer) (((sod-slot-class slot) :islots :slots) (pprint-logical-block (stream nil :prefix " " :suffix ";") (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot))) (terpri stream)))) -(defmethod add-output-hooks progn ((ilayout ilayout) reason sequencer) +(defmethod hook-output progn ((ilayout ilayout) reason sequencer) (with-slots (ichains) ilayout - (dolist (ichain ichains) (add-output-hooks ichain reason sequencer)))) + (dolist (ichain ichains) (hook-output ichain reason sequencer)))) -(defmethod add-output-hooks progn - ((ilayout ilayout) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((ichain ichain) reason sequencer) + (dolist (item (ichain-body ichain)) + (hook-output item reason sequencer))) + +(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) + sequencer) (with-slots (class ichains) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) @@ -174,10 +148,10 @@ ((class :ilayout :end) (format stream "};~2%"))) (dolist (ichain ichains) - (add-output-hooks ichain 'populate-ilayout sequencer)))) + (hook-output ichain 'ilayout sequencer)))) -(defmethod add-output-hooks progn - ((ichain ichain) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) + sequencer) (with-slots (class chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -197,13 +171,17 @@ ~:{ struct ~A ~A;~%~}~ };~2%" (ichain-union-tag chain-tail chain-head) + + ;; Make sure the most specific class is first: only the + ;; first element of a union can be statically initialized in + ;; C90. (mapcar (lambda (super) (list (ichain-struct-tag super chain-head) (sod-class-nickname super))) (sod-class-chain chain-tail)))))))) -(defmethod add-output-hooks progn - ((ichain ichain) (reason (eql 'populate-ilayout)) sequencer) +(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout)) + sequencer) (with-slots (class chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) @@ -211,20 +189,20 @@ (ichain-union-tag chain-tail chain-head) (sod-class-nickname chain-head)))))) -(defmethod add-output-hooks progn - ((vtptr vtable-pointer) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h)) + sequencer) (with-slots (class chain-head chain-tail) vtptr (sequence-output (stream sequencer) ((class :ichain chain-head :slots) (format stream " const struct ~A *_vt;~%" (vtable-struct-tag chain-tail chain-head)))))) -(defmethod add-output-hooks progn ((islots islots) reason sequencer) +(defmethod hook-output progn ((islots islots) reason sequencer) (dolist (slot (islots-slots islots)) - (add-output-hooks slot reason sequencer))) + (hook-output slot reason sequencer))) -(defmethod add-output-hooks progn - ((islots islots) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((islots islots) (reason (eql :h)) + sequencer) (with-slots (class subclass slots) islots (sequence-output (stream sequencer) ((subclass :ichain (sod-class-chain-head class) :slots) @@ -235,12 +213,12 @@ ;;;-------------------------------------------------------------------------- ;;; Vtable structure. -(defmethod add-output-hooks progn ((vtable vtable) reason sequencer) +(defmethod hook-output progn ((vtable vtable) reason sequencer) (with-slots (body) vtable - (dolist (item body) (add-output-hooks item reason sequencer)))) + (dolist (item body) (hook-output item reason sequencer)))) -(defmethod add-output-hooks progn - ((method sod-method) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((method sod-method) (reason (eql :h)) + sequencer) (with-slots (class) method (sequence-output (stream sequencer) ((class :methods) @@ -250,8 +228,8 @@ (sod-method-function-name method)) (format stream ";~%")))))) -(defmethod add-output-hooks progn - ((vtable vtable) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) + sequencer) (with-slots (class chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) @@ -272,8 +250,8 @@ (vtable-struct-tag chain-tail chain-head) class (sod-class-nickname chain-head)))))) -(defmethod add-output-hooks progn - ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) + sequencer) (with-slots (class subclass chain-head chain-tail) vtmsgs (sequence-output (stream sequencer) ((subclass :vtable chain-head :slots) @@ -281,8 +259,8 @@ (vtmsgs-struct-tag subclass class) (sod-class-nickname class)))))) -(defmethod add-output-hooks progn - ((vtmsgs vtmsgs) (reason (eql 'populate-vtmsgs)) sequencer) +(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) + sequencer) (when (vtmsgs-entries vtmsgs) (with-slots (class subclass) vtmsgs (sequence-output (stream sequencer) @@ -299,16 +277,16 @@ ((subclass :vtmsgs class :end) (format stream "};~2%")))))) -(defmethod add-output-hooks progn ((vtmsgs vtmsgs) reason sequencer) +(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer) (with-slots (entries) vtmsgs - (dolist (entry entries) (add-output-hooks entry reason sequencer)))) + (dolist (entry entries) (hook-output entry reason sequencer)))) -(defmethod add-output-hooks progn ((entry method-entry) reason sequencer) +(defmethod hook-output progn ((entry method-entry) reason sequencer) (with-slots (method) entry - (add-output-hooks method reason sequencer))) + (hook-output method reason sequencer))) -(defmethod add-output-hooks progn - ((entry method-entry) (reason (eql 'populate-vtmsgs)) sequencer) +(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs)) + sequencer) (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (class (effective-method-class method)) @@ -320,8 +298,8 @@ (pprint-c-type commented-type stream (sod-message-name message))) (terpri stream))))) -(defmethod add-output-hooks progn - ((cptr class-pointer) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h)) + sequencer) (with-slots (class chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) ((class :vtable chain-head :slots) @@ -331,15 +309,15 @@ (sod-class-nickname meta-chain-head) nil)))))) -(defmethod add-output-hooks progn - ((boff base-offset) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) + sequencer) (with-slots (class chain-head) boff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (write-line " size_t _base;" stream))))) -(defmethod add-output-hooks progn - ((choff chain-offset) (reason (eql :h)) sequencer) +(defmethod hook-output progn ((choff chain-offset) (reason (eql :h)) + sequencer) (with-slots (class chain-head target-head) choff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) @@ -351,8 +329,8 @@ (defvar *instance-class*) -(defmethod add-output-hooks progn - ((class sod-class) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((class sod-class) (reason (eql :c)) + sequencer) (sequence-output (stream sequencer) :constraint @@ -377,18 +355,18 @@ const struct ~A ~A__classobj = {~%" (format stream "};~2%"))) (let ((*instance-class* class)) - (add-output-hooks (sod-class-ilayout (sod-class-metaclass class)) - 'populate-class + (hook-output (sod-class-ilayout (sod-class-metaclass class)) + 'class sequencer))) ;;;-------------------------------------------------------------------------- ;;; Direct methods. -(defmethod add-output-hooks progn - ((method delegating-direct-method) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)) + sequencer) (with-slots (class body) method (unless body - (return-from add-output-hooks)) + (return-from hook-output)) (sequence-output (stream sequencer) ((class :direct-method method :start) (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%" @@ -398,11 +376,11 @@ const struct ~A ~A__classobj = {~%" ((class :direct-method method :end) (format stream "#undef CALL_NEXT_METHOD~%"))))) -(defmethod add-output-hooks progn - ((method sod-method) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((method sod-method) (reason (eql :c)) + sequencer) (with-slots (class body) method (unless body - (return-from add-output-hooks)) + (return-from hook-output)) (sequence-output (stream sequencer) :constraint ((class :direct-methods :start) (class :direct-method method :start) @@ -422,8 +400,8 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Vtables. -(defmethod add-output-hooks progn - ((vtable vtable) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) + sequencer) (with-slots (class chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -439,8 +417,8 @@ const struct ~A ~A__classobj = {~%" ((class :vtable chain-head :end) (format stream "};~2%"))))) -(defmethod add-output-hooks progn - ((cptr class-pointer) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c)) + sequencer) (with-slots (class chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -452,8 +430,8 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname meta-chain-head) (sod-class-nickname metaclass)))))) -(defmethod add-output-hooks progn - ((boff base-offset) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) + sequencer) (with-slots (class chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -464,8 +442,8 @@ const struct ~A ~A__classobj = {~%" (ilayout-struct-tag class) (sod-class-nickname chain-head)))))) -(defmethod add-output-hooks progn - ((choff chain-offset) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((choff chain-offset) (reason (eql :c)) + sequencer) (with-slots (class chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) @@ -477,8 +455,8 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname chain-head) (sod-class-nickname target-head)))))) -(defmethod add-output-hooks progn - ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) + sequencer) (with-slots (class subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) @@ -492,8 +470,8 @@ const struct ~A ~A__classobj = {~%" ((subclass :vtable chain-head :vtmsgs class :end) (format stream " },~%"))))) -(defmethod add-output-hooks progn - ((entry method-entry) (reason (eql :c)) sequencer) +(defmethod hook-output progn ((entry method-entry) (reason (eql :c)) + sequencer) (with-slots (method chain-head chain-tail) entry (let* ((message (effective-method-message method)) (class (effective-method-class method)) @@ -506,8 +484,8 @@ const struct ~A ~A__classobj = {~%" ;;;-------------------------------------------------------------------------- ;;; Filling in the class object. -(defmethod add-output-hooks progn - ((ichain ichain) (reason (eql 'populate-class)) sequencer) +(defmethod hook-output progn ((ichain ichain) (reason (eql 'class)) + sequencer) (with-slots (class chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) @@ -520,8 +498,8 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object chain-head :ichain :end) (format stream " } },~%"))))) -(defmethod add-output-hooks progn - ((islots islots) (reason (eql 'populate-class)) sequencer) +(defmethod hook-output progn ((islots islots) (reason (eql 'class)) + sequencer) (with-slots (class) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) @@ -535,8 +513,8 @@ const struct ~A ~A__classobj = {~%" ((*instance-class* :object class :slots :end) (format stream " },~%")))))) -(defmethod add-output-hooks progn - ((vtptr vtable-pointer) (reason (eql 'populate-class)) sequencer) +(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class)) + sequencer) (with-slots (class chain-head chain-tail) vtptr (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -569,8 +547,7 @@ const struct ~A ~A__classobj = {~%" (:compound (format stream " ~@<{ ~;~A~; },~:>~%" (sod-initializer-value-form init))))))) -(defmethod add-output-hooks progn ((slot sod-class-effective-slot) - (reason (eql 'populate-class)) +(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class)) sequencer) (let ((instance *instance-class*) (func (effective-slot-prepare-function slot))) @@ -579,8 +556,8 @@ const struct ~A ~A__classobj = {~%" ((instance :object :prepare) (funcall func instance stream)))))) -(defmethod add-output-hooks progn - ((slot effective-slot) (reason (eql 'populate-class)) sequencer) +(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class)) + sequencer) (with-slots (class (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) @@ -595,7 +572,7 @@ const struct ~A ~A__classobj = {~%" (defun test (name) (let ((sequencer (make-instance 'sequencer)) (class (find-sod-class name))) - (add-output-hooks class :h sequencer) + (hook-output class :h sequencer) (invoke-sequencer-items sequencer *standard-output*) sequencer)) diff --git a/pre-reorg/codegen.lisp b/pre-reorg/codegen.lisp new file mode 100644 index 0000000..c177a6a --- /dev/null +++ b/pre-reorg/codegen.lisp @@ -0,0 +1,89 @@ +;;; -*-lisp-*- +;;; +;;; Code generator for effective methods +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Temporary names. + +;;;-------------------------------------------------------------------------- +;;; Instructions. + +;;;-------------------------------------------------------------------------- +;;; Instruction types. +;; Top level things. + +;;;-------------------------------------------------------------------------- +;;; Code generator objects. + +(defgeneric emit-inst (codegen inst) + (:documentation + "Add INST to the end of CODEGEN's list of instructions.") + (:method )) + +(defgeneric emit-insts (codegen insts) + (:documentation + "Add a list of INSTS to the end of CODEGEN's list of instructions.") + (:method)) + +(defgeneric ensure-var (codegen name type &optional init) + (:documentation + "Add a variable to CODEGEN's list. + + The variable is called NAME (which should be comparable using EQUAL and + print to an identifier) and has the given TYPE. If INIT is present and + non-nil it is an expression INST used to provide the variable with an + initial value.") + (:method)) + +(defgeneric codegen-push (codegen) + (:documentation + "Pushes the current code generation state onto a stack. + + The state consists of the accumulated variables and instructions, i.e., + what is representable by a BASIC-CODEGEN.") + (:method)) + +(defgeneric codegen-pop (codegen) + (:documentation + "Pops a saved state off of the CODEGEN's stack. + + Returns the newly accumulated variables and instructions as lists, as + separate values.") + (:method)) + +(defgeneric codegen-add-function (codegen function) + (:documentation + "Adds a function to CODEGEN's list. + + Actually, we're not picky: FUNCTION can be any kind of object that you're + willing to find in the list returned by CODEGEN-FUNCTIONS.") + (:method )) + + +;;;-------------------------------------------------------------------------- +;;; Code generation idioms. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/combination.lisp b/pre-reorg/combination.lisp new file mode 100644 index 0000000..2287fab --- /dev/null +++ b/pre-reorg/combination.lisp @@ -0,0 +1,34 @@ +;;; -*-lisp-*- +;;; +;;; Method combinations +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Common behaviour. + +;;;-------------------------------------------------------------------------- +;;; Standard method combination. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/cpl.lisp b/pre-reorg/cpl.lisp new file mode 100644 index 0000000..eb7a3fa --- /dev/null +++ b/pre-reorg/cpl.lisp @@ -0,0 +1,133 @@ +;;; -*-lisp-*- +;;; +;;; Computing class precedence lists +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Linearizations. + +;;;-------------------------------------------------------------------------- +;;; Class protocol. + +(defgeneric compute-cpl (class) + (:documentation + "Returns the class precedence list for CLASS.")) + +;;;-------------------------------------------------------------------------- +;;; Testing. + +#+test +(progn + (defclass test-class () + ((name :initarg :name :accessor sod-class-name) + (direct-superclasses :initarg :superclasses + :accessor sod-class-direct-superclasses) + (class-precedence-list))) + + (defmethod print-object ((class test-class) stream) + (if *print-escape* + (print-unreadable-object (class stream :type t :identity nil) + (princ (sod-class-name class) stream)) + (princ (sod-class-name class) stream))) + + (defvar *test-linearization*) + + (defmethod sod-class-precedence-list ((class test-class)) + (if (slot-boundp class 'class-precedence-list) + (slot-value class 'class-precedence-list) + (setf (slot-value class 'class-precedence-list) + (funcall *test-linearization* class))))) + +#+test +(defun test-cpl (linearization heterarchy) + (let* ((*test-linearization* linearization) + (classes (make-hash-table :test #'equal))) + (dolist (class heterarchy) + (let ((name (car class))) + (setf (gethash (car class) classes) + (make-instance 'test-class :name name)))) + (dolist (class heterarchy) + (setf (sod-class-direct-superclasses (gethash (car class) classes)) + (mapcar (lambda (super) (gethash super classes)) (cdr class)))) + (mapcar (lambda (class) + (handler-case + (mapcar #'sod-class-name + (sod-class-precedence-list (gethash (car class) + classes))) + (inconsistent-merge-error () + (list (car class) :error)))) + heterarchy))) + +#+test +(progn + (defparameter *confused-heterarchy* + '((object) (grid-layout object) + (horizontal-grid grid-layout) (vertical-grid grid-layout) + (hv-grid horizontal-grid vertical-grid) + (vh-grid vertical-grid horizontal-grid) + (confused-grid hv-grid vh-grid))) + (defparameter *boat-heterarchy* + '((object) + (boat object) + (day-boat boat) + (wheel-boat boat) + (engine-less day-boat) + (small-multihull day-boat) + (pedal-wheel-boat engine-less wheel-boat) + (small-catamaran small-multihull) + (pedalo pedal-wheel-boat small-catamaran))) + (defparameter *menu-heterarchy* + '((object) + (choice-widget object) + (menu choice-widget) + (popup-mixin object) + (popup-menu menu popup-mixin) + (new-popup-menu menu popup-mixin choice-widget))) + (defparameter *pane-heterarchy* + '((pane) (scrolling-mixin) (editing-mixin) + (scrollable-pane pane scrolling-mixin) + (editable-pane pane editing-mixin) + (editable-scrollable-pane scrollable-pane editable-pane))) + (defparameter *baker-nonmonotonic-heterarchy* + '((z) (x z) (y) (b y) (a b x) (c a b x y))) + (defparameter *baker-nonassociative-heterarchy* + '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc))) + (defparameter *distinguishing-heterarchy* + '((object) + (a object) (b object) (c object) + (p a b) (q a c) + (u p) (v q) + (x u v) + (y x b c) + (z x c b))) + (defparameter *python-heterarchy* + '((object) + (a object) (b object) (c object) (d object) (e object) + (k1 a b c) + (k2 d b e) + (k3 d a) + (z k1 k2 k3)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/cutting-room-floor.lisp b/pre-reorg/cutting-room-floor.lisp new file mode 100644 index 0000000..294e5b6 --- /dev/null +++ b/pre-reorg/cutting-room-floor.lisp @@ -0,0 +1,491 @@ +;;;-------------------------------------------------------------------------- +;;; C types stuff. + +(cl:defpackage #:c-types + (:use #:common-lisp + #+sbcl #:sb-mop + #+(or cmu clisp) #:mop + #+ecl #:clos) + (:export #:c-type + #:c-declarator-priority #:maybe-parenthesize + #:pprint-c-type + #:c-type-subtype #:compount-type-declaration + #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers + #:simple-c-type #:c-type-name + #:c-pointer-type + #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type + #:tagged-c-type-kind + #:c-array-type #:c-array-dimensions + #:make-argument #:argument-name #:argument-type + #:c-function-type #:c-function-arguments + + #:define-c-type-syntax #:c-type-alias #:defctype + #:print-c-type + #:qualifier #:declare-qualifier + #:define-simple-c-type + + #:const #:volatile #:static #:restrict + #:char #:unsigned-char #:uchar #:signed-char #:schar + #:int #:signed #:signed-int #:sint + #:unsigned #:unsigned-int #:uint + #:short #:signed-short #:short-int #:signed-short-int #:sshort + #:unsigned-short #:unsigned-short-int #:ushort + #:long #:signed-long #:long-int #:signed-long-int #:slong + #:unsigned-long #:unsigned-long-int #:ulong + #:float #:double #:long-double + #:pointer #:ptr + #:[] #:vec + #:fun #:func #:fn)) + + +;;;-------------------------------------------------------------------------- +;;; Convenient syntax for C types. + +;; Basic machinery. + +;; Qualifiers. They have hairy syntax and need to be implemented by hand. + +;; Simple types. + +;; Pointers. + +;; Tagged types. + +;; Arrays. + +;; Functions. + + +(progn + (defconstant q-byte (byte 3 0)) + (defconstant q-const 1) + (defconstant q-volatile 2) + (defconstant q-restrict 4) + + (defconstant z-byte (byte 3 3)) + (defconstant z-unspec 0) + (defconstant z-short 1) + (defconstant z-long 2) + (defconstant z-long-long 3) + (defconstant z-double 4) + (defconstant z-long-double 5) + + (defconstant s-byte (byte 2 6)) + (defconstant s-unspec 0) + (defconstant s-signed 1) + (defconstant s-unsigned 2) + + (defconstant t-byte (byte 3 8)) + (defconstant t-unspec 0) + (defconstant t-int 1) + (defconstant t-char 2) + (defconstant t-float 3) + (defconstant t-user 4)) + +(defun make-type-flags (size sign type &rest quals) + (let ((flags 0)) + (dolist (qual quals) + (setf flags (logior flags qual))) + (setf (ldb z-byte flags) size + (ldb s-byte flags) sign + (ldb t-byte flags) type) + flags)) + + +(defun expand-c-type (spec) + "Parse SPEC as a C type and return the result. + + The SPEC can be one of the following. + + * A C-TYPE object, which is returned immediately. + + * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser + function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX + or some other means is invoked on the ARGUMENTS, and the result is + returned. + + * A symbol, which is treated the same way as a singleton list would be." + + (flet ((interp (sym) + (or (get sym 'c-type) + (error "Unknown C type operator ~S." sym)))) + (etypecase spec + (c-type spec) + (symbol (funcall (interp spec))) + (list (apply (interp (car spec)) (cdr spec)))))) + +(defmacro c-type (spec) + "Evaluates to the type that EXPAND-C-TYPE would return. + + Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe + later it will do something more clever." + `(expand-c-type ',spec)) + +;; S-expression machinery. Qualifiers have hairy syntax and need to be +;; implemented by hand. + +(defun qualifier (qual &rest args) + "Parse a qualified C type. + + The ARGS consist of a number of qualifiers and exactly one C-type + S-expression. The result is a qualified version of this type, with the + given qualifiers attached." + (if (null args) + qual + (let* ((things (mapcar #'expand-c-type args)) + (quals (delete-duplicates + (sort (cons qual (remove-if-not #'keywordp things)) + #'string<))) + (types (remove-if-not (lambda (thing) (typep thing 'c-type)) + things))) + (when (or (null types) + (not (null (cdr types)))) + (error "Only one proper type expected in ~S." args)) + (qualify-type (car types) quals)))) +(setf (get 'qualifier 'c-type) #'qualifier) + +(defun declare-qualifier (qual) + "Defines QUAL as being a type qualifier. + + When used as a C-type operator, it applies that qualifier to the type that + is its argument." + (let ((kw (intern (string qual) :keyword))) + (setf (get qual 'c-type) + (lambda (&rest args) + (apply #'qualifier kw args))))) + +;; Define some initial qualifiers. +(dolist (qual '(const volatile restrict)) + (declare-qualifier qual)) + + +(define-c-type-syntax simple-c-type (name) + "Constructs a simple C type called NAME (a string or symbol)." + (make-simple-type (c-name-case name))) + +(defmethod print-c-type :around + (stream (type qualifiable-c-type) &optional colon atsign) + (if (c-type-qualifiers type) + (pprint-logical-block (stream nil :prefix "(" :suffix ")") + (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_" + (c-type-qualifiers type)) + (call-next-method stream type colon atsign)) + (call-next-method))) +;; S-expression syntax. + + +(define-c-type-syntax enum (tag) + "Construct an enumeration type named TAG." + (make-instance 'c-enum-type :tag (c-name-case tag))) +(define-c-type-syntax struct (tag) + "Construct a structure type named TAG." + (make-instance 'c-struct-type :tag (c-name-case tag))) +(define-c-type-syntax union (tag) + "Construct a union type named TAG." + (make-instance 'c-union-type :tag (c-name-case tag))) + +(defgeneric make-me-argument (message class) + (:documentation + "Return an ARGUMENT object for the `me' argument to MESSAGE, as + specialized to CLASS.")) + +(defmethod make-me-argument + ((message basic-message) (class sod-class)) + (make-argument "me" (make-instance 'c-pointer-type + :subtype (sod-class-type class)))) + +;;;-------------------------------------------------------------------------- +;;; Keyword arguments and lambda lists. + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun transform-otherkeys-lambda-list (bvl) + "Process a simple lambda-list BVL which might contain &OTHER-KEYS. + + &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments + (which must also be present); &ALLOW-OTHER-KEYS must not be present. + + The behaviour is that + + * the presence of non-listed keyword arguments is permitted, as if + &ALLOW-OTHER-KEYS had been provided, and + + * a list of the keyword arguments other than the ones explicitly listed + is stored in the VAR. + + The return value is a replacement BVL which binds the &OTHER-KEYS variable + as an &AUX parameter if necessary. + + At least for now, fancy things like destructuring lambda-lists aren't + supported. I suspect you'll get away with a specializing lambda-list." + + (prog ((new-bvl nil) + (rest-var nil) + (keywords nil) + (other-keys-var nil) + (tail bvl)) + + find-rest + ;; Scan forwards until we find &REST or &KEY. If we find the former, + ;; then remember the variable name. If we find the latter first then + ;; there can't be a &REST argument, so we should invent one. If we + ;; find neither then there's nothing to do. + (when (endp tail) + (go ignore)) + (let ((item (pop tail))) + (push item new-bvl) + (case item + (&rest (when (endp tail) + (error "Missing &REST argument name")) + (setf rest-var (pop tail)) + (push rest-var new-bvl)) + (&aux (go ignore)) + (&key (unless rest-var + (setf rest-var (gensym "REST")) + (setf new-bvl (nconc (list '&key rest-var '&rest) + (cdr new-bvl)))) + (go scan-keywords))) + (go find-rest)) + + scan-keywords + ;; Read keyword argument specs one-by-one. For each one, stash it on + ;; the NEW-BVL list, and also parse it to extract the keyword, which + ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's + ;; nothing for us to do. + (when (endp tail) + (go ignore)) + (let ((item (pop tail))) + (push item new-bvl) + (case item + ((&aux &allow-other-keys) (go ignore)) + (&other-keys (go fix-tail))) + (let ((keyword (if (symbolp item) + (intern (symbol-name item) :keyword) + (let ((var (car item))) + (if (symbolp var) + (intern (symbol-name var) :keyword) + (car var)))))) + (push keyword keywords)) + (go scan-keywords)) + + fix-tail + ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var. + (pop new-bvl) + (when (endp tail) + (error "Missing &OTHER-KEYS argument name")) + (setf other-keys-var (pop tail)) + (push '&allow-other-keys new-bvl) + + ;; There should be an &AUX next. If there isn't, assume there isn't + ;; one and provide our own. (This is safe as long as nobody else is + ;; expecting to plumb in lambda keywords too.) + (when (and (not (endp tail)) (eq (car tail) '&aux)) + (pop tail)) + (push '&aux new-bvl) + + ;; Add our shiny new &AUX argument. + (let ((keys-var (gensym "KEYS")) + (list-var (gensym "LIST"))) + (push `(,other-keys-var (do ((,list-var nil) + (,keys-var ,rest-var (cddr ,keys-var))) + ((endp ,keys-var) (nreverse ,list-var)) + (unless (member (car ,keys-var) + ',keywords) + (setf ,list-var + (cons (cadr ,keys-var) + (cons (car ,keys-var) + ,list-var)))))) + new-bvl)) + + ;; Done. + (return (nreconc new-bvl tail)) + + ignore + ;; Nothing to do. Return the unmolested lambda-list. + (return bvl)))) + +(defmacro lambda-otherkeys (bvl &body body) + "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword." + `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body)) + +(defmacro defun-otherkeys (name bvl &body body) + "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword." + `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body)) + +(defmacro defmethod-otherkeys (name &rest stuff) + "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword." + (do ((quals nil) + (stuff stuff (cdr stuff))) + ((listp (car stuff)) + `(defmethod ,name ,@(nreverse quals) + ,(transform-otherkeys-lambda-list (car stuff)) + ,@(cdr stuff))) + (push (car stuff) quals))) + + +(defparse many ((acc init update + &key (new 'it) (final acc) (min nil minp) max (commitp t)) + parser &optional (sep nil sepp)) + "Parse a sequence of homogeneous items. + + The behaviour is similar to `do'. Initially an accumulator ACC is + established, and bound to the value of INIT. The PARSER is then evaluated + repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults + to `it') bound to the result of the parse, and the value returned by + UPDATE is stored back into ACC. If the PARSER fails, then the parse ends. + + If a SEP parser is provided, then the behaviour changes as follows. + Before each attempt to parse a new item using PARSER, the parser SEP is + invoked. If SEP fails then the parse ends; if SEP succeeds, then the + PARSER must also succeed or the overall parse will fail. + + If MAX (which will be evaluated) is not nil, then it must be a number: the + parse ends automatically after PARSER has succeeded MAX times. When the + parse has ended, if the PARSER succeeded fewer than MIN (which will be + evaluated) times then the parse fails. Otherwise, the FINAL form (which + defaults to simply returning ACC) is evaluated and its value becomes the + result of the parse. MAX defaults to nil -- i.e., no maximum; MIN + defaults to 1 if a SEP parser is given, or 0 if not. + + Note that `many' cannot fail if MIN is zero." + + (unless minp (setf min (if sepp 1 0))) + (with-gensyms (block value win consumedp cp i up done) + (once-only (init min max commitp) + (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0))))) + `(block ,block + + ;; Keep track of variables. We only need an accumulator if it's + ;; not nil, and we don't need a counter if (a) there's no maximum, + ;; and either (b) the minimum is zero, or (c) the minimum is one + ;; and there's a separator. In case (c), we can keep track of how + ;; much has been seen using control flow. + (let ((,consumedp nil) + ,@(and acc `((,acc ,init))) + ,@(and counterp `((,i 0)))) + + ;; Some handy functions. `up' will update the accumulator. + ;; `done' will return the necessary final value. + (flet (,@(and acc `((,up (,new) + (declare (ignorable ,new)) + (setf ,acc ,update)))) + (,done () (return-from ,block + (values ,final t ,consumedp)))) + + ;; If there's a separator, prime the pump by parsing a first + ;; item. This makes the loop easy: it just parses a separator + ;; and an item each time. And it means we don't need a + ;; counter in the case of a minimum of 1. + ,@(and sepp + `((multiple-value-bind (,value ,win ,cp) + (parse ,parser) + (when ,cp (setf ,consumedp t)) + (unless ,win + ,(cond ((eql min 0) + `(,done)) + ((and (numberp min) (plusp min)) + `(return-from ,block + (values ,value nil ,consumedp))) + (t + `(if (< 0 ,min) + (return-from ,block + (values ,value nil, consumedp)) + (,done))))) + ,@(and acc `((,up ,value)))) + ,@(and counterp `((incf ,i))))) + + ;; The main loop... + (loop + + ;; If we've hit the maximum then stop. But, attention, if + ;; we have a separator and we're not committing to parsing + ;; items, then check after scanning the separator, not + ;; before. + ,@(and max commitp + `((when (and ,@(and (not (constantp max)) + `(,max)) + ,@(and (not (constantp commitp)) + `(,commitp)) + (>= ,i ,max)) + (,done)))) + + ,@(if sepp + ;; We're expecting a separator. If this fails and + ;; we're below minimum then we've failed altogether. + ;; If it succeeds then we should go on to parse an + ;; item. + `((multiple-value-bind (,value ,win ,cp) (parse ,sep) + ,@(and (numberp min) (<= min 1) + `((declare (ignore ,value)))) + (when ,cp (setf ,consumedp t)) + (unless ,win + ,(if (and (numberp min) (<= min 1)) + `(,done) + `(if (>= ,i ,min) + (return ,final) + (return-from ,block + (values ,value nil ,consumedp)))))) + + ;; If we're not committing then now is the time to + ;; check for hitting the maximum number of + ;; repetitions. + ,@(and max (or (not commitp) + (not (constantp commitp))) + `((when (and ,@(and (not (constantp max)) + `(,max)) + ,@(and commitp + `((not ,commitp))) + (>= ,i ,max)) + (,done)))) + + ;; Now parse an item. If this fails and we're + ;; committed then we've blown the whole parse. If + ;; it fails and we've not committed then we need to + ;; check the minimum. It's getting very tempting to + ;; write a compiler for optimizing these + ;; conditionals. (If we don't do this, we get + ;; annoying warnings.) + (multiple-value-bind (,value ,win ,cp) + (parse ,parser) + (when ,cp (setf ,consumedp t)) + (unless ,win + ,(cond ((and (constantp commitp) commitp) + `(return-from ,block + (values ,value nil ,consumedp))) + ((not commitp) + (if (and (numberp min) (<= min 1)) + `(,done) + `(if (>= ,i ,min) + (,done) + (return-from ,block + (values ,value nil + ,consumedp))))) + ((and (numberp min) (<= min 1)) + `(if ,commitp + (return-from ,block + (values ,value nil ,consumedp)) + (,done))) + (t + `(if (or ,commitp (< ,i ,min)) + (return-from ,block + (values ,value nil ,consumedp)) + (,done))))) + ,@(and acc `((,up ,value))))) + + ;; No separator. Just parse the value. If it fails, + ;; check that we've met the minimum. + `((multiple-value-bind (,value ,win ,cp) + (parse ,parser) + ,@(and (eql min 0) (null acc) + `((declare (ignore ,value)))) + (when ,cp (setf ,consumedp t)) + (unless ,win + ,(if (eql min 0) + `(,done) + `(if (>= ,i ,min) + (,done) + (return-from ,block + (values ,value nil ,consumedp))))) + ,@(and acc `((,up ,value)))))) + + ;; Done. Update the counter and go round again. + ,@(and counterp `((incf ,i))))))))))) \ No newline at end of file diff --git a/errors.lisp b/pre-reorg/errors.lisp similarity index 98% rename from errors.lisp rename to pre-reorg/errors.lisp index 4b92fee..6ff6747 100644 --- a/errors.lisp +++ b/pre-reorg/errors.lisp @@ -29,8 +29,7 @@ ;;; Enclosing conditions. (define-condition enclosing-condition (condition) - ((enclosed-condition :initarg :condition - :type condition + ((enclosed-condition :initarg :condition :type condition :reader enclosed-condition)) (:documentation "A condition which encloses another condition @@ -45,9 +44,7 @@ ;;; Conditions with location information. (define-condition condition-with-location (condition) - ((location :initarg :location - :reader file-location - :type file-location)) + ((location :initarg :location :reader file-location :type file-location)) (:documentation "A condition which has some location information attached.")) diff --git a/examples.lisp b/pre-reorg/examples.lisp similarity index 100% rename from examples.lisp rename to pre-reorg/examples.lisp diff --git a/pre-reorg/foo.lisp b/pre-reorg/foo.lisp new file mode 100644 index 0000000..b5b8509 --- /dev/null +++ b/pre-reorg/foo.lisp @@ -0,0 +1,2 @@ +;;; +(write-line "stuff's a-goin' on") diff --git a/lex.lisp b/pre-reorg/lex.lisp similarity index 88% rename from lex.lisp rename to pre-reorg/lex.lisp index 0c0fa65..d7fd2c0 100644 --- a/lex.lisp +++ b/pre-reorg/lex.lisp @@ -179,28 +179,11 @@ (defgeneric skip-spaces (lexer) (:documentation - "Skip over whitespace characters in the LEXER.") - (:method ((lexer lexer)) - (do ((ch (lexer-char lexer) (next-char lexer))) - ((not (whitespace-char-p ch)))))) + "Skip over whitespace characters in the LEXER.")) ;;;-------------------------------------------------------------------------- ;;; Lexer utilities. -(defun require-token - (lexer wanted-token-type &key (errorp t) (consumep t) default) - (with-slots (token-type token-value) lexer - (cond ((eql token-type wanted-token-type) - (prog1 token-value - (when consumep (next-token lexer)))) - (errorp - (cerror* "Expected ~A but found ~A" - (format-token wanted-token-type) - (format-token token-type token-value)) - default) - (t - default)))) - ;;;-------------------------------------------------------------------------- ;;; Our main lexer. @@ -414,57 +397,6 @@ ;;;-------------------------------------------------------------------------- ;;; C fragments. -(defclass c-fragment () - ((location :initarg :location :type file-location - :accessor c-fragment-location) - (text :initarg :text :type string :accessor c-fragment-text)) - (:documentation - "Represents a fragment of C code to be written to an output file. - - A C fragment is aware of its original location, and will bear proper #line - markers when written out.")) - -(defun output-c-excursion (stream location thunk) - "Invoke THUNK surrounding it by writing #line markers to STREAM. - - The first marker describes LOCATION; the second refers to the actual - output position in STREAM. If LOCATION doesn't provide a line number then - no markers are output after all. If the output stream isn't - position-aware then no final marker is output." - - (let* ((location (file-location location)) - (line (file-location-line location)) - (pathname (file-location-pathname location)) - (namestring (and pathname (namestring pathname)))) - (cond (line - (format stream "~&#line ~D~@[ ~S~]~%" line namestring) - (funcall thunk) - (when (typep stream 'position-aware-stream) - (fresh-line stream) - (format stream "~&#line ~D ~S~%" - (1+ (position-aware-stream-line stream)) - (namestring (stream-pathname stream))))) - (t - (funcall thunk))))) - -(defmethod print-object ((fragment c-fragment) stream) - (let ((text (c-fragment-text fragment)) - (location (c-fragment-location fragment))) - (if *print-escape* - (print-unreadable-object (fragment stream :type t) - (when location - (format stream "~A " location)) - (cond ((< (length text) 40) - (prin1 text stream) stream) - (t - (prin1 (subseq text 0 40) stream) - (write-string "..." stream)))) - (output-c-excursion stream location - (lambda () (write-string text stream)))))) - -(defmethod make-load-form ((fragment c-fragment) &optional environment) - (make-load-form-saving-slots fragment :environment environment)) - (defun scan-c-fragment (lexer end-chars) "Snarfs a sequence of C tokens with balanced brackets. diff --git a/pre-reorg/methods.lisp b/pre-reorg/methods.lisp new file mode 100644 index 0000000..93782be --- /dev/null +++ b/pre-reorg/methods.lisp @@ -0,0 +1,43 @@ +;;; -*-lisp-*- +;;; +;;; Infrastructure for effective method generation +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Direct method classes. + +;;;-------------------------------------------------------------------------- +;;; Effective method classes. + +;;;-------------------------------------------------------------------------- +;;; Code generation. + +;;;-------------------------------------------------------------------------- +;;; Effective method entry points. + +;;;-------------------------------------------------------------------------- +;;; Output. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/module-output.lisp b/pre-reorg/module-output.lisp similarity index 100% rename from module-output.lisp rename to pre-reorg/module-output.lisp diff --git a/module.lisp b/pre-reorg/module.lisp similarity index 60% rename from module.lisp rename to pre-reorg/module.lisp index 6f8aeec..604703f 100644 --- a/module.lisp +++ b/pre-reorg/module.lisp @@ -26,135 +26,8 @@ (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 build-module - (name body-func &key (truename (probe-file name)) location) - (let ((*module* (make-instance 'module - :name (pathname name) - :state (file-location location))) - (*type-map* (make-hash-table :test #'equal))) - (module-import *builtin-module*) - (when truename - (setf (gethash truename *module-map*) *module*)) - (unwind-protect - (progn - (funcall body-func) - (finalize-module *module*)) - (when (and truename (not (eq (module-state *module*) t))) - (remhash truename *module-map*))))) - -(defmacro define-module - ((name &key (truename nil truenamep) (location nil locationp)) - &body body) - `(build-module ,name - (lambda () ,@body) - ,@(and truenamep `(:truename ,truename)) - ,@(and locationp `(:location ,location)))) - (defun read-module (pathname &key (truename (truename pathname)) location) "Reads a module. @@ -220,30 +93,6 @@ :report "Ignore the error and continue parsing." nil)))) -;;;-------------------------------------------------------------------------- -;;; Type definitions. - -(defclass type-item () - ((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)) - (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)) - (defmethod parse-module-declaration ((tag (eql :typename)) lexer pset) "module-decl ::= `typename' id-list `;'" (loop (let ((name (require-token lexer :id))) @@ -257,33 +106,6 @@ ;;;-------------------------------------------------------------------------- ;;; 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*" @@ -557,102 +379,4 @@ (finalize-sod-class class) (add-to-module *module* class))) -;;;-------------------------------------------------------------------------- -;;; Modules. - -#+(or) -(defun parse-module (lexer) - "Parse a module from the given LEXER. - - The newly constructed module is returned. This is the top-level parsing - function." - - (let ((hfrags nil) - (cfrags nil) - (classes nil) - (plist nil) - (deps nil)) - - (labels ((fragment (func) - (next-token lexer) - (when (require-token lexer #\{ :consumep nil) - (let ((frag (scan-c-fragment lexer '(#\})))) - (next-token lexer) - (require-token lexer #\}) - (funcall func frag))))) - - (tagbody - - top - ;; module : empty | module-def module - ;; - ;; Just read module-defs until we reach the end of the file. - (case (token-type lexer) - - (:eof - (go done)) - (#\; - (next-token lexer) - (go top)) - - ;; module-def : `lisp' sexp - ;; - ;; Process an in-line Lisp form immediately. - (:lisp - - (next-token lexer) - (go top)) - - ;; module-def : `typename' ids `;' - ;; ids : id | ids `,' id - ;; - ;; Add ids as registered type names. We don't need to know what - ;; they mean at this level. - (:typename - (next-token lexer) - (loop - (let ((id (require-token lexer :id))) - (cond ((null id) - (return)) - ((gethash id *type-map*) - (cerror* "Type ~A is already defined" id)) - (t - (setf (gethash id *type-map*) - (make-instance 'simple-c-type :name id)))) - (unless (eql (token-type lexer) #\,) - (return)) - (next-token lexer))) - (go semicolon)) - - ;; module-def : `source' `{' c-stuff `}' - ;; module-def : `header' `{' c-stuff `}' - (:source - (fragment (lambda (frag) (push frag cfrags))) - (go top)) - (:header - (fragment (lambda (frag) (push frag hfrags))) - (go top)) - - ;; Anything else is an error. - (t - (cerror* "Unexpected token ~A ignored" (format-token lexer)) - (next-token lexer) - (go top))) - - semicolon - ;; Scan a terminating semicolon. - (require-token lexer #\;) - (go top) - - done) - - ;; Assemble the module and we're done. - (make-instance 'module - :name (stream-pathname (lexer-stream lexer)) - :plist plist - :classes classes - :header-fragments hfrags - :source-fragments cfrags - :dependencies deps)))) - ;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/output.lisp b/pre-reorg/output.lisp new file mode 100644 index 0000000..dd8bc04 --- /dev/null +++ b/pre-reorg/output.lisp @@ -0,0 +1,63 @@ +;;; -*-lisp-*- +;;; +;;; Output driver for SOD translator +;;; +;;; (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) + +;;;-------------------------------------------------------------------------- +;;; Sequencing machinery. + +(defclass sequencer-item () + ((name :initarg :name :reader sequencer-item-name) + (functions :initarg :functions :initform nil + :type list :accessor sequencer-item-functions)) + (:documentation + "Represents a distinct item to be sequenced by a SEQUENCER. + + A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the + sequencer is invoked. This class is not intended to be subclassed.")) + +;;;-------------------------------------------------------------------------- +;;; Output preparation. + +(defvar *seen-announcement*) ;Keep me unbound! +#+hmm +(defmethod add-output-hooks :around (object reason sequencer &rest stuff) + "Arrange not to invoke any object more than once during a particular + announcement." + (declare (ignore stuff)) + (cond ((not (boundp '*seen-announcement*)) + (let ((*seen-announcement* (make-hash-table))) + (setf (gethash object *seen-announcement*) t) + (call-next-method))) + ((gethash object *seen-announcement*) + nil) + (t + (setf (gethash object *seen-announcement*) t) + (call-next-method)))) + +;;;-------------------------------------------------------------------------- +;;; Utility macro. + +;;;----- That's all, folks -------------------------------------------------- diff --git a/parse-c-types.lisp b/pre-reorg/parse-c-types.lisp similarity index 100% rename from parse-c-types.lisp rename to pre-reorg/parse-c-types.lisp diff --git a/posn-stream.lisp b/pre-reorg/posn-stream.lisp similarity index 100% rename from posn-stream.lisp rename to pre-reorg/posn-stream.lisp diff --git a/pset.lisp b/pre-reorg/pset.lisp similarity index 52% rename from pset.lisp rename to pre-reorg/pset.lisp index a9bbde9..20f0ff9 100644 --- a/pset.lisp +++ b/pre-reorg/pset.lisp @@ -26,254 +26,6 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Property representation. - -(defun property-key (name) - "Convert NAME into a keyword. - - If NAME isn't a symbol already, then flip its case (using FROB-CASE), - replace underscores by hyphens, and intern into the KEYWORD package." - (etypecase name - (symbol name) - (string (intern (substitute #\- #\_ (frob-case name)) :keyword)))) - -(defun property-type (value) - "Guess a sensible property type to use for VALUE." - (typecase value - (symbol :symbol) - (integer :integer) - (string :string) - (character :char) - (c-fragment :frag) - (t :other))) - -(defstruct (property - (:conc-name p-) - (:constructor make-property - (name value - &key (type (property-type value)) - ((:location %loc)) - seenp - &aux (key (property-key name)) - (location (file-location %loc))))) - "A simple structure for holding a property in a property set. - - The main useful feature is the ability to tick off properties which have - been used, so that we can complain about unrecognized properties. - - An explicit type tag is necessary because we need to be able to talk - distinctly about identifiers, strings and symbols, and we've only got two - obvious Lisp types to play with. Sad, but true." - - (name nil :type (or string symbol)) - (value nil :type t) - (type nil :type symbol) - (location (file-location nil) :type file-location) - (key nil :type symbol) - (seenp nil :type boolean)) - -(defun string-to-symbol (string &optional (package *package*)) - "Convert STRING to a symbol in PACKAGE. - - If PACKAGE is nil, then parse off a `PACKAGE:' prefix from STRING to - identify the package. A doubled colon allows access to internal symbols, - and will intern if necessary. Note that escape characters are /not/ - processed; don't put colons in package names if you want to use them from - SOD property sets." - - (let* ((length (length string)) - (colon (position #\: string))) - (multiple-value-bind (start internalp) - (cond ((not colon) (values 0 t)) - ((and (< (1+ colon) length) - (char= (char string (1+ colon)) #\:)) - (values (+ colon 2) t)) - (t - (values (1+ colon) nil))) - (when colon - (let* ((package-name (subseq string 0 colon)) - (found (find-package package-name))) - (unless found - (error "Unknown package `~A'" package-name)) - (setf package found))) - (let ((name (subseq string start))) - (multiple-value-bind (symbol status) - (funcall (if internalp #'intern #'find-symbol) name package) - (cond ((or internalp (eq status :external)) - symbol) - ((not status) - (error "Symbol `~A' not found in package `~A'" - name (package-name package))) - (t - (error "Symbol `~A' not external in package `~A'" - name (package-name package))))))))) - -(defgeneric coerce-property-value (value type wanted) - (:documentation - "Convert VALUE, a property of type TYPE, to be of type WANTED. - - It's sensible to add additional methods to this function, but there are - all the ones we need.") - - ;; If TYPE matches WANTED, we'll assume that VALUE already has the right - ;; form. Otherwise, if nothing else matched, then I guess we'll have to - ;; say it didn't work. - (:method (value type wanted) - (if (eql type wanted) - value - (error "Incorrect type: expected ~A but found ~A" wanted type))) - - ;; If the caller asks for type T then give him the raw thing. - (:method (value type (wanted (eql t))) - value) - - ;; Keywords. - (:method ((value symbol) (type (eql :symbol)) (wanted (eql :keyword))) - value) - (:method ((value string) (type (eql :id)) (wanted (eql :keyword))) - (string-to-symbol (substitute #\- #\_ (frob-case value)) :keyword)) - (:method ((value string) (type (eql :string)) (wanted (eql :keyword))) - (string-to-symbol (frob-case value) :keyword)) - - ;; Symbols. - (:method ((value string) (type (eql :id)) (wanted (eql :symbol))) - (string-to-symbol (substitute #\- #\_ (frob-case value)))) - (:method ((value string) (type (eql :string)) (wanted (eql :symbol))) - (string-to-symbol (frob-case value))) - - ;; Identifiers. - (:method ((value symbol) (type (eql :symbol)) (wanted (eql :id))) - (substitute #\_ #\- (frob-case (symbol-name value))))) - -;;;-------------------------------------------------------------------------- -;;; Property set representation. -;;; -;;; There shouldn't be any code elsewhere which depends on the -;;; representation. It's changed before; it may change again. - -(defstruct (pset (:constructor %make-pset) - (:conc-name %pset-)) - "A property set. - - Wrapped up in a structure so that we can define a print function." - (hash (make-hash-table) :type hash-table)) - -(declaim (inline make-pset pset-get pset-store pset-map)) - -(defun make-pset () - "Constructor for property sets." - (%make-pset)) - -(defun pset-get (pset key) - "Look KEY up in PSET and return what we find. - - If there's no property by that name, return NIL." - (values (gethash key (%pset-hash pset)))) - -(defun pset-store (pset prop) - "Store property PROP in PSET. - - Overwrite or replace any previous property with the same name. Mutates - the property set." - (setf (gethash (p-key prop) (%pset-hash pset)) prop)) - -(defun pset-map (func pset) - "Call FUNC for each property in PSET." - (maphash (lambda (key value) (declare (ignore key)) (funcall func value)) - (%pset-hash pset))) - -;;;-------------------------------------------------------------------------- -;;; `Cooked' property set operations. - -(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))) - -(defun get-property (pset name type &optional default) - "Fetch a property from a property set. - - If a property NAME is not found in PSET, or if a property is found, but - its type doesn't match TYPE, then return DEFAULT and NIL; otherwise return - the value and its file location. In the latter case, mark the property as - having been used. - - The value returned depends on the TYPE argument provided. If you pass NIL - then you get back the entire PROPERTY object. If you pass T, then you get - whatever was left in the property set, uninterpreted. Otherwise the value - is coerced to the right kind of thing (where possible) and returned. - - If PSET is nil, then return DEFAULT." - - (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)) - ((not type) - (setf (p-seenp prop) t) - (values prop (p-location prop))) - (t - (setf (p-seenp prop) t) - (values (coerce-property-value (p-value prop) - (p-type prop) - type) - (p-location prop))))))) - -(defun add-property - (pset name value &key (type (property-type value)) location) - "Add a property to PSET. - - If a property with the same NAME already exists, report an error." - - (with-default-error-location (location) - (let ((existing (get-property pset name nil))) - (when existing - (error "Property ~S already defined~@[ at ~A~]" - name (p-location existing))) - (store-property pset name value :type type :location location)))) - -(defun make-property-set (&rest plist) - "Make a new property set, with given properties. - - This isn't the way to make properties when parsing, but it works well for - programmatic generation. The arguments should form a property list - (alternating keywords and values is good). - - An attempt is made to guess property types from the Lisp types of the - values. This isn't always successful but it's not too bad. The - alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing - into the set." - - (do ((pset (make-pset)) - (plist plist (cddr plist))) - ((endp plist) pset) - (add-property pset (car plist) (cadr plist)))) - -(defmethod print-object ((pset pset) stream) - (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))))) - -(defun check-unused-properties (pset) - "Issue errors about unused properties in PSET." - (when pset - (pset-map (lambda (prop) - (unless (p-seenp prop) - (cerror*-with-location (p-location prop) - "Unknown property `~A'" - (p-name prop)) - (setf (p-seenp prop) t))) - pset))) - -;;;-------------------------------------------------------------------------- ;;; Expression parser. (defun parse-expression (lexer) diff --git a/pre-reorg/sift.lisp b/pre-reorg/sift.lisp new file mode 100644 index 0000000..7d78774 --- /dev/null +++ b/pre-reorg/sift.lisp @@ -0,0 +1,333 @@ +;;; sift through lists of classes and so on. + +(in-package #:cl-user) + +(defstruct (cset (:conc-name s-)) + members supers subs gfs) + +(defstruct (class-node (:conc-name c-)) + name class own-p supers subs visited-p sets) + +(defmacro pushnew-end (object place &rest keys &environment env) + (multiple-value-bind (temps inits newtemps setform getform) + (get-setf-expansion place env) + (let ((objvar (gensym "OBJECT")) + (listvar (gensym "LIST"))) + `(let* ((,objvar ,object) + ,@(mapcar #'list temps inits) + (,listvar ,getform)) + (cond ((member ,objvar ,listvar ,@keys) + ,listvar) + (t + (multiple-value-bind ,newtemps + (append ,listvar (list ,objvar)) + ,setform + (values ,@newtemps)))))))) + +(defun show-classes (classes) + (let ((map (make-hash-table))) + + (labels ((getnode (class &optional own-p) + (let ((found (gethash class map))) + (if found + (values found t) + (values (setf (gethash class map) + (make-class-node :name (class-name class) + :class class + :own-p own-p)) + nil)))) + + (gather (class) + (let ((node (getnode class))) + (dolist (super (class-direct-superclasses class)) + (unless (member super (append (mapcar #'find-class + '(t standard-object + structure-object)) + (class-direct-superclasses + (find-class 'condition)))) + (multiple-value-bind (supernode foundp) + (getnode super) + (pushnew-end supernode (c-supers node)) + (pushnew node (c-subs supernode)) + (unless foundp (gather super))))))) + + (walk (node &optional (level 0) super) + (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)" + (* 2 level) + (c-own-p node) + (c-name node)) + (cond ((null (cdr (c-supers node)))) + ((eq (car (c-supers node)) super) + (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>" + (mapcar #'c-name (c-supers node)))) + (t + (format *standard-output* "*~%") + (return-from walk))) + (terpri *standard-output*) + (dolist (sub (c-subs node)) + (walk sub (1+ level) node)))) + + ;; make nodes for all of the official classes. + (dolist (class classes) + (getnode class t)) + + ;; build the hierarchy, up and down. this may drag in classes from + ;; other packages. + (dolist (class classes) + (gather class)) + + ;; write the table. + (dolist (node (sort (loop for node being the hash-values of map + unless (c-supers node) + collect node) + #'string< :key #'c-name)) + (walk node))))) + +(defun check-sets (members) + (let ((done (make-hash-table))) + (labels ((check (s) + (when (gethash s done) + (return-from check)) + (setf (gethash s done) t) + + ;; subsets must be proper subsets + (dolist (u (s-supers s)) + (assert (subsetp (s-members s) (s-members u))) + (assert (not (subsetp (s-members u) (s-members s)))) + (assert (member s (s-subs u)))) + + ;; supersets must be proper supersets + (dolist (u (s-subs s)) + (assert (subsetp (s-members u) (s-members s))) + (assert (not (subsetp (s-members s) (s-members u)))) + (assert (member s (s-supers u)))) + + ;; supersets must be minimal + (dolist (u (s-supers s)) + (dolist (v (s-supers s)) + (assert (or (eq u v) + (not (subsetp (s-members u) + (s-members v))))))) + + ;; subsets must be maximal + (dolist (u (s-subs s)) + (dolist (v (s-subs s)) + (assert (or (eq u v) + (not (subsetp (s-members u) + (s-members v))))))) + + ;; members must link to us, directly or indirectly. + (dolist (m (s-members s)) + (labels ((look (u) + (or (eq u s) (some #'look (s-supers u))))) + (assert (some #'look (c-sets m))))) + + ;; check supersets and subsets + (dolist (u (s-supers s)) (check u)) + (dolist (u (s-subs s)) (check u)))) + + (dolist (m members) + (dolist (s (c-sets m)) + + ;; sets must contain us + (assert (member m (s-members s))) + + ;; sets must be minimal + (dolist (u (c-sets m)) + (assert (or (eq u s) + (not (subsetp (s-members u) + (s-members s)))))) + + ;; check set + (check s)))))) + +(defmethod print-object ((c class-node) stream) + (format stream "#[~(~A~)]" (c-name c))) + +(defmethod print-object ((s cset) stream) + (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s))) + +(defun ensure-set (members) + + (setf members (remove-duplicates members)) + (check-sets members) + + (let ((subs nil) (supers nil)) + + ;; find the maximal subsets and minimal supersets. if s is not a subset + ;; then answer nil; otherwise answer t, and recursively process all the + ;; supersets of s; if none of them answer t then is maximal, so add it to + ;; the list. + (labels ((up (s) + (cond ((subsetp (s-members s) members) + (unless (some #'up (s-supers s)) (pushnew s subs)) + t) + ((subsetp members (s-members s)) + (pushnew s supers) + nil) + (t nil)))) + (dolist (m members) + (mapc #'up (c-sets m)))) + (when (and subs (subsetp members (s-members (car subs)))) + (return-from ensure-set (car subs))) + (let* ((new (make-cset :members members :supers supers :subs subs))) + + ;; now we have to interpolate ourselves properly. this is the tricky + ;; part. + (dolist (s supers) + (setf (s-subs s) + (cons new (set-difference (s-subs s) subs)))) + (dolist (s subs) + (setf (s-supers s) + (cons new (set-difference (s-supers s) supers)))) + (dolist (m members) + (unless (some (lambda (s) (subsetp (s-members s) members)) + (c-sets m)) + (setf (c-sets m) (cons new + (remove-if (lambda (s) + (subsetp members + (s-members s))) + (c-sets m)))))) + + ;; done + (check-sets members) + new))) + +(defun categorize-protocols (generics classes) + (let ((cmap (make-hash-table))) + + (labels ((getnode (class &optional own-p) + (let ((found (gethash class cmap))) + (if found + (values found t) + (values (setf (gethash class cmap) + (make-class-node :name (class-name class) + :class class + :own-p own-p)) + nil)))) + + (gather (class) + (let ((node (getnode class))) + (dolist (super (class-direct-superclasses class)) + (unless (member super (append (mapcar #'find-class + '(t standard-object + structure-object)) + (class-direct-superclasses + (find-class 'condition)))) + (multiple-value-bind (supernode foundp) + (getnode super) + (pushnew-end supernode (c-supers node)) + (pushnew node (c-subs supernode)) + (unless foundp (gather super)))))))) + + ;; make nodes for all of the official classes. + (dolist (class classes) + (getnode class t)) + + ;; build the hierarchy, up and down. this may drag in classes from + ;; other packages. + (dolist (class classes) + (gather class)) + + ;; go through the generic functions collecting sets of implementing + ;; classes. + (dolist (gf generics) + (let* ((specs (reduce #'append + (mapcar #'method-specializers + (generic-function-methods gf)) + :from-end t)) + (members (labels ((down (c) + (delete-duplicates + (cons c (mapcan #'down (c-subs c))))) + (gather (spec) + (let ((c (gethash spec cmap))) + (and c (down c))))) + (delete-duplicates (mapcan #'gather specs)))) + (s (and members (ensure-set members)))) + (when s + (push gf (s-gfs s))))) + + ;; finally dump the list of participating classes. + (let ((tops nil)) + + ;; find the top-level sets + (let ((m (make-hash-table))) + (labels ((ascend (s) + (unless (gethash s m) + (setf (gethash s m) t) + (if (s-supers s) + (mapc #'ascend (s-supers s)) + (push s tops))))) + (dolist (c classes) + (mapc #'ascend (c-sets (gethash c cmap)))))) + + (let ((done (make-hash-table))) + (labels ((walk (s &optional (level 0)) + (let ((seen (gethash s done))) + (unless seen + (setf (gethash s done) t) + (dolist (gf (s-gfs s)) + (format *standard-output* "~v,0T~(~A~)~%" + (* 2 level) + (generic-function-name gf)))) + (dolist (c (set-difference + (s-members s) + (reduce #'union (mapcar #'s-members + (s-subs s)) + :initial-value nil))) + (format *standard-output* "~40T~(~A~)~:[~;*~]~%" + (c-name c) seen)) + (dolist (u (s-subs s)) + (walk u (1+ level)))))) + (mapc #'walk tops) + nil)))))) + +(defun gather-stuff (package) + (let ((classes nil) + (functions nil) + (generics nil) + (structs nil) + (macros nil) + (methods nil) + (package (find-package package))) + + ;; find all of the interesting things in the package. + (do-symbols (sym package) + (when (eq (symbol-package sym) package) + (let ((class (find-class sym nil))) + (typecase class + ((or standard-class sb-pcl::condition-class) + (push class classes)) + (structure-class (push class structs)))) + (when (fboundp sym) + (let ((func (symbol-function sym))) + (if (typep func 'generic-function) + (push func generics) + (push sym functions)))) + (let ((macro (macro-function sym))) + (when macro (push sym macros))))) + + ;; sort the lists -- makes things look prettier. + (macrolet ((frob (list key) + `(setf ,list (sort ,list #'string< :key #',key)))) + (frob classes class-name) + (frob functions identity) + (frob structs class-name) + (frob generics generic-function-name) + (frob macros identity) + (frob methods (lambda (m) + (generic-function-name (method-generic-function m))))) + + ;; present the classes in a vaguely useful way + (flet ((sep () + (format t "~%-------------------------~2%"))) + (show-classes classes) + (sep) + (show-classes structs) + (sep) + (categorize-protocols generics classes) + (loop for title in '("Macros" "Functions") + for list in (list macros functions) do + (sep) + (format t "~{~(~A~)~%~}" list))))) + diff --git a/sod.asd b/pre-reorg/sod.asd similarity index 89% rename from sod.asd rename to pre-reorg/sod.asd index 54214fc..48dbcaa 100644 --- a/sod.asd +++ b/pre-reorg/sod.asd @@ -82,8 +82,13 @@ (:file "class-finalize" :depends-on ("class-defs" "cpl")) (:file "class-builder" :depends-on ("class-finalize" "pset")) (:file "class-layout" :depends-on ("class-defs")) - (:file "module" :depends-on ("parse-c-types" "tables")) + (:file "module" :depends-on ("parse-c-types" "class-defs" "tables")) + (:file "builtin" :depends-on ("module" "class-layout")) (:file "output" :depends-on ("module")) - (:file "class-output" :depends-on ("class-layout" "output")))) + (:file "methods" :depends-on ("class-layout" "codegen" "output")) + (:file "class-output" :depends-on ("builtin" "class-builder" + "methods" "output")) + (:file "combination" :depends-on ("methods")) + (:file "module-output" :depends-on ("combination" "class-output")))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/tables.lisp b/pre-reorg/tables.lisp similarity index 100% rename from tables.lisp rename to pre-reorg/tables.lisp diff --git a/src/builtin.lisp b/src/builtin.lisp new file mode 100644 index 0000000..7ea022e --- /dev/null +++ b/src/builtin.lisp @@ -0,0 +1,306 @@ +;;; -*-lisp-*- +;;; +;;; Builtin module provides the root of the class graph +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Infrastructure. + +(defvar *class-slot-alist* nil) + +(defun add-class-slot-function (name function) + "Attach a slot function to the *class-slot-alist*. + + The FUNCTION is invoked with one argument, which is a `sod-class' object + to which it should add a slot. If a function with the same NAME is + already defined then that function is replaced; otherwise a new name/ + function pair is defined. + + Functions are are invoked in the order in which their names were first + added." + + (aif (assoc name *class-slot-alist* :test #'string=) + (setf (cdr it) function) + (asetf *class-slot-alist* (append it (list (cons name function)))))) + +(defmacro define-class-slot + (name (class &optional stream) type init &body prepare) + "Define a new class slot. + + The slot will be caled NAME, and will be of TYPE (which should be a type + S-expression). The slot's (static) initializer will be constructed by + printing the value of INIT, which is evaluated with CLASS bound to the + class object being constructed. If any PREPARE forms are provided, then + they are evaluated as a progn; they are evaluated with CLASS bound to the + class object, and STREAM bound to the output stream it should write on." + + (with-gensyms (classvar) + `(add-class-slot-function + ',name + (lambda (,classvar) + (make-sod-slot ,classvar ,name (c-type ,type) + (make-property-set :lisp-class 'sod-class-slot + :initializer-function + (lambda (,class) + ,init) + ,@(and prepare + `(:prepare-function + (lambda (,class ,stream) + ,@prepare))))))))) + +;;;-------------------------------------------------------------------------- +;;; Basic information. + +(define-class-slot "name" (class) const-string + (prin1-to-string (sod-class-name class))) + +(define-class-slot "nick" (class) const-string + (prin1-to-string (sod-class-nickname class))) + +;;;-------------------------------------------------------------------------- +;;; Instance allocation and initialization. + +(define-class-slot "initsz" (class) size-t + (format nil "sizeof(struct ~A)" (ilayout-struct-tag class))) + +(define-class-slot "imprint" (class stream) + (* (fun (* void) ("/*p*/" (* void)))) + (format nil "~A__imprint" class) + (let ((ilayout (sod-class-ilayout class))) + (format stream "~&~: +/* Imprint raw memory with instance structure. */ +static void *~A__imprint(void *p) +{ + struct ~A *sod__obj = p; + + ~:{sod__obj.~A.~A._vt = &~A;~:^~% ~} + return (p); +}~2%" + class + (ilayout-struct-tag class) + (mapcar (lambda (ichain) + (let* ((head (ichain-head ichain)) + (tail (ichain-tail ichain))) + (list (sod-class-nickname head) + (sod-class-nickname tail) + (vtable-name class head)))) + (ilayout-ichains ilayout))))) + +(define-class-slot "init" (class stream) + (* (fun (* void) ("/*p*/" (* void)))) + (format nil "~A__init" class) + + ;; 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.~A" + (sod-class-nickname (ichain-head ichain)) + (sod-class-nickname (ichain-tail ichain))))) + (dolist (item (ichain-body ichain)) + (etypecase item + (vtable-pointer + nil) + (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 + (format stream " ~A.~A =" isl + (sod-slot-name dslot)) + (ecase (sod-initializer-value-kind init) + (:simple (write (sod-initializer-value-form init) + :stream stream + :pretty nil :escape nil) + (format stream ";~%")) + (:compound (format stream " (~A) {" + (sod-slot-type dslot)) + (write (sod-initializer-value-form init) + :stream stream + :pretty nil :escape nil) + (format stream "};~%")))))))))))) + (format stream "~&~: + return (p); +}~2%"))) + +;;;-------------------------------------------------------------------------- +;;; Superclass structure. + +(define-class-slot "n_supers" (class) size-t + (length (sod-class-direct-superclasses class))) + +(define-class-slot "supers" (class stream) + (* (* (class "SodClass" :const) :const)) + (if (null (sod-class-direct-superclasses class)) 0 + (format nil "~A__supers" class)) + (let ((supers (sod-class-direct-superclasses class))) + (when supers + (format stream "~&~: +/* Direct superclasses. */ +static const SodClass *const ~A__supers[] = { + ~{~A__class~^,~% ~} +};~2%" + class supers)))) + +(define-class-slot "n_cpl" (class) size-t + (length (sod-class-precedence-list class))) + +(define-class-slot "cpl" (class stream) + (* (* (class "SodClass" :const) :const)) + (format nil "~A__cpl" class) + (format stream "~&~: +/* Class precedence list. */ +static const SodClass *const ~A__cpl[] = { + ~{~A__class~^,~% ~} +};~2%" + class (sod-class-precedence-list class))) + +;;;-------------------------------------------------------------------------- +;;; Chain structure. + +(define-class-slot "link" (class) (* (class "SodClass" :const)) + (aif (sod-class-chain-link class) + (format nil "~A__class" it) + 0)) + +(define-class-slot "head" (class) (* (class "SodClass" :const)) + (format nil "~A__class" (sod-class-chain-head class))) + +(define-class-slot "level" (class) size-t + (position class (reverse (sod-class-chain class)))) + +(define-class-slot "n_chains" (class) size-t + (length (sod-class-chains class))) + +(define-class-slot "chains" (class stream) (* (struct "sod_chain" :const)) + (format nil "~A__chains" class) + (let ((chains (sod-class-chains class))) + (format stream "~&~: +/* Chain structure. */ +~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)))) + +;;;-------------------------------------------------------------------------- +;;; Class-specific layout. + +(define-class-slot "off_islots" (class) size-t + (format nil "offsetof(struct ~A, ~A)" + (ichain-struct-tag class (sod-class-chain-head class)) + (sod-class-nickname class))) + +(define-class-slot "islotsz" (class) size-t + (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. + (dolist (slot *class-slot-alist*) + (funcall (cdr slot) sod-class)) + + ;; 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 "SOD-BASE" + :type "SOD" + :case :common) + :state nil)) + (include (format nil "#include \"~A\"~%" + (make-pathname :name "SOD" :type "H" + :case :common)))) + (call-with-module-environment + (lambda () + (dolist (name '("va_list" "size_t" "ptrdiff_t")) + (add-to-module module (make-instance 'type-item :name name))) + (add-to-module module (make-instance 'code-fragment-item + :reason :c + :constraints nil + :name :includes + :fragment include)) + (bootstrap-classes module))) + module)) + +(defvar *builtin-module* nil) + +(define-clear-the-decks reset-builtin-module + (setf *builtin-module* (make-builtin-module))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp new file mode 100644 index 0000000..bf02aa6 --- /dev/null +++ b/src/class-utilities.lisp @@ -0,0 +1,199 @@ +;;; -*-lisp-*- +;;; +;;; A collection of utility functions for SOD classes +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Finding things by name + +(export 'find-superclass-by-nick) +(defun find-superclass-by-nick (class nick) + "Returns the superclass of CLASS with nickname NICK, or signals an error." + + ;; Slightly tricky. The class almost certainly hasn't been finalized, so + ;; trundle through its superclasses and hope for the best. + (if (string= nick (sod-class-nickname class)) + class + (or (some (lambda (super) + (find nick (sod-class-precedence-list super) + :key #'sod-class-nickname + :test #'string=)) + (sod-class-direct-superclasses class)) + (error "No superclass of `~A' with nickname `~A'" class nick)))) + +(export '(find-instance-slot-by-name find-class-slot-by-name + find-message-by-name)) +(flet ((find-thing-by-name (what class list name key) + (or (find name list :key key :test #'string=) + (error "No ~A in class `~A' with name `~A'" what class name)))) + + (defun find-instance-slot-by-name (class super-nick slot-name) + (let ((super (find-superclass-by-nick class super-nick))) + (find-thing-by-name "slot" super (sod-class-slots super) + slot-name #'sod-slot-name))) + + (defun find-class-slot-by-name (class super-nick slot-name) + (let* ((meta (sod-class-metaclass class)) + (super (find-superclass-by-nick meta super-nick))) + (find-thing-by-name "slot" super (sod-class-slots super) + slot-name #'sod-slot-name))) + + (defun find-message-by-name (class super-nick message-name) + (let ((super (find-superclass-by-nick class super-nick))) + (find-thing-by-name "message" super (sod-class-messages super) + message-name #'sod-message-name)))) + +;;;-------------------------------------------------------------------------- +;;; Miscellaneous useful functions. + +(export 'sod-subclass-p) +(defun sod-subclass-p (class-a class-b) + "Return whether CLASS-A is a descendent of CLASS-B. + + Careful! Assumes that the class precedence list of CLASS-A has been + computed!" + (member class-b (sod-class-precedence-list class-a))) + +(export 'valid-name-p) +(defun valid-name-p (name) + "Checks whether NAME is a valid name. + + The rules are: + + * the name must be a string + * which is nonempty + * whose first character is alphabetic + * all of whose characters are alphanumeric or underscores + * and which doesn't contain two consecutive underscores." + + (and (stringp name) + (plusp (length name)) + (alpha-char-p (char name 0)) + (every (lambda (ch) (or (alphanumericp ch) (char= ch #\_))) name) + (not (search "__" name)))) + +(export 'find-root-superclass) +(defun find-root-superclass (class) + "Returns the `root' superclass of CLASS. + + The root superclass is the superclass which itself has no direct + superclasses. In universes not based on the provided builtin module, the + root class may not be our beloved SodObject; however, there must be one + (otherwise the class graph is cyclic, which should be forbidden), and we + insist that it be unique." + + ;; The root superclass must be a chain head since the chains partition the + ;; superclasses; the root has no superclasses so it can't have a link and + ;; must therefore be a head. This narrows the field down quite a lot. + ;; + ;; Note! This function gets called from `check-sod-class' before the + ;; class's chains have been computed. Therefore we iterate over the direct + ;; superclass's chains rather than the class's own. This misses a chain + ;; only in the case where the class is its own chain head. There are two + ;; subcases: if there are no direct superclasses at all, then the class is + ;; its own root; otherwise, it clearly can't be the root and the omission + ;; is harmless. + + (let* ((supers (sod-class-direct-superclasses class)) + (roots (if supers + (remove-duplicates + (remove-if #'sod-class-direct-superclasses + (mappend (lambda (super) + (mapcar (lambda (chain) + (sod-class-chain-head + (car chain))) + (sod-class-chains super))) + supers))) + (list class)))) + (cond ((null roots) (error "Class ~A has no root class!" class)) + ((cdr roots) (error "Class ~A has multiple root classes ~ + ~{~A~#[~; and ~;, ~]~}" + class roots)) + (t (car roots))))) + +(export 'find-root-metaclass) +(defun find-root-metaclass (class) + "Returns the `root' metaclass of CLASS. + + The root metaclass is the metaclass of the root superclass -- see + `find-root-superclass'." + (sod-class-metaclass (find-root-superclass class))) + +;;;-------------------------------------------------------------------------- +;;; Type hacking. + +(export 'argument-lists-compatible-p) +(defun argument-lists-compatible-p (message-args method-args) + "Compare argument lists for compatibility. + + Return true if METHOD-ARGS is a suitable method argument list + corresponding to the message argument list MESSAGE-ARGS. This is the case + if the lists are the same length, each message argument has a + corresponding method argument with the same type, and if the message + arguments end in an ellpisis, the method arguments must end with a + `va_list' argument. (We can't pass actual variable argument lists around, + except as `va_list' objects, which are devilish inconvenient things and + require much hacking. See the method combination machinery for details.)" + + (and (= (length message-args) (length method-args)) + (every (lambda (message-arg method-arg) + (if (eq message-arg :ellipsis) + (eq method-arg (c-type va-list)) + (c-type-equal-p (argument-type message-arg) + (argument-type method-arg)))) + message-args method-args))) + +;;;-------------------------------------------------------------------------- +;;; Names of things. + +(export 'islots-struct-tag) +(defun islots-struct-tag (class) + (format nil "~A__islots" class)) + +(export 'ichain-struct-tag) +(defun ichain-struct-tag (class chain-head) + (format nil "~A__ichain_~A" class (sod-class-nickname chain-head))) + +(export 'ichain-union-tag) +(defun ichain-union-tag (class chain-head) + (format nil "~A__ichainu_~A" class (sod-class-nickname chain-head))) + +(export 'ilayout-struct-tag) +(defun ilayout-struct-tag (class) + (format nil "~A__ilayout" class)) + +(export 'vtmsgs-struct-tag) +(defun vtmsgs-struct-tag (class super) + (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) + +(export 'vtable-struct-tag) +(defun vtable-struct-tag (class chain-head) + (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) + +(export 'vtable-name) +(defun vtable-name (class chain-head) + (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/classes.lisp b/src/classes.lisp new file mode 100644 index 0000000..3d01f57 --- /dev/null +++ b/src/classes.lisp @@ -0,0 +1,445 @@ +;;; -*-lisp-*- +;;; +;;; Class definitions for main classes +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Classes. + +(export '(sod-class sod-class-name sod-class-nickname + sod-class-type sod-class-metaclass + sod-class-direct-superclasses sod-class-precedence-list + sod-class-chain-link sod-class-chain-head + sod-class-chain sod-class-chains + sod-class-slots + sod-class-instance-initializers sod-class-class-initializers + sod-class-messages sod-class-methods + sod-class-state + sod-class-ilayout sod-class-vtables)) +(defclass sod-class () + ((name :initarg :name :type string :reader sod-class-name) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (nickname :initarg :nick :type string :reader sod-class-nickname) + (direct-superclasses :initarg :superclasses :type list + :reader sod-class-direct-superclasses) + (chain-link :initarg :link :type (or sod-class null) + :reader sod-class-chain-link) + (metaclass :initarg :metaclass :type sod-class + :reader sod-class-metaclass) + (slots :initarg :slots :initform nil + :type list :accessor sod-class-slots) + (instance-initializers :initarg :instance-initializers :initform nil + :type list + :accessor sod-class-instance-initializers) + (class-initializers :initarg :class-initializers :initform nil + :type list :accessor sod-class-class-initializers) + (messages :initarg :messages :initform nil + :type list :accessor sod-class-messages) + (methods :initarg :methods :initform nil + :type list :accessor sod-class-methods) + + (class-precedence-list :type list :accessor sod-class-precedence-list) + + (type :type c-class-type :accessor sod-class-type) + + (chain-head :type sod-class :accessor sod-class-chain-head) + (chain :type list :accessor sod-class-chain) + (chains :type list :accessor sod-class-chains) + + (ilayout :type ilayout :accessor sod-class-ilayout) + (effective-methods :type list :accessor sod-class-effective-methods) + (vtables :type list :accessor sod-class-vtables) + + (state :initform nil :type (member nil :finalized broken) + :accessor sod-class-state)) + (:documentation + "Classes describe the layout and behaviour of objects. + + The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAIN-LINK and + METACLASS slots are intended to be initialized when the class object is + constructed: + + * The NAME is the identifier associated with the class in the user's + source file. It is used verbatim in the generated C code as a type + name, and must be distinct from other file-scope names in any source + file which includes the class definition. Furthermore, other names + are derived from the class name (most notably the class object + NAME__class), which have external linkage and must therefore be + distinct from all other identifiers in the program. It is forbidden + for a class NAME to begin with an underscore or to contain two + consecutive underscores. + + * The LOCATION identifies where in the source the class was defined. It + gets used in error messages. + + * The NICKNAME is a shorter identifier used to name the class in some + circumstances. The uniqueness requirements on NICKNAME are less + strict, which allows them to be shorter: no class may have two classes + with the same nickname on its class precedence list. Nicknames are + used (user-visibly) to distinguish slots and messages defined by + different classes, and (invisibly) in the derived names of direct + methods. It is forbidden for a nickname to begin with an underscore, + or to contain two consecutive underscores. + + * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses, + in the order that they were declared in the source. The class + precedence list is computed from the DIRECT-SUPERCLASSES lists of all + of the superclasses involved. + + * The CHAIN-LINK is either NIL or one of the DIRECT-SUPERCLASSES. Class + chains are a means for recovering most of the benefits of simple + hierarchy lost by the introduction of multiple inheritance. A class's + superclasses (including itself) are partitioned into chains, + consisting of a class, its CHAIN-LINK superclass, that class's + CHAIN-LINK, and so on. It is an error if two direct subclasses of any + class appear in the same chain (a global property which requires + global knowledge of an entire program's class hierarchy in order to + determine sensibly). Slots of superclasses in the same chain can be + accessed efficiently; there is an indirection needed to access slots + of superclasses in other chains. Furthermore, an indirection is + required to perform a cross-chain conversion (i.e., converting a + pointer to an instance of some class into a pointer to an instance of + one of its superclasses in a different chain), an operation which + occurs implicitly in effective methods in order to call direct methods + defined on cross-chain superclasses. + + * The METACLASS is the class of the class object. Classes are objects + in their own right, and therefore must be instances of some class; + this class is the metaclass. Metaclasses can define additional slots + and methods to be provided by their instances; a class definition can + provide (C constant expression) initial values for the metaclass + instance. + + The next few slots can't usually be set at object-construction time, since + the objects need to contain references to the class object itself. + + * The SLOTS are a list of the slots defined by the class (instances of + `sod-slot'). (The class will also define all of the slots defined by + its superclasses.) + + * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of + initializers for slots (see `sod-initializer' and subclasses), + providing initial values for instances of the class, and for the + class's class object itself, respectively. + + * The MESSAGES are a list of the messages recognized by the class + (instances of `sod-message' and subclasses). (Note that the message + need not have any methods defined on it. The class will also + recognize all of the messages defined by its superclasses.) + + * The METHODS are a list of (direct) methods defined on the class + (instances of `sod-method' and subclasses). Each method provides + behaviour to be invoked by a particular message recognized by the + class. + + Other slots are computed from these in order to describe the class's + layout and effective methods; this is done by `finalize-sod-class'. + + * The CLASS-PRECEDENCE-LIST is a list of superclasses in a linear order. + It is computed by `compute-class-precedence-list', whose default + implementation ensures that the order of superclasses is such that (a) + subclasses appear before their superclasses; (b) the direct + superclasses of a given class appear in the order in which they were + declared by the programmer; and (c) classes always appear in the same + relative order in all class precedence lists in the same superclass + graph. + + * The CHAIN-HEAD is the least-specific class in the class's chain. If + there is no link class then the CHAIN-HEAD is the class itself. This + slot, like the next two, is computed by the generic function + `compute-chains'. + + * The CHAIN is the list of classes on the complete primary chain, + starting from this class and ending with the CHAIN-HEAD. + + * The CHAINS are the complete collection of chains (most-to-least + specific) for the class and all of its superclasses. + + Finally, slots concerning the instance and vtable layout of the class are + computed on demand via methods on `slot-unbound'. + + * The ILAYOUT describes the layout for an instance of the class. It's + quite complicated; see the documentation of the ILAYOUT class for + detais. + + * The EFFECTIVE-METHODS are a list of effective methods, specialized for + the class. + + * The VTABLES are a list of descriptions of vtables for the class. The + individual elements are VTABLE objects, which are even more + complicated than ILAYOUT structures. See the class documentation for + details.")) + +(defmethod print-object ((class sod-class) stream) + (maybe-print-unreadable-object (class stream :type t) + (princ (sod-class-name class) stream))) + +;;;-------------------------------------------------------------------------- +;;; Slots and initializers. + +(export '(sod-slot sod-slot-name sod-slot-class sod-slot-type)) +(defclass sod-slot () + ((name :initarg :name :type string :reader sod-slot-name) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-slot-class) + (type :initarg :type :type c-type :reader sod-slot-type)) + (:documentation + "Slots are units of information storage in instances. + + Each class defines a number of slots, which function similarly to (data) + members in structures. An instance contains all of the slots defined in + its class and all of its superclasses. + + A slot carries the following information. + + * A NAME, which distinguishes it from other slots defined by the same + class. Unlike most (all?) other object systems, slots defined in + different classes are in distinct namespaces. There are no special + restrictions on slot names. + + * A LOCATION, which states where in the user's source the slot was + defined. This gets used in error messages. + + * A CLASS, which states which class defined the slot. The slot is + available in instances of this class and all of its descendents. + + * A TYPE, which is the C type of the slot. This must be an object type + (certainly not a function type, and it must be a complete type by the + time that the user header code has been scanned).")) + +(defmethod print-object ((slot sod-slot) stream) + (maybe-print-unreadable-object (slot stream :type t) + (pprint-c-type (sod-slot-type slot) stream + (format nil "~A.~A" + (sod-class-nickname (sod-slot-class slot)) + (sod-slot-name slot))))) + +(export '(sod-initializer sod-initializer-slot sod-initializer-class + sod-initializer-value-kind sod-initializer-value-form)) +(defclass sod-initializer () + ((slot :initarg :slot :type sod-slot :reader sod-initializer-slot) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-initializer-class) + (value-kind :initarg :value-kind :type keyword + :reader sod-initializer-value-kind) + (value-form :initarg :value-form :type c-fragment + :reader sod-initializer-value-form)) + (:documentation + "Provides an initial value for a slot. + + The slots of an initializer are as follows. + + * The SLOT specifies which slot this initializer is meant to initialize. + + * The LOCATION states the position in the user's source file where the + initializer was found. This gets used in error messages. (Depending + on the source layout style, this might differ from the location in the + VALUE-FORM C fragment.) + + * The CLASS states which class defined this initializer. For instance + slot initializers (`sod-instance-initializer'), this will be the same + as the SLOT's class, or be one of its descendants. For class slot + initializers (`sod-class-initializer'), this will be an instance of + the SLOT's class, or an instance of one of its descendants. + + * The VALUE-KIND states what manner of initializer we have. It can be + either `:single', indicating a standalone expression, or `:compound', + indicating a compound initializer which must be surrounded by braces + on output. + + * The VALUE-FORM gives the text of the initializer, as a C fragment. + + Typically you'll see instances of subclasses of this class in the wild + rather than instances of this class directly. See `sod-class-initializer' + and `sod-instance-initializer'.")) + +(defmethod print-object ((initializer sod-initializer) stream) + (if *print-escape* + (print-unreadable-object (initializer stream :type t) + (format stream "~A = ~A" + (sod-initializer-slot initializer) + initializer)) + (format stream "~:[{~A}~;~A~]" + (eq (sod-initializer-value-kind initializer) :single) + (sod-initializer-value-form initializer)))) + +(export 'sod-class-initializer) +(defclass sod-class-initializer (sod-initializer) + () + (:documentation + "Provides an initial value for a class slot. + + A class slot initializer provides an initial value for a slot in the class + object (i.e., one of the slots defined by the class's metaclass). Its + VALUE-FORM must have the syntax of an initializer, and its consituent + expressions must be constant expressions. + + See `sod-initializer' for more details.")) + +(export 'sod-instance-initializer) +(defclass sod-instance-initializer (sod-initializer) + () + (:documentation + "Provides an initial value for a slot in all instances. + + An instance slot initializer provides an initial value for a slot in + instances of the class. Its VALUE-FORM must have the syntax of an + initializer. Furthermore, if the slot has aggregate type, then you'd + better be sure that your compiler supports compound literals (6.5.2.5) + because that's what the initializer gets turned into. + + See `sod-initializer' for more details.")) + +;;;-------------------------------------------------------------------------- +;;; Messages and methods. + +(export '(sod-message sod-message-name sod-message-class sod-message-type)) +(defclass sod-message () + ((name :initarg :name :type string :reader sod-message-name) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-message-class) + (type :initarg :type :type c-function-type :reader sod-message-type)) + (:documentation + "Messages the means for stimulating an object to behave. + + SOD is a single-dispatch object system, like Smalltalk, C++, Python and so + on, but unlike CLOS and Dylan. Behaviour is invoked by `sending messages' + to objects. A message carries a name (distinguishing it from other + messages recognized by the same class), and a number of arguments; the + object may return a value in response. Sending a message therefore looks + very much like calling a function; indeed, each message bears the static + TYPE signature of a function. + + An object reacts to being sent a message by executing an `effective + method', constructed from the direct methods defined on the recpient's + (run-time, not necessarily statically-declared) class and its superclasses + according to the message's `method combination'. + + Much interesting work is done by subclasses of `sod-message', which (for + example) specify method combinations. + + The slots are as follows. + + * The NAME distinguishes the message from others defined by the same + class. Unlike most (all?) other object systems, messages defined in + different classes are in distinct namespaces. It is forbidden for a + message name to begin with an underscore, or to contain two + consecutive underscores. (Final underscores are fine.) + + * The LOCATION states where in the user's source the slot was defined. + It gets used in error messages. + + * The CLASS states which class defined the message. + + * The TYPE is a function type describing the message's arguments and + return type. + + Subclasses can (and probably will) define additional slots.")) + +(defmethod print-object ((message sod-message) stream) + (maybe-print-unreadable-object (message stream :type t) + (pprint-c-type (sod-message-type message) stream + (format nil "~A.~A" + (sod-class-nickname (sod-message-class message)) + (sod-message-name message))))) + +(export '(sod-method sod-method-message sod-method-class sod-method-type + sod-method-body)) +(defclass sod-method () + ((message :initarg :message :type sod-message :reader sod-method-message) + (location :initarg :location :initform (file-location nil) + :type file-location :reader file-location) + (class :initarg :class :type sod-class :reader sod-method-class) + (type :initarg :type :type c-function-type :reader sod-method-type) + (body :initarg :body :type (or c-fragment null) :reader sod-method-body)) + (:documentation + "(Direct) methods are units of behaviour. + + Methods are the unit of behaviour in SOD. Classes define direct methods + for particular messages. + + When a message is received by an instance, all of the methods defined for + that message on that instance's (run-time, not static) class and its + superclasses are `applicable'. The applicable methods are gathered + together and invoked in some way; the details of this are left to the + `method combination', determined by the subclass of `sod-message'. + + The slots are as follows. + + * The MESSAGE describes which meessage invokes the method's behaviour. + The method is combined with other methods on the same message + according to the message's method combination, to form an `effective + method'. + + * The LOCATION states where, in the user's source, the method was + defined. This gets used in error messages. (Depending on the user's + coding style, this location might be subtly different from the BODY's + location.) + + * The CLASS specifies which class defined the method. This will be + either the class of the message, or one of its descendents. + + * The TYPE gives the type of the method, including its arguments. This + will, in general, differ from the type of the message for several + reasons. + + -- Firstly, the method type must include names for all of the + method's parameters. The message definition can omit the + parameter names (in the same way as a function declaration can). + Formally, the message definition can contain abstract + declarators, whereas method definitions must not. + + -- Method combinations may require different parameter or return + types. For example, `before' and `after' methods don't + contribute to the message's return value, so they must be defined + as returning `void'. + + -- Method combinations may permit methods whose parameter and/or + return types don't exactly match the corresponding types of the + message. For example, one might have methods with covariant + return types and contravariant parameter types. (This sounds + nice, but it doesn't actually seem like such a clever idea when + you consider that the co-/contravariance must hold among all the + applicable methods ordered according to the class precedence + list. As a result, a user might have to work hard to build + subclasses whose CPLs match the restrictions implied by the + method types.) + + Method objects are fairly passive in the SOD translator. However, + subclasses of `sod-message' may (and probably will) construct instances of + subclasses of `sod-method' in order to carry the additional metadata they + need to keep track of.")) + +(defmethod print-object ((method sod-method) stream) + (maybe-print-unreadable-object (method stream :type t) + (format stream "~A ~@_~A" + (sod-method-message method) + (sod-method-class method)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/foo.lisp b/src/foo.lisp new file mode 100644 index 0000000..4063c03 --- /dev/null +++ b/src/foo.lisp @@ -0,0 +1,7 @@ +(cl:in-package #:sod) + +(defun list-tokens (scanner) + (let ((toke (make-instance 'sod-token-scanner :char-scanner scanner))) + (loop collect (list (token-type toke) (token-value toke)) + until (scanner-at-eof-p toke) + do (scanner-step toke)))) diff --git a/src/impl-c-types-class.lisp b/src/impl-c-types-class.lisp new file mode 100644 index 0000000..f61d84f --- /dev/null +++ b/src/impl-c-types-class.lisp @@ -0,0 +1,145 @@ +;;; -*-lisp-*- +;;; +;;; Integrating classes into the C type system +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Class definition. + +(export '(c-class-type c-type-class)) +(defclass c-class-type (simple-c-type) + ((class :initarg :class :initform nil + :type (or null sod-class) :accessor c-type-class) + (tag :initarg :tag)) + (:documentation + "A SOD class, as a C type. + + One usually handles classes as pointers, but the type refers to the actual + instance structure itself. Or, in fact, just the primary chain of the + instance (i.e., the one containing the class's own direct slots) -- which + is why dealing with the instance structure directly doesn't make much + sense. + + The CLASS slot will be NIL if the class isn't defined yet, i.e., this + entry was constructed by a forward reference operation. + + The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print + the type even when it's a forward reference.")) + +;; Constructor function and interning. + +(define-module-var *module-type-map* (make-hash-table :test #'equal) + "Table mapping identifiers to C type objects. + + Each module has its own map.") + +(export 'find-class-type) +(defun find-class-type (name) + "Look up NAME and return the corresponding C-CLASS-TYPE. + + * If the type was found, and was a class, returns TYPE. + + * If no type was found at all, returns NIL. + + * If a type was found, but it wasn't a class, signals an error." + + (atypecase (gethash name *module-type-map*) + (null nil) + (c-class-type it) + (t (error "Type `~A' (~A) is not a class" name it)))) + +(export 'make-class-type) +(defun make-class-type (name &optional qualifiers) + "Make a distinguished object for the class type called NAME." + + ;; We're in an awkward situation. We want to enter it into the + ;; `*c-type-intern-map*' so that it will handle the qualifiers list for + ;; us. But that map isn't scoped to particular modules, so we maintain our + ;; own `*module-type-map*'. But now we need to keep them in sync. + ;; + ;; The solution is to make the `*module-type-map*' be the master. Each + ;; class-type object has a tag -- a gensym, so that `equal' will think + ;; they're different, and we use the tag as part of the input to + ;; `intern-c-type'. + ;; + ;; So the first thing to do is to find the tag for the basic type, without + ;; any qualifiers. + (multiple-value-bind (type tag) + (aif (find-class-type name) + (values it (slot-value it 'tag)) + (let* ((tag (gensym "TAG-")) + (type (intern-c-type 'c-class-type :name name :tag tag))) + (values type tag))) + + ;; If no qualifiers are wanted then we've already found or created the + ;; wanted type. Otherwise we'll intern another type with the right + ;; qualifiers. + (if (null qualifiers) + type + (intern-c-type 'c-class-type + :name name :tag tag + :qualifiers (canonify-qualifiers qualifiers))))) + +;; Comparison protocol. + +(defmethod c-type-equal-p and + ((type-a c-class-type) (type-b c-class-type)) + (eql (c-type-class type-a) (c-type-class type-b))) + +;; S-expression notation protocol. + +(defmethod print-c-type (stream (type c-class-type) &optional colon atsign) + (declare (ignore colon atsign)) + (format stream "~:@" + (c-type-name type) + (c-type-qualifiers type))) + +(export 'class) +(define-c-type-syntax class (name &rest quals) + "Returns a type object for the named class." + `(make-class-type ,name (list ,@quals))) + +;;;-------------------------------------------------------------------------- +;;; Additional functions for lookup. + +(export 'find-sod-class) +(defun find-sod-class (name) + "Return the SOD-CLASS object with the given NAME." + (aif (find-class-type name) + (or (c-type-class it) (error "Class `~A' is incomplete" name)) + (error "Type `~A' not known" name))) + +(export 'record-sod-class) +(defun record-sod-class (class) + "Record CLASS as being a class definition." + (with-default-error-location (class) + (let* ((name (sod-class-name class)) + (type (make-class-type name))) + (if (c-type-class type) + (cerror* "Class `~A' already defined at ~A" + name (file-location (c-type-class type))) + (setf (c-type-class type) class))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/c-types.lisp b/src/impl-c-types.lisp similarity index 54% rename from c-types.lisp rename to src/impl-c-types.lisp index ed7f922..7892565 100644 --- a/c-types.lisp +++ b/src/impl-c-types.lisp @@ -1,13 +1,13 @@ ;;; -*-lisp-*- ;;; -;;; Dealing with C types +;;; C type representation implementation ;;; -;;; (c) 2008 Straylight/Edgeware +;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Simple Object Definition system. +;;; This file is part of the Sensble 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 @@ -26,223 +26,73 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Plain old C types. - -;; Class definition. - -(defclass c-type () - () - (:documentation - "Base class for C type objects.")) - -;; Important protocol. - -(defgeneric c-type-subtype (type) - (:documentation - "For compound types, return the base type.")) - -(defgeneric c-type-equal-p (type-a type-b) - (:method-combination and) - (:documentation - "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.") - (:method and (type-a type-b) - (eql (class-of type-a) (class-of type-b)))) - -(defgeneric pprint-c-type (type stream kernel) - (:documentation - "Pretty-printer for C types. - - Print TYPE to STREAM. In the middle of the declarator, call the function - KERNEL with one argument: whether it needs a leading space.") - (:method :around (type stream kernel) - (typecase kernel - (function (call-next-method)) - (null (pprint-c-type type stream - (lambda (stream prio spacep) - (declare (ignore stream prio spacep)) - nil))) - (t (pprint-c-type type stream - (lambda (stream prio spacep) - (declare (ignore prio)) - (when spacep - (c-type-space stream)) - (princ kernel stream))))))) - -(defgeneric print-c-type (stream type &optional colon atsign) - (:documentation - "Print an abbreviated syntax for TYPE to the STREAM.")) - -(defmethod print-object ((object c-type) stream) - (if *print-escape* - (format stream "~:@" object) - (pprint-c-type object stream nil))) - -;; Utility functions and macros. - -(defun c-type-space (stream) - "Print a space and a miser-mode newline to STREAM. - - This is the right function to call in a PPRINT-C-TYPE kernel function when - the SPACEP argument is true." - (pprint-indent :block 2 stream) - (write-char #\space stream) - (pprint-newline :miser stream)) - -(defun maybe-in-parens* (stream condition thunk) - "Helper function for the MAYBE-IN-PARENS macro." - (pprint-logical-block - (stream nil - :prefix (if condition "(" "") - :suffix (if condition ")" "")) - (funcall thunk stream))) - -(defmacro maybe-in-parens ((stream condition) &body body) - "Evaluate BODY; if CONDITION, write parens to STREAM around it. - - This macro is useful for implementing the PPRINT-C-TYPE method on compound - types. The BODY is evaluated in the context of a logical block printing - to STREAM. If CONDITION is non-nil, then the block will have open/close - parens as its prefix and suffix; otherwise they will be empty. - - The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol." - `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body))) - -;; S-expression syntax machinery. - -(defun c-name-case (name) - "Convert NAME to suitable case. - - Strings are returned as-is; symbols are squashed to lower-case and hyphens - are replaced by underscores." - (typecase name - (symbol (with-output-to-string (out) - (loop for ch across (symbol-name name) - do (cond ((alpha-char-p ch) - (write-char (char-downcase ch) out)) - ((or (digit-char-p ch) - (char= ch #\_)) - (write-char ch out)) - ((char= ch #\-) - (write-char #\_ out)) - (t - (error "Bad character in C name ~S." name)))))) - (t name))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defgeneric expand-c-type-spec (spec) - (:documentation - "Expand SPEC into Lisp code to construct a C type.") - (:method ((spec list)) - (expand-c-type-form (car spec) (cdr spec)))) - (defgeneric expand-c-type-form (head tail) - (:documentation - "Expand a C type list beginning with HEAD.") - (:method ((name (eql 'lisp)) tail) - `(progn ,@tail)))) - -(defmacro c-type (spec) - "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC." - (expand-c-type-spec spec)) - -(defmacro define-c-type-syntax (name bvl &rest body) - "Define a C-type syntax function. - - A function defined by BODY and with lambda-list BVL is associated with the - NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this - function with the argument list STUFF." - (let ((headvar (gensym "HEAD")) - (tailvar (gensym "TAIL"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar) - (destructuring-bind ,bvl ,tailvar - ,@body))))) - -(defmacro c-type-alias (original &rest aliases) - "Make ALIASES behave the same way as the ORIGINAL type." - (let ((headvar (gensym "HEAD")) - (tailvar (gensym "TAIL"))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(mapcar (lambda (alias) - `(defmethod expand-c-type-form - ((,headvar (eql ',alias)) ,tailvar) - (expand-c-type-form ',original ,tailvar))) - aliases)))) - -(defmacro defctype (names value) - "Define NAMES all to describe the C-type VALUE. - - NAMES can be a symbol (treated as a singleton list), or a list of symbols. - The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will - be expanded once at run-time." - (let* ((names (if (listp names) names (list names))) - (namevar (gensym "NAME")) - (typevar (symbolicate 'c-type- (car names)))) - `(progn - (defparameter ,typevar ,(expand-c-type-spec value)) - (eval-when (:compile-toplevel :load-toplevel :execute) - ,@(mapcar (lambda (name) - `(defmethod expand-c-type-spec ((,namevar (eql ',name))) - ',typevar)) - names))))) +;;; Interning types. + +(defparameter *c-type-intern-map* (make-hash-table :test #'equal) + "Hash table mapping lists describing types to their distinguished + representations.") + +(defun intern-c-type (class &rest initargs) + "If the CLASS and INITARGS have already been interned, then return the + existing object; otherwise make a new one." + (let ((list (cons class initargs))) + (or (gethash list *c-type-intern-map*) + (let ((new (apply #'make-instance class initargs))) + (setf (gethash new *c-type-intern-map*) t + (gethash list *c-type-intern-map*) new))))) + +#+test +(defun check-type-intern-map () + "Sanity check for the type-intern map." + (let ((map (make-hash-table))) + + ;; Pass 1: check that interned types are consistent with their keys. + ;; Remember interned types. + (maphash (lambda (k v) + (when (listp k) + (let ((ty (apply #'make-instance k))) + (assert (c-type-equal-p ty v))) + (setf (gethash v map) t))) + *c-type-intern-map*) + + ;; Pass 2: check that the interned type indicators are correct. + (maphash (lambda (k v) + (declare (ignore v)) + (assert (gethash k *c-type-intern-map*))) + map) + (maphash (lambda (k v) + (declare (ignore v)) + (when (typep k 'c-type) + (assert (gethash k map)))) + *c-type-intern-map*))) ;;;-------------------------------------------------------------------------- -;;; Types which can accept qualifiers. +;;; Simple C types. -;; Basic definitions. +;; Class definition. -(defclass qualifiable-c-type (c-type) - ((qualifiers :initarg :qualifiers :initform nil - :type list :accessor c-type-qualifiers)) +(export '(simple-c-type c-type-name)) +(defclass simple-c-type (qualifiable-c-type) + ((name :initarg :name :type string :reader c-type-name)) (:documentation - "Base class for C types which can be qualified.")) - -(defun format-qualifiers (quals) - "Return a string listing QUALS, with a space after each." - (format nil "~{~(~A~) ~}" quals)) - -(defmethod c-type-equal-p and ((type-a qualifiable-c-type) - (type-b qualifiable-c-type)) - (flet ((fix (type) - (sort (copy-list (c-type-qualifiers type)) #'string<))) - (equal (fix type-a) (fix type-b)))) - -;; A handy utility. - -(let ((cache (make-hash-table :test #'equal))) - (defun qualify-type (c-type qualifiers) - "Returns a qualified version of C-TYPE. - - Maintains a cache of qualified types so that we don't have to run out of - memory. This can also speed up type comparisons." - (if (null qualifiers) - c-type - (let ((key (cons c-type qualifiers))) - (unless (typep c-type 'qualifiable-c-type) - (error "~A isn't qualifiable." (class-name (class-of c-type)))) - (or (gethash key cache) - (setf (gethash key cache) - (copy-instance c-type :qualifiers qualifiers))))))) + "C types with simple forms.")) -;;;-------------------------------------------------------------------------- -;;; Simple C types (e.g., built-in arithmetic types). +;; Constructor function and interning. -(defvar *simple-type-map* (make-hash-table :test #'equal) - "A hash table mapping type strings to Lisp symbols naming them.") +(export 'make-simple-type) +(defun make-simple-type (name &optional qualifiers) + "Make a distinguished object for the simple type called NAME." + (intern-c-type 'simple-c-type + :name name + :qualifiers (canonify-qualifiers qualifiers))) -;; Basic definitions. +;; Comparison protocol. -(defclass simple-c-type (qualifiable-c-type) - ((name :initarg :name :type string :reader c-type-name)) - (:documentation - "C types with simple forms.")) +(defmethod c-type-equal-p and + ((type-a simple-c-type) (type-b simple-c-type)) + (string= (c-type-name type-a) (c-type-name type-b))) -(let ((cache (make-hash-table :test #'equal))) - (defun make-simple-type (name &optional qualifiers) - "Make a distinguished object for the simple type called NAME." - (qualify-type (or (gethash name cache) - (setf (gethash name cache) - (make-instance 'simple-c-type :name name))) - qualifiers))) +;; C syntax output protocol. (defmethod pprint-c-type ((type simple-c-type) stream kernel) (pprint-logical-block (stream nil) @@ -251,9 +101,10 @@ (c-type-name type)) (funcall kernel stream 0 t))) -(defmethod c-type-equal-p and ((type-a simple-c-type) - (type-b simple-c-type)) - (string= (c-type-name type-a) (c-type-name type-b))) +;; S-expression notation protocol. + +(defparameter *simple-type-map* (make-hash-table) + "Hash table mapping strings of C syntax to symbolic names.") (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign) (declare (ignore colon atsign)) @@ -262,14 +113,13 @@ (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]" (c-type-qualifiers type) (or symbol name)))) -;; S-expression syntax. - (eval-when (:compile-toplevel :load-toplevel :execute) (defmethod expand-c-type-spec ((spec string)) `(make-simple-type ,spec)) (defmethod expand-c-type-form ((head string) tail) - `(make-simple-type ,head ,@tail))) + `(make-simple-type ,head (list ,@tail)))) +(export 'define-simple-c-type) (defmacro define-simple-c-type (names type) "Define each of NAMES to be a simple type called TYPE." (let ((names (if (listp names) names (list names)))) @@ -279,6 +129,18 @@ (define-c-type-syntax ,(car names) (&rest quals) `(make-simple-type ,',type (list ,@quals)))))) +;; Built-in C types. + +(export '(void float double long-double va-list size-t ptrdiff-t + char unsigned-char uchar signed-char schar + int signed signed-int sint unsigned unsigned-int uint + short signed-short short-int signed-short-int sshort + unsigned-short unsigned-short-int ushort + long signed-long long-int signed-long-int slong + unsigned-long unsigned-long-int ulong + long-long signed-long-long long-long-int signed-long-long-int + unsigned-long-long unsigned-long-long-int llong sllong ullong)) + (define-simple-c-type void "void") (define-simple-c-type char "char") @@ -313,34 +175,51 @@ (define-simple-c-type ptrdiff-t "ptrdiff_t") ;;;-------------------------------------------------------------------------- -;;; Tag types (structs, unions and enums). +;;; Tagged types (enums, structs and unions). -;; Definitions. +;; Class definition. +(export '(tagged-c-type c-type-tag)) (defclass tagged-c-type (qualifiable-c-type) ((tag :initarg :tag :type string :reader c-type-tag)) (:documentation "C types with tags.")) +;; Subclass definitions. + +(export 'c-tagged-type-kind) (defgeneric c-tagged-type-kind (type) (:documentation "Return the kind of tagged type that TYPE is, as a keyword.")) +(export 'kind-c-tagged-type) +(defgeneric kind-c-tagged-type (kind) + (:documentation + "Given a keyword KIND, return the appropriate class name.")) + +(export 'make-c-tagged-type) +(defun make-c-tagged-type (kind tag &optional qualifiers) + "Return a tagged type with the given KIND (keyword) and TAG (string)." + (intern-c-type (kind-c-tagged-type kind) + :tag tag + :qualifiers (canonify-qualifiers qualifiers))) + (macrolet ((define-tagged-type (kind what) - (let ((type (symbolicate 'c- kind '-type)) - (constructor (symbolicate 'make- kind '-type))) + (let* ((type (symbolicate 'c- kind '-type)) + (keyword (intern (symbol-name kind) :keyword)) + (constructor (symbolicate 'make- kind '-type))) `(progn + (export '(,type ,constructor)) (defclass ,type (tagged-c-type) () (:documentation ,(format nil "C ~a types." what))) (defmethod c-tagged-type-kind ((type ,type)) - ',kind) - (let ((cache (make-hash-table :test #'equal))) - (defun ,constructor (tag &optional qualifiers) - (qualify-type (or (gethash tag cache) - (setf (gethash tag cache) - (make-instance ',type - :tag tag))) - qualifiers))) + ',keyword) + (defmethod kind-c-tagged-type ((kind (eql ',keyword))) + ',type) + (defun ,constructor (tag &optional qualifiers) + (intern-c-type ',type :tag tag + :qualifiers (canonify-qualifiers + qualifiers))) (define-c-type-syntax ,kind (tag &rest quals) ,(format nil "Construct ~A type named TAG" what) `(,',constructor ,tag (list ,@quals))))))) @@ -348,6 +227,13 @@ (define-tagged-type struct "structure") (define-tagged-type union "union")) +;; Comparison protocol. + +(defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type)) + (string= (c-type-tag type-a) (c-type-tag type-b))) + +;; C syntax output protocol. + (defmethod pprint-c-type ((type tagged-c-type) stream kernel) (pprint-logical-block (stream nil) (format stream "~{~(~A~) ~@_~}~(~A~) ~A" @@ -356,9 +242,7 @@ (c-type-tag type)) (funcall kernel stream 0 t))) -(defmethod c-type-equal-p and ((type-a tagged-c-type) - (type-b tagged-c-type)) - (string= (c-type-tag type-a) (c-type-tag type-b))) +;; S-expression notation protocol. (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign) (declare (ignore colon atsign)) @@ -370,19 +254,32 @@ ;;;-------------------------------------------------------------------------- ;;; Pointer types. -;; Definitions. +;; Class definition. +(export 'c-pointer-type) (defclass c-pointer-type (qualifiable-c-type) ((subtype :initarg :subtype :type c-type :reader c-type-subtype)) - (:documentation - "C pointer types.")) + (:documentation "C pointer types.")) -(let ((cache (make-hash-table :test #'eql))) - (defun make-pointer-type (subtype &optional qualifiers) - "Return a (maybe distinguished) pointer type." - (qualify-type (or (gethash subtype cache) - (make-instance 'c-pointer-type :subtype subtype)) - qualifiers))) +;; Constructor function. + +(export 'make-pointer-type) +(defun make-pointer-type (subtype &optional qualifiers) + "Return a (maybe distinguished) pointer type." + (let ((canonical (canonify-qualifiers qualifiers))) + (funcall (if (gethash subtype *c-type-intern-map*) + #'intern-c-type #'make-instance) + 'c-pointer-type + :subtype subtype + :qualifiers canonical))) + +;; Comparison protocol. + +(defmethod c-type-equal-p and ((type-a c-pointer-type) + (type-b c-pointer-type)) + (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b))) + +;; C syntax output protocol. (defmethod pprint-c-type ((type c-pointer-type) stream kernel) (pprint-c-type (c-type-subtype type) stream @@ -393,43 +290,76 @@ (c-type-qualifiers type)) (funcall kernel stream 1 (c-type-qualifiers type)))))) -(defmethod c-type-equal-p and ((type-a c-pointer-type) - (type-b c-pointer-type)) - (c-type-equal-p (c-type-subtype type-a) - (c-type-subtype type-b))) +;; S-expression notation protocol. (defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign) (declare (ignore colon atsign)) - (format stream "~:@<* ~@_~/sod::print-c-type/~{ ~_~S~}~:>" + (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>" (c-type-subtype type) (c-type-qualifiers type))) -;; S-expression syntax. - +(export '(* pointer ptr)) (define-c-type-syntax * (sub &rest quals) "Return the type of pointer-to-SUB." `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals))) (c-type-alias * pointer ptr) +;; Built-in C types. + +(export '(string const-string)) (defctype string (* char)) (defctype const-string (* (char :const))) ;;;-------------------------------------------------------------------------- ;;; Array types. -;; Definitions. +;; Class definition. +(export '(c-array-type c-array-dimensions)) (defclass c-array-type (c-type) ((subtype :initarg :subtype :type c-type :reader c-type-subtype) (dimensions :initarg :dimensions :type list :reader c-array-dimensions)) (:documentation "C array types.")) +;; Constructor function. + +(export 'make-array-type) (defun make-array-type (subtype dimensions) "Return a new array of SUBTYPE with given DIMENSIONS." (make-instance 'c-array-type :subtype subtype :dimensions (or dimensions '(nil)))) +;; Comparison protocol. + +(defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type)) + + ;; Messy. C doesn't have multidimensional arrays, but we fake them for + ;; convenience's sake. But it means that we have to arrange for + ;; multidimensional arrays to equal vectors of vectors -- and in general + ;; for multidimensional arrays of multidimensional arrays to match each + ;; other properly, even when their dimensions don't align precisely. + (labels ((check (sub-a dim-a sub-b dim-b) + (cond ((endp dim-a) + (cond ((endp dim-b) + (c-type-equal-p sub-a sub-b)) + ((typep sub-a 'c-array-type) + (check (c-type-subtype sub-a) + (c-array-dimensions sub-a) + sub-b dim-b)) + (t + nil))) + ((endp dim-b) + (check sub-b dim-b sub-a dim-a)) + ((equal (car dim-a) (car dim-b)) + (check sub-a (cdr dim-a) sub-b (cdr dim-b))) + (t + nil)))) + (check (c-type-subtype type-a) (c-array-dimensions type-a) + (c-type-subtype type-b) (c-array-dimensions type-b)))) + +;; C syntax output protocol. + (defmethod pprint-c-type ((type c-array-type) stream kernel) (pprint-c-type (c-type-subtype type) stream (lambda (stream prio spacep) @@ -438,21 +368,15 @@ (format stream "~@<~{[~@[~A~]]~^~_~}~:>" (c-array-dimensions type)))))) -(defmethod c-type-equal-p and ((type-a c-array-type) - (type-b c-array-type)) - (and (c-type-equal-p (c-type-subtype type-a) - (c-type-subtype type-b)) - (equal (c-array-dimensions type-a) - (c-array-dimensions type-b)))) +;; S-expression notation protocol. (defmethod print-c-type (stream (type c-array-type) &optional colon atsign) (declare (ignore colon atsign)) - (format stream "~:@<[] ~@_~:I~/sod::print-c-type/~{ ~_~S~}~:>" + (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>" (c-type-subtype type) (c-array-dimensions type))) -;; S-expression syntax. - +(export '([] array vec)) (define-c-type-syntax [] (sub &rest dims) "Return the type of arrays of SUB with the dimensions DIMS. @@ -464,12 +388,7 @@ ;;;-------------------------------------------------------------------------- ;;; Function types. -;; Arguments. - -(defstruct (argument (:constructor make-argument (name type)) (:type list)) - "Simple list structure representing a function argument." - name - type) +;; Function arguments. (defun arguments-lists-equal-p (list-a list-b) "Return whether LIST-A and LIST-B match. @@ -484,37 +403,9 @@ (argument-type arg-b)))) list-a list-b))) -(defgeneric commentify-argument-name (name) - (:documentation - "Produce a `commentified' version of the argument. - - The default behaviour is that temporary argument names are simply omitted - (NIL is returned); otherwise, `/*...*/' markers are wrapped around the - printable representation of the argument.") - (:method ((name null)) nil) - (:method ((name t)) (format nil "/*~A*/" name))) - -(defun commentify-argument-names (arguments) - "Return an argument list with the arguments commentified. - - That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME." - (mapcar (lambda (arg) - (if (eq arg :ellipsis) - arg - (make-argument (commentify-argument-name (argument-name arg)) - (argument-type arg)))) - arguments)) - -(defun commentify-function-type (type) - "Return a type like TYPE, but with arguments commentified. - - This doesn't recurse into the return type or argument types." - (make-function-type (c-type-subtype type) - (commentify-argument-names - (c-function-arguments type)))) - -;; Definitions. +;; Class definition. +(export '(c-function-type c-function-arguments)) (defclass c-function-type (c-type) ((subtype :initarg :subtype :type c-type :reader c-type-subtype) (arguments :initarg :arguments :type list :reader c-function-arguments)) @@ -522,28 +413,22 @@ "C function types. The subtype is the return type, as implied by the C syntax for function declarations.")) +;; Constructor function. + +(export 'make-function-type) (defun make-function-type (subtype arguments) "Return a new function type, returning SUBTYPE and accepting ARGUMENTS." (make-instance 'c-function-type :subtype subtype :arguments arguments)) -(defmethod c-type-equal-p and ((type-a c-function-type) - (type-b c-function-type)) - (and (c-type-equal-p (c-type-subtype type-a) - (c-type-subtype type-b)) +;; Comparison protocol. + +(defmethod c-type-equal-p and + ((type-a c-function-type) (type-b c-function-type)) + (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)) (arguments-lists-equal-p (c-function-arguments type-a) (c-function-arguments type-b)))) -(defmethod print-c-type - (stream (type c-function-type) &optional colon atsign) - (declare (ignore colon atsign)) - (format stream - #.(concatenate 'string - "~:@<" - "FUN ~@_~:I~/sod::print-c-type/" - "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}" - "~:>") - (c-type-subtype type) - (c-function-arguments type))) +;; C syntax output protocol. (defmethod pprint-c-type ((type c-function-type) stream kernel) (pprint-c-type (c-type-subtype type) stream @@ -552,7 +437,6 @@ (when spacep (c-type-space stream)) (funcall kernel stream 2 nil) (pprint-indent :block 4 stream) - ;;(pprint-newline :miser stream) (pprint-logical-block (stream nil :prefix "(" :suffix ")") (let ((firstp t)) @@ -566,8 +450,23 @@ stream (argument-name arg)))))))))) -;; S-expression syntax. +;; S-expression notation protocol. + +(defmethod print-c-type + (stream (type c-function-type) &optional colon atsign) + (declare (ignore colon atsign)) + (format stream "~:@<~ + FUN ~@_~:I~/sod:print-c-type/~ + ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~ + ~:>" + (c-type-subtype type) + (mapcar (lambda (arg) + (if (eq arg :ellipsis) + arg + (list (argument-name arg) (argument-type arg)))) + (c-function-arguments type)))) +(export '(fun function func fn)) (define-c-type-syntax fun (ret &rest args) "Return the type of functions which returns RET and has arguments ARGS. @@ -597,8 +496,34 @@ ((or (atom args) (atom (car args))) (cond ((and (null args) (null list)) `nil) ((null args) `(list ,@(nreverse list))) + ((and (consp args) + (eq (car args) :ellipsis)) + `(list ,@(nreverse list) :ellipsis)) ((null list) `,args) (t `(list* ,@(nreverse list) ,args))))))) (c-type-alias fun function () func fn) +;; Additional utilities for dealing with functions. + +(export 'commentify-argument-names) +(defun commentify-argument-names (arguments) + "Return an argument list with the arguments commentified. + + That is, with each argument name passed through COMMENTIFY-ARGUMENT-NAME." + (mapcar (lambda (arg) + (if (eq arg :ellipsis) + arg + (make-argument (commentify-argument-name (argument-name arg)) + (argument-type arg)))) + arguments)) + +(export 'commentify-function-type) +(defun commentify-function-type (type) + "Return a type like TYPE, but with arguments commentified. + + This doesn't recurse into the return type or argument types." + (make-function-type (c-type-subtype type) + (commentify-argument-names + (c-function-arguments type)))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/cpl.lisp b/src/impl-class-finalize.lisp similarity index 59% rename from cpl.lisp rename to src/impl-class-finalize.lisp index 041e8e7..6193836 100644 --- a/cpl.lisp +++ b/src/impl-class-finalize.lisp @@ -1,13 +1,13 @@ ;;; -*-lisp-*- ;;; -;;; Computing class precedence lists +;;; Class finalization implementation ;;; ;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Simple Object Definition system. +;;; This file is part of the Sensble 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 @@ -26,10 +26,10 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Linearizations. +;;; Class precedence lists. -;; Just for fun, we implement a wide selection. C3 seems to be clearly the -;; best, with fewer sharp edges for the unwary. +;; Just for fun, we implement a wide selection of precedence list algorithms. +;; C3 seems to be clearly the best, with fewer sharp edges for the unwary. ;; ;; The extended precedence graph (EPG) is constructed by adding edges to the ;; superclass graph. If A and B are classes, then write A < B if A is a @@ -48,6 +48,8 @@ ;; Superclass Linearization for Dylan' for more detail. ;; http://www.webcom.com/haahr/dylan/linearization-oopsla96.html +;;; Tiebreaker functions. + (defun clos-tiebreaker (candidates so-far) "The CLOS linearization tiebreaker function. @@ -68,6 +70,36 @@ (error "SOD INTERNAL ERROR: Failed to break tie in CLOS.")) winner)) +(defun c3-tiebreaker (candidates cpls) + "The C3 linearization tiebreaker function. + + Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which + appears in the earliest element of CPLS, which should be the list of the + class precedence lists of the direct superclasses of the class in + question, in the order specified in the class declaration. + + The only class in the class precedence list which does not appear in one + of these lists is the new class itself, which must precede all of the + others. + + This must disambiguate, since if two classes are in the same class + precedence list, then one must appear in it before the other, which + provides an ordering between them. (In this situation we return the one + that matches earliest anyway, which would still give the right answer.) + + Note that this will merge the CPLs of superclasses /as they are/, not + necessarily as C3 would have computed them. This ensures monotonicity + assuming that the superclass CPLs are already monotonic. If they aren't, + you're going to lose anyway." + + (dolist (cpl cpls) + (dolist (candidate candidates) + (when (member candidate cpl) + (return-from c3-tiebreaker candidate)))) + (error "SOD INTERNAL ERROR: Failed to break tie in C3.")) + +;;; Linearization functions. + (defun clos-cpl (class) "Compute the class precedence list of CLASS using CLOS linearization rules. @@ -113,34 +145,6 @@ (mapcar #'sod-class-precedence-list direct-supers)) :pick #'clos-tiebreaker))) -(defun c3-tiebreaker (candidates cpls) - "The C3 linearization tiebreaker function. - - Intended for use with MERGE-LISTS. Returns the member of CANDIDATES which - appears in the earliest element of CPLS, which should be the list of the - class precedence lists of the direct superclasses of the class in - question, in the order specified in the class declaration. - - The only class in the class precedence list which does not appear in one - of these lists is the new class itself, which must precede all of the - others. - - This must disambiguate, since if two classes are in the same class - precedence list, then one must appear in it before the other, which - provides an ordering between them. (In this situation we return the one - that matches earliest anyway, which would still give the right answer.) - - Note that this will merge the CPLs of superclasses /as they are/, not - necessarily as C3 would have computed them. This ensures monotonicity - assuming that the superclass CPLs are already monotonic. If they aren't, - you're going to lose anyway." - - (dolist (cpl cpls) - (dolist (candidate candidates) - (when (member candidate cpl) - (return-from c3-tiebreaker candidate)))) - (error "SOD INTERNAL ERROR: Failed to break tie in C3.")) - (defun c3-cpl (class) "Compute the class precedence list of CLASS using C3 linearization rules. @@ -222,12 +226,7 @@ (when (member class candidates) (return class)))))))) -;;;-------------------------------------------------------------------------- -;;; Class protocol. - -(defgeneric compute-cpl (class) - (:documentation - "Returns the class precedence list for CLASS.")) +;;; Default function. (defmethod compute-cpl ((class sod-class)) (handler-case (c3-cpl class) @@ -236,98 +235,166 @@ (sod-class-name class))))) ;;;-------------------------------------------------------------------------- -;;; Testing. - -#+test -(progn - (defclass test-class () - ((name :initarg :name :accessor sod-class-name) - (direct-superclasses :initarg :superclasses - :accessor sod-class-direct-superclasses) - (class-precedence-list))) - - (defmethod print-object ((class test-class) stream) - (if *print-escape* - (print-unreadable-object (class stream :type t :identity nil) - (princ (sod-class-name class) stream)) - (princ (sod-class-name class) stream))) - - (defvar *test-linearization*) - - (defmethod sod-class-precedence-list ((class test-class)) - (if (slot-boundp class 'class-precedence-list) - (slot-value class 'class-precedence-list) - (setf (slot-value class 'class-precedence-list) - (funcall *test-linearization* class))))) - -#+test -(defun test-cpl (linearization heterarchy) - (let* ((*test-linearization* linearization) - (classes (make-hash-table :test #'equal))) - (dolist (class heterarchy) - (let ((name (car class))) - (setf (gethash (car class) classes) - (make-instance 'test-class :name name)))) - (dolist (class heterarchy) - (setf (sod-class-direct-superclasses (gethash (car class) classes)) - (mapcar (lambda (super) (gethash super classes)) (cdr class)))) - (mapcar (lambda (class) - (handler-case - (mapcar #'sod-class-name - (sod-class-precedence-list (gethash (car class) - classes))) - (inconsistent-merge-error () - (list (car class) :error)))) - heterarchy))) - -#+test -(progn - (defparameter *confused-heterarchy* - '((object) (grid-layout object) - (horizontal-grid grid-layout) (vertical-grid grid-layout) - (hv-grid horizontal-grid vertical-grid) - (vh-grid vertical-grid horizontal-grid) - (confused-grid hv-grid vh-grid))) - (defparameter *boat-heterarchy* - '((object) - (boat object) - (day-boat boat) - (wheel-boat boat) - (engine-less day-boat) - (small-multihull day-boat) - (pedal-wheel-boat engine-less wheel-boat) - (small-catamaran small-multihull) - (pedalo pedal-wheel-boat small-catamaran))) - (defparameter *menu-heterarchy* - '((object) - (choice-widget object) - (menu choice-widget) - (popup-mixin object) - (popup-menu menu popup-mixin) - (new-popup-menu menu popup-mixin choice-widget))) - (defparameter *pane-heterarchy* - '((pane) (scrolling-mixin) (editing-mixin) - (scrollable-pane pane scrolling-mixin) - (editable-pane pane editing-mixin) - (editable-scrollable-pane scrollable-pane editable-pane))) - (defparameter *baker-nonmonotonic-heterarchy* - '((z) (x z) (y) (b y) (a b x) (c a b x y))) - (defparameter *baker-nonassociative-heterarchy* - '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc))) - (defparameter *distinguishing-heterarchy* - '((object) - (a object) (b object) (c object) - (p a b) (q a c) - (u p) (v q) - (x u v) - (y x b c) - (z x c b))) - (defparameter *python-heterarchy* - '((object) - (a object) (b object) (c object) (d object) (e object) - (k1 a b c) - (k2 d b e) - (k3 d a) - (z k1 k2 k3)))) +;;; Chains. + +(defmethod compute-chains ((class sod-class)) + (with-default-error-location (class) + (with-slots (chain-link class-precedence-list) class + (let* ((head (if chain-link + (sod-class-chain-head chain-link) + class)) + (chain (cons class (and chain-link + (sod-class-chain chain-link)))) + (table (make-hash-table))) + + ;; Check the chains. We work through each superclass, maintaining a + ;; hash table keyed by class. If we encounter a class C which links + ;; to L, then we store C as L's value; if L already has a value then + ;; we've found an error. By the end of all of this, the classes + ;; which don't have an entry are the chain tails. + (dolist (super class-precedence-list) + (let ((link (sod-class-chain-link super))) + (when link + (when (gethash link table) + (error "Conflicting chains in class ~A: ~ + (~A and ~A both link to ~A)" + class super (gethash link table) link)) + (setf (gethash link table) super)))) + + ;; Done. + (values head chain + (cons chain + (mapcar #'sod-class-chain + (remove-if (lambda (super) + (gethash super table)) + (cdr class-precedence-list))))))))) + +;;;-------------------------------------------------------------------------- +;;; Sanity checking. + +(defmethod check-sod-class ((class sod-class)) + (with-default-error-location (class) + + ;; Check the names of things are valid. + (with-slots (name nickname messages) class + (unless (valid-name-p name) + (error "Invalid class name `~A'" class)) + (unless (valid-name-p nickname) + (error "Invalid class nickname `~A' on class `~A'" nickname class)) + (dolist (message messages) + (unless (valid-name-p (sod-message-name message)) + (error "Invalid message name `~A' on class `~A'" + (sod-message-name message) class)))) + + ;; Check that the slots and messages have distinct names. + (with-slots (slots messages class-precedence-list) class + (flet ((check-list (list what namefunc) + (let ((table (make-hash-table :test #'equal))) + (dolist (item list) + (let ((name (funcall namefunc item))) + (if (gethash name table) + (error "Duplicate ~A name `~A' on class `~A'" + what name class) + (setf (gethash name table) item))))))) + (check-list slots "slot" #'sod-slot-name) + (check-list messages "message" #'sod-message-name) + (check-list class-precedence-list "nickname" #'sod-class-name))) + + ;; Check that the CHAIN-TO class is actually a proper superclass. (This + ;; eliminates hairy things like a class being its own link.) + (with-slots (class-precedence-list chain-link) class + (unless (or (not chain-link) + (member chain-link (cdr class-precedence-list))) + (error "In `~A~, chain-to class `~A' is not a proper superclass" + class chain-link))) + + ;; Check for circularity in the superclass graph. Since the superclasses + ;; should already be acyclic, it suffices to check that our class is not + ;; a superclass of any of its own direct superclasses. + (let ((circle (find-if (lambda (super) + (sod-subclass-p super class)) + (sod-class-direct-superclasses class)))) + (when circle + (error "Circularity: ~A is already a superclass of ~A" + class circle))) + + ;; Check that the class has a unique root superclass. + (find-root-superclass class) + + ;; Check that the metaclass is a subclass of each direct superclass's + ;; metaclass. + (with-slots (metaclass direct-superclasses) class + (dolist (super direct-superclasses) + (unless (sod-subclass-p metaclass (sod-class-metaclass super)) + (error "Incompatible metaclass for `~A': ~ + `~A' isn't a subclass of `~A' (of `~A')" + class metaclass (sod-class-metaclass super) super)))))) + +;;;-------------------------------------------------------------------------- +;;; Finalization. + +(defmethod finalize-sod-class ((class sod-class)) + + ;; CLONE-AND-HACK WARNING: Note that BOOTSTRAP-CLASSES has a (very brief) + ;; clone of the CPL and chain establishment code. If the interface changes + ;; then BOOTSTRAP-CLASSES will need to be changed too. + + (with-default-error-location (class) + (ecase (sod-class-state class) + ((nil) + + ;; If this fails, mark the class as a loss. + (setf (sod-class-state class) :broken) + + ;; Finalize all of the superclasses. There's some special pleading + ;; here to make bootstrapping work: we don't try to finalize the + ;; metaclass if we're a root class (no direct superclasses -- because + ;; in that case the metaclass will have to be a subclass of us!), or + ;; if it's equal to us. This is enough to tie the knot at the top of + ;; the class graph. + (with-slots (name direct-superclasses metaclass) class + (dolist (super direct-superclasses) + (finalize-sod-class super)) + (unless (or (null direct-superclasses) + (eq class metaclass)) + (finalize-sod-class metaclass))) + + ;; Stash the class's type. + (setf (sod-class-type class) + (make-class-type (sod-class-name class))) + + ;; Clobber the lists of items if they've not been set. + (dolist (slot '(slots instance-initializers class-initializers + messages methods)) + (unless (slot-boundp class slot) + (setf (slot-value class slot) nil))) + + ;; If the CPL hasn't been done yet, compute it. + (with-slots (class-precedence-list) class + (unless (slot-boundp class 'class-precedence-list) + (setf class-precedence-list (compute-cpl class)))) + + ;; Check that the class is fairly sane. + (check-sod-class class) + + ;; Determine the class's layout. + (with-slots (chain-head chain chains) class + (setf (values chain-head chain chains) (compute-chains class))) + + ;; FIXME: make these slots autovivifying. + (with-slots (ilayout effective-methods vtables) class + (setf ilayout (compute-ilayout class)) + (setf effective-methods (compute-effective-methods class)) + (setf vtables (compute-vtables class))) + + ;; Done. + (setf (sod-class-state class) :finalized) + t) + + (:broken + nil) + + (:finalized + t)))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-class-layout.lisp b/src/impl-class-layout.lisp new file mode 100644 index 0000000..4bff54d --- /dev/null +++ b/src/impl-class-layout.lisp @@ -0,0 +1,395 @@ +;;; -*-lisp-*- +;;; +;;; Class layout protocol implementation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Effective slots. + +(defmethod print-object ((slot effective-slot) stream) + (maybe-print-unreadable-object (slot stream :type t) + (format stream "~A~@[ = ~@_~A~]" + (effective-slot-direct-slot slot) + (effective-slot-initializer slot)))) + +(defmethod find-slot-initializer ((class sod-class) (slot sod-slot)) + (some (lambda (super) + (find slot + (sod-class-instance-initializers super) + :key #'sod-initializer-slot)) + (sod-class-precedence-list class))) + +(defmethod compute-effective-slot ((class sod-class) (slot sod-slot)) + (make-instance 'effective-slot + :slot slot + :class class + :initializer (find-slot-initializer class slot))) + +;;;-------------------------------------------------------------------------- +;;; Special-purpose slot objects. + +(export 'sod-class-slot) +(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))) + +(export 'sod-class-effective-slot) +(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 + :class class :slot slot + :initializer-function (sod-slot-initializer-function slot) + :prepare-function (sod-slot-prepare-function slot) + :initializer (find-slot-initializer class slot))) + +;;;-------------------------------------------------------------------------- +;;; Effective methods. + +(defmethod print-object ((method effective-method) stream) + (maybe-print-unreadable-object (method stream :type t) + (format stream "~A ~A" + (effective-method-message method) + (effective-method-class method)))) + +(defmethod print-object ((entry method-entry) stream) + (maybe-print-unreadable-object (entry stream :type t) + (format stream "~A:~A" + (method-entry-effective-method entry) + (sod-class-nickname (method-entry-chain-head entry))))) + +(defmethod compute-sod-effective-method + ((message sod-message) (class sod-class)) + (let ((direct-methods (mappend (lambda (super) + (remove message + (sod-class-methods super) + :key #'sod-method-message + :test-not #'eql)) + (sod-class-precedence-list class)))) + (make-instance (message-effective-method-class message) + :message message + :class class + :direct-methods direct-methods))) + +(defmethod compute-effective-methods ((class sod-class)) + (mapcan (lambda (super) + (mapcar (lambda (message) + (compute-sod-effective-method message class)) + (sod-class-messages super))) + (sod-class-precedence-list class))) + +(defmethod slot-unbound + (clos-class (class sod-class) (slot-name (eql 'effective-methods))) + (setf (slot-value class 'effective-methods) + (compute-effective-methods class))) + +;;;-------------------------------------------------------------------------- +;;; Instance layout. + +;;; islots + +(defmethod print-object ((islots islots) stream) + (print-unreadable-object (islots stream :type t) + (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" + (islots-subclass islots) + (islots-class islots) + (islots-slots islots)))) + +(defmethod compute-islots ((class sod-class) (subclass sod-class)) + (make-instance 'islots + :class class + :subclass subclass + :slots (mapcar (lambda (slot) + (compute-effective-slot subclass slot)) + (sod-class-slots class)))) + +;;; vtable-pointer +;;; Do we need a construction protocol here? + +(defmethod print-object ((vtp vtable-pointer) stream) + (print-unreadable-object (vtp stream :type t) + (format stream "~A:~A" + (vtable-pointer-class vtp) + (sod-class-nickname (vtable-pointer-chain-head vtp))))) + +;;; ichain + +(defmethod print-object ((ichain ichain) stream) + (print-unreadable-object (ichain stream :type t) + (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" + (ichain-class ichain) + (sod-class-nickname (ichain-head ichain)) + (ichain-body ichain)))) + +(defmethod compute-ichain ((class sod-class) chain) + (let* ((chain-head (car chain)) + (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) + :key #'sod-class-chain-head)) + (vtable-pointer (make-instance 'vtable-pointer + :class class + :chain-head chain-head + :chain-tail chain-tail)) + (islots (remove-if-not #'islots-slots + (mapcar (lambda (super) + (compute-islots super class)) + chain)))) + (make-instance 'ichain + :class class + :chain-head chain-head + :chain-tail chain-tail + :body (cons vtable-pointer islots)))) + +;;; ilayout + +(defmethod print-object ((ilayout ilayout) stream) + (print-unreadable-object (ilayout stream :type t) + (format stream "~A ~_~:<~@{~S~^ ~_~}~:>" + (ilayout-class ilayout) + (ilayout-ichains ilayout)))) + +(defmethod compute-ilayout ((class sod-class)) + (make-instance 'ilayout + :class class + :ichains (mapcar (lambda (chain) + (compute-ichain class + (reverse chain))) + (sod-class-chains class)))) + +(defmethod slot-unbound + (clos-class (class sod-class) (slot-name (eql 'ilayout))) + (setf (slot-value class 'ilayout) + (compute-ilayout class))) + +;;;-------------------------------------------------------------------------- +;;; Vtable layout. + +;;; vtmsgs + +(defmethod print-object ((vtmsgs vtmsgs) stream) + (print-unreadable-object (vtmsgs stream :type t) + (format stream "~A <= ~A ~_~:<~@{~S~^ ~_~}~:>" + (vtmsgs-subclass vtmsgs) + (vtmsgs-class vtmsgs) + (vtmsgs-entries vtmsgs)))) + +(defmethod compute-vtmsgs + ((class sod-class) + (subclass sod-class) + (chain-head sod-class) + (chain-tail sod-class)) + (flet ((make-entry (message) + (let ((method (find message + (sod-class-effective-methods subclass) + :key #'effective-method-message))) + (make-method-entry method chain-head chain-tail)))) + (make-instance 'vtmsgs + :class class + :subclass subclass + :chain-head chain-head + :chain-tail chain-tail + :entries (mapcar #'make-entry + (sod-class-messages class))))) + +;;; class-pointer + +(defmethod print-object ((cptr class-pointer) stream) + (print-unreadable-object (cptr stream :type t) + (format stream "~A:~A" + (class-pointer-metaclass cptr) + (sod-class-nickname (class-pointer-meta-chain-head cptr))))) + +(defmethod make-class-pointer + ((class sod-class) (chain-head sod-class) + (metaclass sod-class) (meta-chain-head sod-class)) + + ;; Slightly tricky. We don't necessarily want a pointer to the metaclass, + ;; but to its most specific subclass on the given chain. Fortunately, CL + ;; is good at this game. + (let* ((meta-chains (sod-class-chains metaclass)) + (meta-chain-tails (mapcar #'car meta-chains)) + (meta-chain-tail (find meta-chain-head meta-chain-tails + :key #'sod-class-chain-head))) + (make-instance 'class-pointer + :class class + :chain-head chain-head + :metaclass meta-chain-tail + :meta-chain-head meta-chain-head))) + +;;; base-offset + +(defmethod print-object ((boff base-offset) stream) + (print-unreadable-object (boff stream :type t) + (format stream "~A:~A" + (base-offset-class boff) + (sod-class-nickname (base-offset-chain-head boff))))) + +(defmethod make-base-offset ((class sod-class) (chain-head sod-class)) + (make-instance 'base-offset + :class class + :chain-head chain-head)) + +;;; chain-offset + +(defmethod print-object ((choff chain-offset) stream) + (print-unreadable-object (choff stream :type t) + (format stream "~A:~A->~A" + (chain-offset-class choff) + (sod-class-nickname (chain-offset-chain-head choff)) + (sod-class-nickname (chain-offset-target-head choff))))) + +(defmethod make-chain-offset + ((class sod-class) (chain-head sod-class) (target-head sod-class)) + (make-instance 'chain-offset + :class class + :chain-head chain-head + :target-head target-head)) + +;;; vtable + +(defmethod print-object ((vtable vtable) stream) + (print-unreadable-object (vtable stream :type t) + (format stream "~A:~A ~_~:<~@{~S~^ ~_~}~:>" + (vtable-class vtable) + (sod-class-nickname (vtable-chain-head vtable)) + (vtable-body vtable)))) + +;; Special variables used by `compute-vtable'. +(defvar *done-metaclass-chains*) +(defvar *done-instance-chains*) + +(defmethod compute-vtable-items + ((class sod-class) (super sod-class) (chain-head sod-class) + (chain-tail sod-class) (emit function)) + + ;; If this class introduces new metaclass chains, then emit pointers to + ;; them. + (let* ((metasuper (sod-class-metaclass super)) + (metasuper-chains (sod-class-chains metasuper)) + (metasuper-chain-heads (mapcar (lambda (chain) + (sod-class-chain-head (car chain))) + metasuper-chains))) + (dolist (metasuper-chain-head metasuper-chain-heads) + (unless (member metasuper-chain-head *done-metaclass-chains*) + (funcall emit (make-class-pointer class + chain-head + metasuper + metasuper-chain-head)) + (push metasuper-chain-head *done-metaclass-chains*)))) + + ;; If there are new instance chains, then emit offsets to them. + (let* ((chains (sod-class-chains super)) + (chain-heads (mapcar (lambda (chain) + (sod-class-chain-head (car chain))) + chains))) + (dolist (head chain-heads) + (unless (member head *done-instance-chains*) + (funcall emit (make-chain-offset class chain-head head)) + (push head *done-instance-chains*)))) + + ;; Finally, if there are interesting methods, emit those too. + (when (sod-class-messages super) + (funcall emit (compute-vtmsgs super class chain-head chain-tail)))) + +(defmethod compute-vtable ((class sod-class) (chain list)) + (let* ((chain-head (car chain)) + (chain-tail (find chain-head (mapcar #'car (sod-class-chains class)) + :key #'sod-class-chain-head)) + (*done-metaclass-chains* nil) + (*done-instance-chains* (list chain-head)) + (done-superclasses nil) + (items nil)) + (flet ((emit (item) + (push item items))) + + ;; Find the root chain in the metaclass and write a pointer. + (let* ((metaclass (sod-class-metaclass class)) + (metaclass-root (find-root-metaclass class)) + (metaclass-root-head (sod-class-chain-head metaclass-root))) + (emit (make-class-pointer class chain-head metaclass + metaclass-root-head)) + (push metaclass-root-head *done-metaclass-chains*)) + + ;; Write an offset to the instance base. + (emit (make-base-offset class chain-head)) + + ;; Now walk the chain. As we ascend the chain, scan the class + ;; precedence list of each class in reverse to ensure that we have + ;; everything interesting. + (dolist (super chain) + (dolist (sub (reverse (sod-class-precedence-list super))) + (unless (member sub done-superclasses) + (compute-vtable-items class + sub + chain-head + chain-tail + #'emit) + (push sub done-superclasses)))) + + ;; We're through. + (make-instance 'vtable + :class class + :chain-head chain-head + :chain-tail chain-tail + :body (nreverse items))))) + +(defmethod compute-vtables ((class sod-class)) + (mapcar (lambda (chain) + (compute-vtable class (reverse chain))) + (sod-class-chains class))) + +(defmethod slot-unbound + (clos-class (class sod-class) (slot-name (eql 'vtables))) + (setf (slot-value class 'vtables) + (compute-vtables class))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-class-make.lisp b/src/impl-class-make.lisp new file mode 100644 index 0000000..4470416 --- /dev/null +++ b/src/impl-class-make.lisp @@ -0,0 +1,240 @@ +;;; -*-lisp-*- +;;; +;;; Class construction protocol implementation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Classes. + +(defmethod guess-metaclass ((class sod-class)) + "Default metaclass-guessing function for classes. + + Return the most specific metaclass of any of the CLASS's direct + superclasses." + (do ((supers (sod-class-direct-superclasses class) (cdr supers)) + (meta nil (let ((candidate (sod-class-metaclass (car supers)))) + (cond ((null meta) candidate) + ((sod-subclass-p meta candidate) meta) + ((sod-subclass-p candidate meta) candidate) + (t (error "Unable to choose metaclass for `~A'" + class)))))) + ((endp supers) meta))) + +(defmethod shared-initialize :after ((class sod-class) slot-names &key pset) + "Specific behaviour for SOD class initialization. + + Properties inspected are as follows: + + * `:metaclass' names the metaclass to use. If unspecified, nil is + stored, and (unless you intervene later) `guess-metaclass' will be + called by `finalize-sod-class' to find a suitable default. + + * `:nick' provides a nickname for the class. If unspecified, a default + (the class's name, forced to lowercase) will be chosen in + `finalize-sod-class'. + + * `:link' names the chained superclass. If unspecified, this class will + be left at the head of its chain." + + ;; If no nickname, copy the class name. It won't be pretty, though. + (default-slot-from-property (class 'nickname slot-names) + (pset :nick :id) + (string-downcase (slot-value class 'name))) + + ;; If no metaclass, guess one in a (Lisp) class-specific way. + (default-slot-from-property (class 'metaclass slot-names) + (pset :metaclass :id meta (find-sod-class meta)) + (guess-metaclass class)) + + ;; If no chain-link, then start a new chain here. + (default-slot-from-property (class 'chain-link slot-names) + (pset :link :id link (find-sod-class link)) + nil)) + +;;;-------------------------------------------------------------------------- +;;; Slots. + +(defmethod make-sod-slot + ((class sod-class) name type pset &optional location) + (with-default-error-location (location) + (let ((slot (make-instance (get-property pset :lisp-class :symbol + 'sod-slot) + :class class + :name name + :type type + :location (file-location location) + :pset pset))) + (with-slots (slots) class + (setf slots (append slots (list slot)))) + (check-unused-properties pset)))) + +(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) + "This method does nothing. + + It only exists so that it isn't an error to provide a `:pset' initarg + to (make-instance 'sod-slot ...)." + + (declare (ignore slot-names pset))) + +;;;-------------------------------------------------------------------------- +;;; Slot initializers. + +(defmethod make-sod-instance-initializer + ((class sod-class) nick name value-kind value-form pset + &optional location) + (with-default-error-location (location) + (let* ((slot (find-instance-slot-by-name class nick name)) + (initializer (make-sod-initializer-using-slot + class slot 'sod-instance-initializer + value-kind value-form pset + (file-location location)))) + (with-slots (instance-initializers) class + (setf instance-initializers + (append instance-initializers (list initializer)))) + (check-unused-properties pset)))) + +(defmethod make-sod-class-initializer + ((class sod-class) nick name value-kind value-form pset + &optional location) + (with-default-error-location (location) + (let* ((slot (find-class-slot-by-name class nick name)) + (initializer (make-sod-initializer-using-slot + class slot 'sod-class-initializer + value-kind value-form pset + (file-location location)))) + (with-slots (class-initializers) class + (setf class-initializers + (append class-initializers (list initializer)))) + (check-unused-properties pset)))) + +(defmethod make-sod-initializer-using-slot + ((class sod-class) (slot sod-slot) + init-class value-kind value-form pset location) + (make-instance (get-property pset :lisp-class :symbol init-class) + :class class + :slot slot + :value-kind value-kind + :value-form value-form + :location location + :pset pset)) + +(defmethod shared-initialize :after + ((init sod-initializer) slot-names &key pset) + "This method does nothing. + + It only exists so that it isn't an error to provide a `:pset' initarg + to (make-instance 'sod-initializer ...)." + (declare (ignore slot-names pset)) + nil) + +;;;-------------------------------------------------------------------------- +;;; Messages. + +(defmethod make-sod-message + ((class sod-class) name type pset &optional location) + (with-default-error-location (location) + (let ((message (make-instance (get-property pset :lisp-class :symbol + 'standard-message) + :class class + :name name + :type type + :location (file-location location) + :pset pset))) + (with-slots (messages) class + (setf messages (append messages (list message)))) + (check-unused-properties pset)))) + +(defmethod shared-initialize :after + ((message sod-message) slot-names &key pset) + (declare (ignore slot-names pset)) + (with-slots (type) message + (check-message-type message type))) + +(defmethod check-message-type ((message sod-message) (type c-function-type)) + nil) + +(defmethod check-message-type ((message sod-message) (type c-type)) + (error "Messages must have function type, not ~A" type)) + +;;;-------------------------------------------------------------------------- +;;; Methods. + +(defmethod make-sod-method + ((class sod-class) nick name type body pset &optional location) + (with-default-error-location (location) + (let* ((message (find-message-by-name class nick name)) + (method (make-sod-method-using-message message class + type body pset + (file-location location)))) + (with-slots (methods) class + (setf methods (append methods (list method))))) + (check-unused-properties pset))) + +(defmethod make-sod-method-using-message + ((message sod-message) (class sod-class) type body pset location) + (make-instance (or (get-property pset :lisp-class :symbol) + (sod-message-method-class message class pset)) + :message message + :class class + :type type + :body body + :location location + :pset pset)) + +(defmethod sod-message-method-class + ((message sod-message) (class sod-class) pset) + (declare (ignore pset)) + 'sod-method) + +(defmethod shared-initialize :after + ((method sod-method) slot-names &key pset) + (declare (ignore slot-names pset)) + + ;; Check that the arguments are named if we have a method body. + (with-slots (body type) method + (unless (or (not body) + (every #'argument-name (c-function-arguments type))) + (error "Abstract declarators not permitted in method definitions"))) + + ;; Check the method type. + (with-slots (message type) method + (check-method-type method message type))) + +(defmethod check-method-type + ((method sod-method) (message sod-message) (type c-type)) + (error "Methods must have function type, not ~A" type)) + +(defmethod check-method-type + ((method sod-method) (message sod-message) (type c-function-type)) + (with-slots ((msgtype type)) message + (unless (c-type-equal-p (c-type-subtype msgtype) + (c-type-subtype type)) + (error "Method return type ~A doesn't match message ~A" + (c-type-subtype msgtype) (c-type-subtype type))) + (unless (argument-lists-compatible-p (c-function-arguments msgtype) + (c-function-arguments type)) + (error "Method arguments ~A don't match message ~A" type msgtype)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-codegen.lisp b/src/impl-codegen.lisp new file mode 100644 index 0000000..25413f8 --- /dev/null +++ b/src/impl-codegen.lisp @@ -0,0 +1,199 @@ +;;; -*-lisp-*- +;;; +;;; Code generation protocol implementation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Temporary names. + +(export '(temporary-argument temporary-function)) +(defclass temporary-argument (temporary-name) ()) +(defclass temporary-function (temporary-name) ()) + +(export 'temporary-variable) +(defclass temporary-variable (temporary-name) + ((in-use-p :initarg :in-use-p :initform nil + :type boolean :accessor var-in-use-p))) + +(defmethod commentify-argument-name ((name temporary-name)) + nil) + +(export 'temporary-function) +(defun temporary-function () + "Return a temporary function name." + (make-instance 'temporary-function + :tag (prog1 *temporary-index* (incf *temporary-index*)))) + +(defmethod format-temporary-name ((var temporary-name) stream) + (format stream "~A" (temp-tag var))) +(defmethod format-temporary-name ((var temporary-argument) stream) + (format stream "sod__a~A" (temp-tag var))) +(defmethod format-temporary-name ((var temporary-variable) stream) + (format stream "sod__v~A" (temp-tag var))) +(defmethod format-temporary-name ((var temporary-function) stream) + (format stream "sod__f~A" (temp-tag var))) + +(defmethod print-object ((var temporary-name) stream) + (if *print-escape* + (print-unreadable-object (var stream :type t) + (prin1 (temp-tag var) stream)) + (format-temporary-name var stream))) + +;;;-------------------------------------------------------------------------- +;;; Instruction types. + +;; Compound statements. + +(export '(if-inst make-if-inst + while-inst make-while-inst + do-inst make-do-inst + inst-condition inst-consequent inst-alternative inst-body)) + +(definst if (stream) (condition consequent alternative) + (format-compound-statement (stream consequent alternative) + (format stream "if (~A)" condition)) + (when alternative + (format-compound-statement (stream alternative) + (write-string "else" stream)))) + +(definst while (stream) (condition body) + (format-compound-statement (stream body) + (format stream "while (~A)" condition))) + +(definst do-while (stream) (body condition) + (format-compound-statement (stream body :space) + (write-string "do" stream)) + (format stream "while (~A);" condition)) + +;; Special varargs hacks. + +(export '(va-start-inst make-va-start-inst + va-copy-inst make-va-copy-inst + va-end-inst make-va-end-inst + inst-ap inst-arg inst-to inst-from)) + +(definst va-start (stream) (ap arg) + (format stream "va_start(~@<~A, ~_~A~:>);" ap arg)) + +(definst va-copy (stream) (to from) + (format stream "va_copy(~@<~A, ~_~A~:>);" to from)) + +(definst va-end (stream) (ap) + (format stream "va_end(~A);" ap)) + +;; Expressions. + +(export '(call-inst make-call-inst inst-func inst-args)) + +(definst call (stream) (func args) + (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args)) + +;;;-------------------------------------------------------------------------- +;;; Code generator objects. + +(defclass basic-codegen () + ((vars :initarg :vars :initform nil :type list :accessor codegen-vars) + (insts :initarg :insts :initform nil :type list :accessor codegen-insts) + (temp-index :initarg :temp-index :initform 0 + :type fixnum :accessor codegen-temp-index)) + (:documentation + "Base class for code generator state. + + This contains the bare essentials for supporting the EMIT-INST and + ENSURE-VAR protocols; see the documentation for those generic functions + for more details. + + This class isn't abstract. A full CODEGEN object uses instances of this + to keep track of pending functions which haven't been completed yet. + + Just in case that wasn't clear enough: this is nothing to do with the + BASIC language.")) + +(defmethod emit-inst ((codegen basic-codegen) inst) + (push inst (codegen-insts codegen))) + +(defmethod emit-insts ((codegen basic-codegen) insts) + (asetf (codegen-insts codegen) (revappend insts it))) + +(defmethod ensure-var ((codegen basic-codegen) name type &optional init) + (let* ((vars (codegen-vars codegen)) + (var (find name vars :key #'inst-name :test #'equal))) + (cond ((not var) + (setf (codegen-vars codegen) + (cons (make-var-inst name type init) vars))) + ((not (c-type-equal-p type (inst-type var))) + (error "(Internal) Redefining type for variable ~A." name))) + name)) + +(export 'codegen) +(defclass codegen (basic-codegen) + ((functions :initform nil :type list :accessor codegen-functions) + (stack :initform nil :type list :accessor codegen-stack)) + (:documentation + "A full-fat code generator which can generate and track functions. + + This is the real deal. Subclasses may which to attach additional state + for convenience's sake, but this class is self-contained. It supports the + CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols.")) + +(defmethod codegen-push ((codegen codegen)) + (with-slots (vars insts temp-index stack) codegen + (push (make-instance 'basic-codegen + :vars vars + :insts insts + :temp-index temp-index) + stack) + (setf vars nil insts nil temp-index 0))) + +(defmethod codegen-pop ((codegen codegen)) + (with-slots (vars insts temp-index stack) codegen + (multiple-value-prog1 + (values (nreverse vars) (nreverse insts)) + (let ((sub (pop stack))) + (setf vars (codegen-vars sub) + insts (codegen-insts sub) + temp-index (codegen-temp-index sub)))))) + +(defmethod codegen-add-function ((codegen codegen) function) + (with-slots (functions) codegen + (setf functions (nconc functions (list function))))) + +(defmethod temporary-var ((codegen basic-codegen) type) + (with-slots (vars temp-index) codegen + (or (some (lambda (var) + (let ((name (inst-name var))) + (if (and (not (var-in-use-p name)) + (c-type-equal-p type (inst-type var))) + name + nil))) + vars) + (let* ((name (make-instance 'temporary-variable + :in-use-p t + :tag (prog1 temp-index + (incf temp-index))))) + (push (make-var-inst name type nil) vars) + name)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-lexer.lisp b/src/impl-lexer.lisp new file mode 100644 index 0000000..9f9d31e --- /dev/null +++ b/src/impl-lexer.lisp @@ -0,0 +1,297 @@ +;;; -*-lisp-*- +;;; +;;; Implementation of lexical analysis protocol. +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Basic lexical analyser. + +(defstruct (pushed-token + (:constructor make-pushed-token (type value location))) + "A token that has been pushed back into a lexer for later processing." + type value location) + +;;; Class definition. + +(export 'basic-lexer) +(defclass basic-lexer () + ((stream :initarg :stream :type stream :reader lexer-stream) + (char :initform nil :type (or character null) :reader lexer-char) + (pushback-chars :initform nil :type list) + (token-type :initform nil :accessor token-type) + (token-value :initform nil :accessor token-value) + (location :initform nil :reader file-location) + (pushback-tokens :initform nil :type list)) + (:documentation + "Base class for lexical analysers. + + The lexer reads characters from STREAM, which, for best results, wants to + be a POSITION-AWARE-INPUT-STREAM. + + The lexer provides one-character lookahead by default: the current + lookahead character is available to subclasses in the slot CHAR. Before + beginning lexical analysis, the lookahead character needs to be + established with NEXT-CHAR. If one-character lookahead is insufficient, + the analyser can push back an arbitrary number of characters using + PUSHBACK-CHAR. + + The NEXT-TOKEN function scans and returns the next token from the STREAM, + and makes it available as TOKEN-TYPE and TOKEN-VALUE, providing one-token + lookahead. A parser using the lexical analyser can push back tokens using + PUSHBACK-TOKENS. + + For convenience, the lexer implements a FILE-LOCATION method (delegated to + the underlying stream).")) + +;;; Reading and pushing back characters. + +(defmethod next-char ((lexer basic-lexer)) + (with-slots (stream char pushback-chars) lexer + (setf char (if pushback-chars + (pop pushback-chars) + (read-char stream nil))))) + +(defmethod pushback-char ((lexer basic-lexer) new-char) + (with-slots (char pushback-chars) lexer + (push char pushback-chars) + (setf char new-char))) + +(defmethod fixup-stream* ((lexer basic-lexer) thunk) + (with-slots (stream char pushback-chars) lexer + (when pushback-chars + (error "Lexer has pushed-back characters.")) + (when (slot-boundp lexer 'char) + (unread-char char stream)) + (unwind-protect + (funcall thunk stream) + (setf char (read-char stream nil))))) + +;;; Reading and pushing back tokens. + +(defmethod next-token :around ((lexer basic-lexer)) + (unless (slot-boundp lexer 'char) + (next-char lexer))) + +(defmethod next-token ((lexer basic-lexer)) + (with-slots (pushback-tokens token-type token-value location) lexer + (setf (values token-type token-value) + (if pushback-tokens + (let ((pushback (pop pushback-tokens))) + (setf location (pushed-token-location pushback)) + (values (pushed-token-type pushback) + (pushed-token-value pushback))) + (scan-token lexer))))) + +(defmethod scan-token :around ((lexer basic-lexer)) + (with-default-error-location (lexer) + (call-next-method))) + +(defmethod pushback-token ((lexer basic-lexer) new-token-type + &optional new-token-value new-location) + (with-slots (pushback-tokens token-type token-value location) lexer + (push (make-pushed-token token-type token-value location) + pushback-tokens) + (when new-location (setf location new-location)) + (setf token-type new-token-type + token-value new-token-value))) + +;;; Utilities. + +(defmethod skip-spaces ((lexer basic-lexer)) + (do ((ch (lexer-char lexer) (next-char lexer))) + ((not (whitespace-char-p ch)) ch))) + +;;;-------------------------------------------------------------------------- +;;; Our main lexer. + +(export 'sod-lexer) +(defclass sod-lexer (basic-lexer) + () + (:documentation + "Lexical analyser for the SOD lanuage. + + See the LEXER class for the gory details about the lexer protocol.")) + +(defmethod scan-token ((lexer sod-lexer)) + (with-slots (stream char keywords location) lexer + (prog (ch) + + consider + + ;; Stash the position of this token so that we can report it later. + (setf ch (skip-spaces lexer) + location (file-location stream)) + + ;; Now work out what it is that we're dealing with. + (cond + + ;; End-of-file brings its own peculiar joy. + ((null ch) (return (values :eof t))) + + ;; Strings. + ((or (char= ch #\") (char= ch #\')) + (let* ((quote ch) + (string + (with-output-to-string (out) + (loop + (flet ((getch () + (setf ch (next-char lexer)) + (when (null ch) + (cerror* "Unexpected end of file in ~ + ~:[string~;character~] constant" + (char= quote #\')) + (return)))) + (getch) + (cond ((char= ch quote) (return)) + ((char= ch #\\) (getch))) + (write-char ch out)))))) + (setf ch (next-char lexer)) + (ecase quote + (#\" (return (values :string string))) + (#\' (case (length string) + (0 (cerror* "Empty character constant") + (return (values :char #\?))) + (1 (return (values :char (char string 0)))) + (t (cerror* "Multiple characters in character constant") + (return (values :char (char string 0))))))))) + + ;; Pick out identifiers and keywords. + ((or (alpha-char-p ch) (char= ch #\_)) + + ;; Scan a sequence of alphanumerics and underscores. We could + ;; allow more interesting identifiers, but it would damage our C + ;; lexical compatibility. + (let ((id (with-output-to-string (out) + (loop + (write-char ch out) + (setf ch (next-char lexer)) + (when (or (null ch) + (not (or (alphanumericp ch) + (char= ch #\_)))) + (return)))))) + + ;; Done. + (return (values :id id)))) + + ;; Pick out numbers. Currently only integers, but we support + ;; multiple bases. + ((digit-char-p ch) + + ;; Sort out the prefix. If we're looking at `0b', `0o' or `0x' + ;; (maybe uppercase) then we've got a funny radix to deal with. + ;; Otherwise, a leading zero signifies octal (daft, I know), else + ;; we're left with decimal. + (multiple-value-bind (radix skip-char) + (if (char/= ch #\0) + (values 10 nil) + (case (and (setf ch (next-char lexer)) + (char-downcase ch)) + (#\b (values 2 t)) + (#\o (values 8 t)) + (#\x (values 16 t)) + (t (values 8 nil)))) + + ;; If we last munched an interesting letter, we need to skip over + ;; it. That's what the SKIP-CHAR flag is for. + ;; + ;; Danger, Will Robinson! If we're just about to eat a radix + ;; letter, then the next thing must be a digit. For example, + ;; `0xfatenning' parses as a hex number followed by an identifier + ;; `0xfa ttening', but `0xturning' is an octal number followed by + ;; an identifier `0 xturning'. + (when skip-char + (let ((peek (next-char lexer))) + (unless (digit-char-p peek radix) + (pushback-char lexer ch) + (return-from scan-token (values :integer 0))) + (setf ch peek))) + + ;; Scan an integer. While there are digits, feed them into the + ;; accumulator. + (do ((accum 0 (+ (* accum radix) digit)) + (digit (and ch (digit-char-p ch radix)) + (and ch (digit-char-p ch radix)))) + ((null digit) (return-from scan-token + (values :integer accum))) + (setf ch (next-char lexer))))) + + ;; A slash might be the start of a comment. + ((char= ch #\/) + (setf ch (next-char lexer)) + (case ch + + ;; Comment up to the end of the line. + (#\/ + (loop + (setf ch (next-char lexer)) + (when (or (null ch) (char= ch #\newline)) + (go scan)))) + + ;; Comment up to the next `*/'. + (#\* + (tagbody + top + (case (setf ch (next-char lexer)) + (#\* (go star)) + ((nil) (go done)) + (t (go top))) + star + (case (setf ch (next-char lexer)) + (#\* (go star)) + (#\/ (setf ch (next-char lexer)) + (go done)) + ((nil) (go done)) + (t (go top))) + done) + (go consider)) + + ;; False alarm. (The next character is already set up.) + (t + (return (values #\/ t))))) + + ;; A dot: might be `...'. Tread carefully! We need more lookahead + ;; than is good for us. + ((char= ch #\.) + (setf ch (next-char lexer)) + (cond ((eql ch #\.) + (setf ch (next-char lexer)) + (cond ((eql ch #\.) (return (values :ellipsis nil))) + (t (pushback-char lexer #\.) + (return (values #\. t))))) + (t + (return (values #\. t))))) + + ;; Anything else is a lone delimiter. + (t + (return (multiple-value-prog1 + (values ch t) + (next-char lexer))))) + + scan + ;; Scan a new character and try again. + (setf ch (next-char lexer)) + (go consider)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/methods.lisp b/src/impl-method.lisp similarity index 53% rename from methods.lisp rename to src/impl-method.lisp index b54887a..a1e2a65 100644 --- a/methods.lisp +++ b/src/impl-method.lisp @@ -1,13 +1,13 @@ ;;; -*-lisp-*- ;;; -;;; Infrastructure for effective method generation +;;; Method combination implementation ;;; ;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Simple Object Definition system. +;;; This file is part of the Sensble 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 @@ -26,55 +26,9 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- -;;; Function type protocol. - -(defgeneric sod-message-argument-tail (message) - (:documentation - "Return the argument tail for the message, with invented argument names. - - No `me' argument is prepended; any :ELLIPSIS is left as it is.")) - -(defgeneric sod-message-no-varargs-tail (message) - (:documentation - "Return the argument tail for the message with :ELLIPSIS substituted. - - As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended. - However, an :ELLIPSIS is replaced by an argument of type `va_list', named - `sod__ap'.")) - -(defgeneric sod-method-function-type (method) - (:documentation - "Return the C function type for the direct method. - - This is called during initialization of a direct method object, and the - result is cached. - - A default method is provided (by BASIC-DIRECT-METHOD) which simply - prepends an appropriate `me' argument to the user-provided argument list. - Fancy method classes may need to override this behaviour.")) - -(defgeneric sod-method-next-method-type (method) - (:documentation - "Return the C function type for the next-method trampoline. - - This is called during initialization of a direct method object, and the - result is cached. It should return a function type, not a pointer type. - - A default method is provided (by DELEGATING-DIRECT-METHOD) which should do - the right job. Very fancy subclasses might need to do something - different.")) - -(defgeneric sod-method-function-name (method) - (:documentation - "Return the C function name for the direct method.")) - -(defgeneric method-entry-function-type (entry) - (:documentation - "Return the C function type for a method entry.")) - -;;;-------------------------------------------------------------------------- ;;; Message classes. +(export 'basic-message) (defclass basic-message (sod-message) ((argument-tail :type list :reader sod-message-argument-tail) (no-varargs-tail :type list :reader sod-message-no-varargs-tail)) @@ -85,34 +39,32 @@ This is a separate class so that `special effect' messages can avoid inheriting its default behaviour. - The function type protocol is implemented on BASIC-MESSAGE using slot + The function type protocol is implemented on `basic-message' using slot reader methods. The actual values are computed on demand in methods - defined on SLOT-UNBOUND.")) - -;;; Function type protocol. + defined on `slot-unbound'.")) (defmethod slot-unbound (class (message basic-message) (slot-name (eql 'argument-tail))) (let ((seq 0)) - (mapcar (lambda (arg) - (if (or (eq arg :ellipsis) (argument-name arg)) - arg - (make-argument (make-instance 'temporary-argument - :tag (prog1 seq (incf seq))) - (argument-type arg)))) - (c-function-arguments (sod-message-type message))))) + (setf (slot-value message 'argument-tail) + (mapcar (lambda (arg) + (if (or (eq arg :ellipsis) (argument-name arg)) arg + (make-argument (make-instance 'temporary-argument + :tag (prog1 seq + (incf seq))) + (argument-type arg)))) + (c-function-arguments (sod-message-type message)))))) (defmethod slot-unbound (class (message basic-message) (slot-name (eql 'no-varargs-tail))) - (mapcar (lambda (arg) - (if (eq arg :ellipsis) - (make-argument *sod-ap* (c-type va-list)) - arg)) - (sod-message-argument-tail message))) - -;;; Method class selection. + (setf (slot-value message 'no-varargs-tail) + (mapcar (lambda (arg) + (if (eq arg :ellipsis) + (make-argument *sod-ap* (c-type va-list)) + arg)) + (sod-message-argument-tail message)))) (defmethod sod-message-method-class ((message basic-message) (class sod-class) pset) @@ -123,18 +75,31 @@ ((nil) (error "How odd: a primary method slipped through the net")) (t (error "Unknown method role ~A" role))))) -;;; Utility functions. +(export 'simple-message) +(defclass simple-message (basic-message) + () + (:documentation + "Base class for messages with `simple' method combinations. -(defun varargs-message-p (message) - "Answer whether the MESSAGE accepts a variable-length argument list. + A simple method combination is one which has only one method role other + than the `before', `after' and `around' methods provided by BASIC-MESSAGE. + We call these `primary' methods, and the programmer designates them by not + specifying an explicit role. - We need to jump through some extra hoops in order to cope with varargs - messages, so this is useful to know." - (member :ellipsis (sod-message-argument-tail message))) + If the programmer doesn't define any primary methods then the effective + method is null -- i.e., the method entry pointer shows up as a null + pointer.")) + +(defmethod sod-message-method-class + ((message simple-message) (class sod-class) pset) + (if (get-property pset :role :keyword nil) + (call-next-method) + (primary-method-class message))) ;;;-------------------------------------------------------------------------- ;;; Direct method classes. +(export 'basic-direct-method) (defclass basic-direct-method (sod-method) ((role :initarg :role :type symbol :reader sod-method-role) (function-type :type c-function-type :reader sod-method-function-type)) @@ -146,12 +111,12 @@ inheriting its default behaviour and slots. A basic method can be assigned a `role', which may be set either as an - initarg or using the :ROLE property. Roles are used for method + initarg or using the `:role' property. Roles are used for method categorization. - The function type protocol is implemented on BASIC-DIRECT-METHOD using + The function type protocol is implemented on `basic-direct-method' using slot reader methods. The actual values are computed on demand in methods - defined on SLOT-UNBOUND.")) + defined on `slot-unbound'.")) (defmethod shared-initialize :after ((method basic-direct-method) slot-names &key pset) @@ -172,6 +137,7 @@ (sod-class-nickname (sod-message-class message)) (sod-message-name message)))) +(export 'daemon-direct-method) (defclass daemon-direct-method (basic-direct-method) () (:documentation @@ -184,10 +150,9 @@ In C terms, a daemon method must return `void', and is not passed a `next_method' pointer.")) -(defmethod check-method-type - ((method daemon-direct-method) - (message sod-message) - (type c-function-type)) +(defmethod check-method-type ((method daemon-direct-method) + (message sod-message) + (type c-function-type)) (with-slots ((msgtype type)) message (unless (c-type-equal-p (c-type-subtype type) (c-type void)) (error "Method return type ~A must be `void'" (c-type-subtype type))) @@ -195,6 +160,7 @@ (c-function-arguments type)) (error "Method arguments ~A don't match message ~A" type msgtype)))) +(export 'delegating-direct-method) (defclass delegating-direct-method (basic-direct-method) ((next-method-type :type c-function-type :reader sod-method-next-method-type)) @@ -246,16 +212,7 @@ ;;;-------------------------------------------------------------------------- ;;; Effective method classes. -(defgeneric effective-method-basic-argument-names (method) - (:documentation - "Return a list of argument names to be passed to direct methods. - - The argument names are constructed from the message's arguments returned - by SOD-MESSAGE-NO-VARARGS-TAIL. The basic arguments are the ones - immediately derived from the programmer's explicitly stated arguments; the - `me' argument is not included, and neither are more exotic arguments added - as part of the method delegation protocol.")) - +(export 'basic-effective-method) (defclass basic-effective-method (effective-method) ((around-methods :initarg :around-methods :initform nil :type list :reader effective-method-around-methods) @@ -273,9 +230,9 @@ `around' methods and provides behaviour for invoking these methods correctly. - The argument names protocol is implemented on BASIC-EFFECTIVE-METHOD using - a slot reader method. The actual values are computed on demand in methods - defined on SLOT-UNBOUND.")) + The argument names protocol is implemented on `basic-effective-method' + using a slot reader method. The actual values are computed on demand in + methods defined on `slot-unbound'.")) (defmethod slot-unbound (class (method basic-effective-method) @@ -286,67 +243,44 @@ (mapcar #'argument-name (sod-message-no-varargs-tail message)))))) -;;;-------------------------------------------------------------------------- -;;; Method categorization. - -(defmacro categorize ((itemvar items &key bind) categories &body body) - "Categorize ITEMS into lists and invoke BODY. - - The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR - will contain the current item. The BIND argument is a list of LET*-like - clauses. The CATEGORIES are a list of clauses of the form (SYMBOL - PREDICATE). - - The behaviour of the macro is as follows. ITEMVAR is assigned (not - bound), in turn, each item in the list ITEMS. The PREDICATEs in the - CATEGORIES list are evaluated in turn, in an environment containing - ITEMVAR and the BINDings, until one of them evaluates to a non-nil value. - At this point, the item is assigned to the category named by the - corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an - error is signalled; a PREDICATE consisting only of T will (of course) - match anything; it is detected specially so as to avoid compiler warnings. - - Once all of the ITEMS have been categorized in this fashion, the BODY is - evaluated as an implicit PROGN. For each SYMBOL naming a category, a - variable named after that symbol will be bound in the BODY's environment - to a list of the items in that category, in the same order in which they - were found in the list ITEMS. The final values of the macro are the final - values of the BODY." - - (let* ((cat-names (mapcar #'car categories)) - (cat-match-forms (mapcar #'cadr categories)) - (cat-vars (mapcar (lambda (name) (gensym (symbol-name name))) - cat-names)) - (items-var (gensym "ITEMS"))) - `(let ((,items-var ,items) - ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) - (dolist (,itemvar ,items-var) - (let* ,bind - (cond ,@(mapcar (lambda (cat-match-form cat-var) - `(,cat-match-form - (push ,itemvar ,cat-var))) - cat-match-forms cat-vars) - ,@(and (not (member t cat-match-forms)) - `((t (error "Failed to categorize ~A" ,itemvar))))))) - (let ,(mapcar (lambda (name var) - `(,name (nreverse ,var))) - cat-names cat-vars) - ,@body)))) +(defmethod effective-method-function-name ((method effective-method)) + (let* ((class (effective-method-class method)) + (message (effective-method-message method)) + (message-class (sod-message-class message))) + (format nil "~A__emethod_~A__~A" + class + (sod-class-nickname message-class) + (sod-message-name message)))) -;;;-------------------------------------------------------------------------- -;;; Code generation. +(defmethod slot-unbound + (class (method basic-effective-method) (slot-name (eql 'functions))) + (setf (slot-value method 'functions) + (compute-method-entry-functions method))) -(defclass method-codegen (codegen) - ((message :initarg :message :type sod-message :reader codegen-message) - (class :initarg :class :type sod-class :reader codegen-class) - (method :initarg :method :type effective-method :reader codegen-method) - (target :initarg :target :reader codegen-target)) +(export 'simple-effective-method) +(defclass simple-effective-method (basic-effective-method) + ((primary-methods :initarg :primary-methods :initform nil + :type list :reader effective-method-primary-methods)) (:documentation - "Augments CODEGEN with additional state regarding an effective method. + "Effective method counterpart to `simple-message'.")) - We store the effective method, and also its target class and owning - message, so that these values are readily available to the code-generating - functions.")) +(defmethod shared-initialize :after + ((method simple-effective-method) slot-names &key direct-methods) + (declare (ignore slot-names)) + (categorize (method direct-methods :bind ((role (sod-method-role method)))) + ((primary (null role)) + (before (eq role :before)) + (after (eq role :after)) + (around (eq role :around))) + (with-slots (primary-methods before-methods after-methods around-methods) + method + (setf primary-methods primary + before-methods before + after-methods (reverse after) + around-methods around)))) + +;;;-------------------------------------------------------------------------- +;;; Code generation. (defmethod shared-initialize :after ((codegen method-codegen) slot-names &key) @@ -356,141 +290,10 @@ :void :return)))) -(defgeneric compute-effective-method-body (method codegen target) - (:documentation - "Generates the body of an effective method. - - Writes the function body to the code generator. It can (obviously) - generate auxiliary functions if it needs to. - - The arguments are as specified by the SOD-MESSAGE-NO-VARARGS-TAIL, with an - additional argument `sod__obj' of type pointer-to-ilayout. The code - should deliver the result (if any) to the TARGET.")) - -(defun invoke-method (codegen target arguments-tail direct-method) - "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL. - - The code is generated in the context of CODEGEN, which can be any instance - of the CODEGEN class -- it needn't be an instance of METHOD-CODEGEN. The - DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of argument - expressions), preceded by a `me' argument of type pointer-to-CLASS where - CLASS is the class on which the method was defined. - - If the message accepts a variable-length argument list then a copy of the - prevailing master argument pointer is provided in place of the :ELLIPSIS." - - (let* ((message (sod-method-message direct-method)) - (class (sod-method-class direct-method)) - (function (sod-method-function-name direct-method)) - (arguments (cons (format nil "&sod__obj.~A.~A" - (sod-class-nickname - (sod-class-chain-head class)) - (sod-class-nickname class)) - arguments-tail))) - (if (varargs-message-p message) - (convert-stmts codegen target - (c-type-subtype (sod-method-type direct-method)) - (lambda (var) - (ensure-var codegen *sod-ap* (c-type va-list)) - (emit-inst codegen - (make-va-copy-inst *sod-ap* - *sod-master-ap*)) - (deliver-expr codegen var - (make-call-inst function arguments)) - (emit-inst codegen - (make-va-end-inst *sod-ap*)))) - (deliver-expr codegen target (make-call-inst function arguments))))) - -(definst convert-to-ilayout (stream) (class chain-head expr) - (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" - class (sod-class-nickname chain-head) expr)) - -(defun ensure-ilayout-var (codegen super) - "Define a variable `sod__obj' pointing to the class's ilayout structure. - - CODEGEN is a METHOD-CODEGEN. The class in question is CODEGEN's class, - i.e., the target class for the effective method. SUPER is one of the - class's superclasses; it is assumed that `me' is a pointer to a SUPER - (i.e., to SUPER's ichain within the ilayout)." - - (let* ((class (codegen-class codegen)) - (super-head (sod-class-chain-head super))) - (ensure-var codegen "sod__obj" - (c-type (* (struct (ilayout-struct-tag class)))) - (make-convert-to-ilayout-inst class super-head "me")))) - -(defun make-trampoline (codegen super body) - "Construct a trampoline function and return its name. - - CODEGEN is a METHOD-CODEGEN. SUPER is a superclass of the CODEGEN class. - We construct a new trampoline function (with an unimaginative name) - suitable for being passed to a direct method defined on SUPER as its - `next_method'. In particular, it will have a `me' argument whose type is - pointer-to-SUPER. - - The code of the function is generated by BODY, which will be invoked with - a single argument which is the TARGET to which it should deliver its - result. - - The return value is the name of the generated function." - - (let* ((message (codegen-message codegen)) - (message-type (sod-message-type message)) - (return-type (c-type-subtype message-type)) - (arguments (mapcar (lambda (arg) - (if (eq (argument-name arg) *sod-ap*) - (make-argument *sod-master-ap* - (c-type va-list)) - arg)) - (sod-message-no-varargs-tail message)))) - (codegen-push codegen) - (ensure-ilayout-var codegen super) - (funcall body (codegen-target codegen)) - (codegen-pop-function codegen (temporary-function) - (c-type (fun (lisp return-type) - ("me" (* (class super))) - . arguments))))) - -(defun invoke-delegation-chain (codegen target basic-tail chain kernel) - "Invoke a chain of delegating methods. - - CODEGEN is a METHOD-CODEGEN. BASIC-TAIL is a list of argument expressions - to provide to the methods. The result of the delegation chain will be - delivered to TARGET. - - The CHAIN is a list of DELEGATING-DIRECT-METHOD objects. The behaviour is - as follows. The first method in the chain is invoked with the necessary - arguments (see below) including a `next_method' pointer. If KERNEL is nil - and there are no more methods in the chain then the `next_method' pointer - will be null; otherwise it will point to a `trampoline' function, whose - behaviour is to call the remaining methods on the chain as a delegation - chain. The method may choose to call this function with its arguments. - It will finally return a value, which will be delivered to the TARGET. - - If the chain is empty, then the code generated by KERNEL (given a TARGET - argument) will be invoked. It is an error if both CHAIN and KERNEL are - nil." - - (let* ((message (codegen-message codegen)) - (argument-tail (if (varargs-message-p message) - (cons *sod-master-ap* basic-tail) - basic-tail))) - (labels ((next-trampoline (method chain) - (if (or kernel chain) - (make-trampoline codegen (sod-method-class method) - (lambda (target) - (invoke chain target))) - 0)) - (invoke (chain target) - (if (null chain) - (funcall kernel target) - (let* ((trampoline (next-trampoline (car chain) - (cdr chain)))) - (invoke-method codegen target - (cons trampoline argument-tail) - (car chain)))))) - (invoke chain target)))) +;;;-------------------------------------------------------------------------- +;;; Invoking direct methods. +(export 'basic-effective-method-body) (defun basic-effective-method-body (codegen target method body) "Build the common method-invocation structure. @@ -524,15 +327,7 @@ around-methods #'method-kernel))))) ;;;-------------------------------------------------------------------------- -;;; Effective method entry points. - -(defgeneric compute-method-entry-functions (method) - (:documentation - "Construct method entry functions. - - Builds the effective method function (if there is one) and the necessary - method entries. Returns a list of functions (i.e., FUNCTION-INST objects) - which need to be defined in the generated source code.")) +;;; Method entry points. (defparameter *method-entry-inline-threshold* 200 "Threshold below which effective method bodies are inlined into entries. @@ -543,37 +338,34 @@ fold the method body into the entry functions; otherwise we split the effective method out into its own function.") -(defgeneric effective-method-function-name (method) - (:documentation - "Returns the function name of an effective method.")) - -(defgeneric method-entry-function-name (method chain-head) - (:documentation - "Returns the function name of a method entry. - - The method entry is given as an effective method/chain-head pair, rather - than as a method entry object because we want the function name before - we've made the entry object.")) - -(defmethod effective-method-function-name ((method effective-method)) - (let* ((class (effective-method-class method)) - (message (effective-method-message method)) - (message-class (sod-message-class message))) - (format nil "~A__emethod_~A__~A" - class - (sod-class-nickname message-class) - (sod-message-name message)))) - (defmethod method-entry-function-name ((method effective-method) (chain-head sod-class)) (let* ((class (effective-method-class method)) (message (effective-method-message method)) (message-class (sod-message-class message))) - (format nil "~A__mentry_~A__~A__chain_~A" - class - (sod-class-nickname message-class) - (sod-message-name message) - (sod-class-nickname chain-head)))) + (if (or (not (slot-boundp method 'functions)) + (slot-value method 'functions)) + (format nil "~A__mentry_~A__~A__chain_~A" + class + (sod-class-nickname message-class) + (sod-message-name message) + (sod-class-nickname chain-head)) + 0))) + +(defmethod method-entry-function-type ((entry method-entry)) + (let* ((method (method-entry-effective-method entry)) + (message (effective-method-message method)) + (type (sod-message-type message))) + (c-type (fun (lisp (c-type-subtype type)) + ("me" (* (class (method-entry-chain-tail entry)))) + . (sod-message-argument-tail message))))) + +(defmethod make-method-entry ((method basic-effective-method) + (chain-head sod-class) (chain-tail sod-class)) + (make-instance 'method-entry + :method method + :chain-head chain-head + :chain-tail chain-tail)) (defmethod compute-method-entry-functions ((method basic-effective-method)) @@ -638,25 +430,25 @@ (return prev)))) (entry-target (codegen-target codegen))) - (labels ((setup-entry (tail) - (let ((head (sod-class-chain-head tail))) - (codegen-push codegen) - (ensure-var codegen "sod__obj" ilayout-type - (make-convert-to-ilayout-inst class - head "me")))) - (varargs-prologue () - (ensure-var codegen *sod-master-ap* (c-type va-list)) - (emit-inst codegen - (make-va-start-inst *sod-master-ap* parm-n))) - (varargs-epilogue () - (emit-inst codegen (make-va-end-inst *sod-master-ap*))) - (finish-entry (tail) - (let* ((head (sod-class-chain-head tail)) - (name (method-entry-function-name method head)) - (type (c-type (fun (lisp return-type) - ("me" (* (class tail))) - . entry-args)))) - (codegen-pop-function codegen name type)))) + (flet ((setup-entry (tail) + (let ((head (sod-class-chain-head tail))) + (codegen-push codegen) + (ensure-var codegen "sod__obj" ilayout-type + (make-convert-to-ilayout-inst class + head "me")))) + (varargs-prologue () + (ensure-var codegen *sod-master-ap* (c-type va-list)) + (emit-inst codegen + (make-va-start-inst *sod-master-ap* parm-n))) + (varargs-epilogue () + (emit-inst codegen (make-va-end-inst *sod-master-ap*))) + (finish-entry (tail) + (let* ((head (sod-class-chain-head tail)) + (name (method-entry-function-name method head)) + (type (c-type (fun (lisp return-type) + ("me" (* (class tail))) + . entry-args)))) + (codegen-pop-function codegen name type)))) ;; Generate the method body. We'll work out what to do with it later. (codegen-push codegen) @@ -705,35 +497,50 @@ (codegen-functions codegen)))) -(defmethod slot-unbound - (class (method basic-effective-method) (slot-name (eql 'functions))) - (setf (slot-value method 'functions) - (compute-method-entry-functions method))) +(defmethod compute-method-entry-functions + ((method simple-effective-method)) + (if (effective-method-primary-methods method) + (call-next-method) + nil)) + +(defmethod compute-effective-method-body + ((method simple-effective-method) codegen target) + (with-slots (message basic-argument-names primary-methods) method + (basic-effective-method-body codegen target method + (lambda (target) + (simple-method-body method + codegen + target))))) -(defmethod method-entry-function-type ((entry method-entry)) - (let* ((method (method-entry-effective-method entry)) - (message (effective-method-message method)) - (type (sod-message-type message))) - (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (method-entry-chain-tail entry)))) - . (sod-message-argument-tail message))))) +;;;-------------------------------------------------------------------------- +;;; Standard method combination. -(defmethod make-method-entry ((method basic-effective-method) - (chain-head sod-class) (chain-tail sod-class)) - (make-instance 'method-entry - :method method - :chain-head chain-head - :chain-tail chain-tail)) +(export 'standard-message) +(defclass standard-message (simple-message) + () + (:documentation + "Message class for standard method combination. -;;;-------------------------------------------------------------------------- -;;; Output. - -(defmethod add-output-hooks progn - ((method basic-effective-method) (reason (eql :c)) sequencer) - (with-slots (class functions) method - (sequence-output (stream sequencer) - ((class :effective-methods) - (dolist (func functions) - (write func :stream stream :escape nil :circle nil)))))) + Standard method combination is a simple method combination where the + primary methods are invoked as a delegation chain, from most- to + least-specific.")) + +(export 'standard-effective-method) +(defclass standard-effective-method (simple-effective-method) () + (:documentation "Effective method counterpart to `standard-message'.")) + +(defmethod primary-method-class ((message standard-message)) + 'delegating-direct-method) + +(defmethod message-effective-method-class ((message standard-message)) + 'standard-effective-method) + +(defmethod simple-method-body + ((method standard-effective-method) codegen target) + (invoke-delegation-chain codegen + target + (effective-method-basic-argument-names method) + (effective-method-primary-methods method) + nil)) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-module.lisp b/src/impl-module.lisp new file mode 100644 index 0000000..8349b85 --- /dev/null +++ b/src/impl-module.lisp @@ -0,0 +1,189 @@ +;;; -*-lisp-*- +;;; +;;; Module protocol implementation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Module basics. + +(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)) + (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 objects. + +(defparameter *module-map* (make-hash-table :test #'equal) + "Hash table mapping true names to module objects.") + +(defun build-module + (name thunk &key (truename (probe-file name)) location) + "Construct a new module. + + This is the functionality underlying `define-module'." + + (let ((*module* (make-instance 'module + :name (pathname name) + :state (file-location location)))) + (when truename + (setf (gethash truename *module-map*) *module*)) + (unwind-protect + (call-with-module-environment (lambda () + (module-import *builtin-module*) + (funcall thunk) + (finalize-module *module*))) + (when (and truename (not (eq (module-state *module*) t))) + (remhash truename *module-map*))))) + +;;;-------------------------------------------------------------------------- +;;; Type definitions. + +(export 'type-item) +(defclass type-item () + ((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)) + (def (gethash name *module-type-map*)) + (type (make-simple-type name))) + (cond ((not def) + (setf (gethash name *module-type-map*) type)) + ((not (eq def type)) + (error "Conflicting types `~A'" name))))) + +(defmethod module-import ((class sod-class)) + (record-sod-class class)) + +;;;-------------------------------------------------------------------------- +;;; Code fragments. + +(export 'c-fragment) +(defclass c-fragment () + ((location :initarg :location :type file-location + :accessor c-fragment-location) + (text :initarg :text :type string :accessor c-fragment-text)) + (:documentation + "Represents a fragment of C code to be written to an output file. + + A C fragment is aware of its original location, and will bear proper #line + markers when written out.")) + +(defun output-c-excursion (stream location thunk) + "Invoke THUNK surrounding it by writing #line markers to STREAM. + + The first marker describes LOCATION; the second refers to the actual + output position in STREAM. If LOCATION doesn't provide a line number then + no markers are output after all. If the output stream isn't + position-aware then no final marker is output." + + (let* ((location (file-location location)) + (line (file-location-line location)) + (filename (file-location-filename location))) + (cond (line + (format stream "~&#line ~D~@[ ~S~]~%" line filename) + (funcall thunk) + (when (typep stream 'position-aware-stream) + (fresh-line stream) + (format stream "~&#line ~D ~S~%" + (1+ (position-aware-stream-line stream)) + (namestring (stream-pathname stream))))) + (t + (funcall thunk))))) + +(defmethod print-object ((fragment c-fragment) stream) + (let ((text (c-fragment-text fragment)) + (location (c-fragment-location fragment))) + (if *print-escape* + (print-unreadable-object (fragment stream :type t) + (when location + (format stream "~A " location)) + (cond ((< (length text) 40) + (prin1 text stream) stream) + (t + (prin1 (subseq text 0 37) stream) + (write-string "..." stream)))) + (output-c-excursion stream location + (lambda () (write-string text stream)))))) + +(defmethod make-load-form ((fragment c-fragment) &optional environment) + (make-load-form-saving-slots fragment :environment environment)) + +(export 'code-fragment-item) +(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)))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-output.lisp b/src/impl-output.lisp new file mode 100644 index 0000000..30d0c80 --- /dev/null +++ b/src/impl-output.lisp @@ -0,0 +1,58 @@ +;;; -*-lisp-*- +;;; +;;; Output scheduling protocol implementation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Sequencing machinery. + +(defmethod print-object ((item sequencer-item) stream) + (print-unreadable-object (item stream :type t) + (prin1 (sequencer-item-name item) stream))) + +(defmethod ensure-sequencer-item ((sequencer sequencer) name) + (with-slots (table) sequencer + (or (gethash name table) + (setf (gethash name table) + (make-instance 'sequencer-item :name name))))) + +(defmethod add-sequencer-constraint ((sequencer sequencer) (constraint list)) + (let ((converted-constraint + (mapcar (lambda (name) + (ensure-sequencer-item sequencer name)) + constraint))) + (with-slots (constraints) sequencer + (pushnew converted-constraint constraints :test #'equal)))) + +(defmethod add-sequencer-item-function ((sequencer sequencer) name function) + (let ((item (ensure-sequencer-item sequencer name))) + (pushnew function (sequencer-item-functions item)))) + +(defmethod invoke-sequencer-items ((sequencer sequencer) &rest arguments) + (dolist (item (merge-lists (reverse (sequencer-constraints sequencer)))) + (dolist (function (reverse (sequencer-item-functions item))) + (apply function arguments)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/impl-pset.lisp b/src/impl-pset.lisp new file mode 100644 index 0000000..e498deb --- /dev/null +++ b/src/impl-pset.lisp @@ -0,0 +1,83 @@ +;;; -*-lisp-*- +;;; +;;; Implementation for property sets +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Property representation. + +(defmethod file-location ((prop property)) + (file-location (p-location prop))) + +;;; Keywords. + +(defmethod coerce-property-value + ((value symbol) (type (eql :symbol)) (wanted (eql :keyword))) + value) + +(defmethod coerce-property-value + ((value string) (type (eql :id)) (wanted (eql :keyword))) + (string-to-symbol value :package :keyword)) + +(defmethod coerce-property-value + ((value string) (type (eql :string)) (wanted (eql :keyword))) + (string-to-symbol value :package :keyword :swap-hyphen nil)) + +;;; Symbols. + +(defmethod coerce-property-value + ((value string) (type (eql :id)) (wanted (eql :symbol))) + (string-to-symbol value)) + +(defmethod coerce-property-value + ((value string) (type (eql :string)) (wanted (eql :symbol))) + (string-to-symbol value :swap-hyphen nil)) + +;;; Identifiers. + +(defmethod coerce-property-value + ((value string) (type (eql :string)) (wanted (eql :id))) + value) + +(defmethod coerce-property-value + ((value symbol) (type (eql :symbol)) (wanted (eql :id))) + (frob-identifier (symbol-name value))) + +;;;-------------------------------------------------------------------------- +;;; Property sets. + +(defmethod print-object ((pset pset) stream) + (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))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/lexer-bits.lisp b/src/lexer-bits.lisp new file mode 100644 index 0000000..daa533c --- /dev/null +++ b/src/lexer-bits.lisp @@ -0,0 +1,98 @@ +(cl:in-package #:sod) + +(defun play-fetch-token (string) + (with-parser-context (string-parser :string string) + (labels ((digit (radix) + (parse (filter (lambda (ch) + (digit-char-p ch radix))))) + (number (radix &optional (initial 0)) + (parse (many (a initial (+ (* radix a) it)) + (digit radix)))) + (numeric (radix sigil) + (parse (seq ((first (peek (seq ((nil (funcall sigil)) + (d (digit radix))) + d))) + (result (number radix first))) + result)))) + (multiple-value-call #'values + (loop + (parse :whitespace) + + (cond-parse () + + ;; Give up at end-of-file. + (:eof + (return (values :eof nil))) + + ;; Pick out comments. + ((peek (and #\/ #\*)) + (parse (skip-many () ; this may fail at eof; don't worry + (and (skip-many () (not #\*)) + (skip-many (:min 1) #\*)) + (not #\/))) + (if-parse :eof () + (cerror* "Unterminated comment") + (parse :any))) + ((and (peek (seq (#\/ #\/))) + (skip-many () (not #\newline)) + (or :eof #\newline))) + + ;; Quoted strings and characters. + ((or #\' #\") + (let ((quote it) + (out (make-string-output-stream))) + (parse (skip-many () + (or (seq ((ch (satisfies (lambda (ch) + (and (char/= ch #\\) + (char/= ch quote)))))) + (write-char ch out)) + (seq (#\\ (ch :any)) + (write-char ch out))))) + (if-parse :eof () + (cerror* "Unterminated ~:[string~;character~] constant" + (char= quote #\')) + (parse :any)) + (let ((string (get-output-stream-string out))) + (ecase quote + (#\" (return (values :string string))) + (#\' (case (length string) + (0 (cerror* "Empty character constant") + (return (values :char #\?))) + (1 (return (values :char (char string 0)))) + (t (cerror* "Multiple characters in ~ + character constant") + (return (values :char (char string 0)))))))))) + + ;; Identifiers. + ((seq ((first (satisfies (lambda (ch) + (or (char= ch #\_) + (alpha-char-p ch))))) + (ident (many (out (let ((s (make-string-output-stream))) + (write-char first s) + s) + (progn (write-char it out) out) + :final (get-output-stream-string out)) + (satisfies (lambda (ch) + (or (char= ch #\_) + (alphanumericp ch))))))) + (return (values :id ident)))) + + ;; Numbers -- uses the machinery in the labels above. + ((or (seq (#\0 + (i (or (numeric 8 (parser () (or #\o #\O))) + (numeric 16 (parser () (or #\x #\X))) + (number 8)))) + i) + (seq ((first (digit 10)) + (rest (number 10 first))) + rest)) + (return (values :integer it))) + + ;; Special separator tokens. + ("..." + (return (values :ellipsis :ellipsis))) + + ;; Anything else is a standalone delimiter character. + (:any + (return (values it it))))) + (parse (list () :any)))))) diff --git a/src/output-class.lisp b/src/output-class.lisp new file mode 100644 index 0000000..58d4830 --- /dev/null +++ b/src/output-class.lisp @@ -0,0 +1,576 @@ +;;; -*-lisp-*- +;;; +;;; Output for classes +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Classes. + +(defmethod hook-output progn ((class sod-class) (reason (eql :h)) + sequencer) + + ;; Main output sequencing. + (sequence-output (stream sequencer) + + :constraint + ((:classes :start) + (class :banner) + (class :islots :start) (class :islots :slots) (class :islots :end) + (class :vtmsgs :start) (class :vtmsgs :end) + (class :vtables :start) (class :vtables :end) + (class :vtable-externs) (class :vtable-externs-after) + (class :methods :start) (class :methods) (class :methods :end) + (class :ichains :start) (class :ichains :end) + (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end) + (class :conversions) + (class :object) + (:classes :end)) + + (:typedefs + (format stream "typedef struct ~A ~A;~%" + (ichain-struct-tag class (sod-class-chain-head class)) class)) + + ((class :banner) + (banner (format nil "Class ~A" class) stream)) + ((class :vtable-externs-after) + (terpri stream)) + + ((class :vtable-externs) + (format stream "/* Vtable structures. */~%")) + + ((class :object) + (let ((metaclass (sod-class-metaclass class)) + (metaroot (find-root-metaclass class))) + (format stream "/* The class object. */~@ + extern const struct ~A ~A__classobj;~@ + #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%" + (ilayout-struct-tag metaclass) class + (sod-class-nickname (sod-class-chain-head metaroot)) + (sod-class-nickname metaroot))))) + + ;; Maybe generate an islots structure. + (when (sod-class-slots class) + (dolist (slot (sod-class-slots class)) + (hook-output slot 'islots sequencer)) + (sequence-output (stream sequencer) + ((class :islots :start) + (format stream "/* Instance slots. */~@ + struct ~A {~%" + (islots-struct-tag class))) + ((class :islots :end) + (format stream "};~2%")))) + + ;; Declare the direct methods. + (when (sod-class-methods class) + (sequence-output (stream sequencer) + ((class :methods :start) + (format stream "/* Direct methods. */~%")) + ((class :methods :end) + (terpri stream)))) + + ;; Provide upcast macros which do the right thing. + (when (sod-class-direct-superclasses class) + (sequence-output (stream sequencer) + ((class :conversions) + (let ((chain-head (sod-class-chain-head class))) + (format stream "/* Conversion macros. */~%") + (dolist (super (cdr (sod-class-precedence-list class))) + (let ((super-head (sod-class-chain-head super))) + (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~ + ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%" + class (sod-class-nickname super) super + (eq chain-head super-head) + (sod-class-nickname super-head)))) + (terpri stream))))) + + ;; Generate vtmsgs structure for all superclasses. + (hook-output (car (sod-class-vtables class)) + 'vtmsgs + sequencer)) + +(defmethod hook-output progn ((class sod-class) reason sequencer) + (with-slots (ilayout vtables methods effective-methods) class + (hook-output ilayout reason sequencer) + (dolist (method methods) (hook-output method reason sequencer)) + (dolist (method effective-methods) + (hook-output method reason sequencer)) + (dolist (vtable vtables) (hook-output vtable reason sequencer)))) + +;;;-------------------------------------------------------------------------- +;;; Instance structure. + +(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots)) + sequencer) + (sequence-output (stream sequencer) + (((sod-slot-class slot) :islots :slots) + (pprint-logical-block (stream nil :prefix " " :suffix ";") + (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot))) + (terpri stream)))) + +(defmethod hook-output progn ((ilayout ilayout) reason sequencer) + (with-slots (ichains) ilayout + (dolist (ichain ichains) (hook-output ichain reason sequencer)))) + +(defmethod hook-output progn ((ichain ichain) reason sequencer) + (dolist (item (ichain-body ichain)) + (hook-output item reason sequencer))) + +(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) + sequencer) + (with-slots (class ichains) ilayout + (sequence-output (stream sequencer) + ((class :ilayout :start) + (format stream "/* Instance layout. */~@ + struct ~A {~%" + (ilayout-struct-tag class))) + ((class :ilayout :end) + (format stream "};~2%"))) + (dolist (ichain ichains) + (hook-output ichain 'ilayout sequencer)))) + +(defmethod hook-output progn ((ichain ichain) (reason (eql :h)) + sequencer) + (with-slots (class chain-head chain-tail) ichain + (when (eq class chain-tail) + (sequence-output (stream sequencer) + :constraint ((class :ichains :start) + (class :ichain chain-head :start) + (class :ichain chain-head :slots) + (class :ichain chain-head :end) + (class :ichains :end)) + ((class :ichain chain-head :start) + (format stream "/* Instance chain structure. */~@ + struct ~A {~%" + (ichain-struct-tag chain-tail chain-head))) + ((class :ichain chain-head :end) + (format stream "};~2%") + (format stream "/* Union of equivalent superclass chains. */~@ + union ~A {~@ + ~:{ struct ~A ~A;~%~}~ + };~2%" + (ichain-union-tag chain-tail chain-head) + + ;; Make sure the most specific class is first: only the + ;; first element of a union can be statically initialized in + ;; C90. + (mapcar (lambda (super) + (list (ichain-struct-tag super chain-head) + (sod-class-nickname super))) + (sod-class-chain chain-tail)))))))) + +(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout)) + sequencer) + (with-slots (class chain-head chain-tail) ichain + (sequence-output (stream sequencer) + ((class :ilayout :slots) + (format stream " union ~A ~A;~%" + (ichain-union-tag chain-tail chain-head) + (sod-class-nickname chain-head)))))) + +(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h)) + sequencer) + (with-slots (class chain-head chain-tail) vtptr + (sequence-output (stream sequencer) + ((class :ichain chain-head :slots) + (format stream " const struct ~A *_vt;~%" + (vtable-struct-tag chain-tail chain-head)))))) + +(defmethod hook-output progn ((islots islots) reason sequencer) + (dolist (slot (islots-slots islots)) + (hook-output slot reason sequencer))) + +(defmethod hook-output progn ((islots islots) (reason (eql :h)) + sequencer) + (with-slots (class subclass slots) islots + (sequence-output (stream sequencer) + ((subclass :ichain (sod-class-chain-head class) :slots) + (format stream " struct ~A ~A;~%" + (islots-struct-tag class) + (sod-class-nickname class)))))) + +;;;-------------------------------------------------------------------------- +;;; Vtable structure. + +(defmethod hook-output progn ((vtable vtable) reason sequencer) + (with-slots (body) vtable + (dolist (item body) (hook-output item reason sequencer)))) + +(defmethod hook-output progn ((method sod-method) (reason (eql :h)) + sequencer) + (with-slots (class) method + (sequence-output (stream sequencer) + ((class :methods) + (let ((type (sod-method-function-type method))) + (princ "extern " stream) + (pprint-c-type (commentify-function-type type) stream + (sod-method-function-name method)) + (format stream ";~%")))))) + +(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) + sequencer) + (with-slots (class chain-head chain-tail) vtable + (when (eq class chain-tail) + (sequence-output (stream sequencer) + :constraint ((class :vtables :start) + (class :vtable chain-head :start) + (class :vtable chain-head :slots) + (class :vtable chain-head :end) + (class :vtables :end)) + ((class :vtable chain-head :start) + (format stream "/* Vtable structure. */~@ + struct ~A {~%" + (vtable-struct-tag chain-tail chain-head))) + ((class :vtable chain-head :end) + (format stream "};~2%")))) + (sequence-output (stream sequencer) + ((class :vtable-externs) + (format stream "~@~%" + (vtable-struct-tag chain-tail chain-head) + class (sod-class-nickname chain-head)))))) + +(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) + sequencer) + (with-slots (class subclass chain-head chain-tail) vtmsgs + (sequence-output (stream sequencer) + ((subclass :vtable chain-head :slots) + (format stream " struct ~A ~A;~%" + (vtmsgs-struct-tag subclass class) + (sod-class-nickname class)))))) + +(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs)) + sequencer) + (when (vtmsgs-entries vtmsgs) + (with-slots (class subclass) vtmsgs + (sequence-output (stream sequencer) + :constraint ((subclass :vtmsgs :start) + (subclass :vtmsgs class :start) + (subclass :vtmsgs class :slots) + (subclass :vtmsgs class :end) + (subclass :vtmsgs :end)) + ((subclass :vtmsgs class :start) + (format stream "/* Messages protocol from class ~A */~@ + struct ~A {~%" + class + (vtmsgs-struct-tag subclass class))) + ((subclass :vtmsgs class :end) + (format stream "};~2%")))))) + +(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer) + (with-slots (entries) vtmsgs + (dolist (entry entries) (hook-output entry reason sequencer)))) + +(defmethod hook-output progn ((entry method-entry) reason sequencer) + (with-slots (method) entry + (hook-output method reason sequencer))) + +(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs)) + sequencer) + (let* ((method (method-entry-effective-method entry)) + (message (effective-method-message method)) + (class (effective-method-class method)) + (type (method-entry-function-type entry)) + (commented-type (commentify-function-type type))) + (sequence-output (stream sequencer) + ((class :vtmsgs (sod-message-class message) :slots) + (pprint-logical-block (stream nil :prefix " " :suffix ";") + (pprint-c-type commented-type stream (sod-message-name message))) + (terpri stream))))) + +(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h)) + sequencer) + (with-slots (class chain-head metaclass meta-chain-head) cptr + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" + metaclass + (if (sod-class-direct-superclasses meta-chain-head) + (sod-class-nickname meta-chain-head) + nil)))))) + +(defmethod hook-output progn ((boff base-offset) (reason (eql :h)) + sequencer) + (with-slots (class chain-head) boff + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (write-line " size_t _base;" stream))))) + +(defmethod hook-output progn ((choff chain-offset) (reason (eql :h)) + sequencer) + (with-slots (class chain-head target-head) choff + (sequence-output (stream sequencer) + ((class :vtable chain-head :slots) + (format stream " ptrdiff_t _off_~A;~%" + (sod-class-nickname target-head)))))) + +;;;-------------------------------------------------------------------------- +;;; Implementation output. + +(defvar *instance-class*) + +(defmethod hook-output progn ((class sod-class) (reason (eql :c)) + sequencer) + (sequence-output (stream sequencer) + + :constraint + ((:classes :start) + (class :banner) + (class :direct-methods :start) (class :direct-methods :end) + (class :effective-methods) + (class :vtables :start) (class :vtables :end) + (class :object :prepare) (class :object :start) (class :object :end) + (:classes :end)) + + ((class :banner) + (banner (format nil "Class ~A" class) stream)) + + ((class :object :start) + (format stream "~ +/* The class object. */ +const struct ~A ~A__classobj = {~%" + (ilayout-struct-tag (sod-class-metaclass class)) + class)) + ((class :object :end) + (format stream "};~2%"))) + + (let ((*instance-class* class)) + (hook-output (sod-class-ilayout (sod-class-metaclass class)) + 'class + sequencer))) + +;;;-------------------------------------------------------------------------- +;;; Direct methods. + +(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)) + sequencer) + (with-slots (class body) method + (unless body + (return-from hook-output)) + (sequence-output (stream sequencer) + ((class :direct-method method :start) + (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%" + (mapcar #'argument-name + (c-function-arguments (sod-method-next-method-type + method))))) + ((class :direct-method method :end) + (format stream "#undef CALL_NEXT_METHOD~%"))))) + +(defmethod hook-output progn ((method sod-method) (reason (eql :c)) + sequencer) + (with-slots (class body) method + (unless body + (return-from hook-output)) + (sequence-output (stream sequencer) + :constraint ((class :direct-methods :start) + (class :direct-method method :start) + (class :direct-method method :body) + (class :direct-method method :end) + (class :direct-methods :end)) + ((class :direct-method method :body) + (pprint-c-type (sod-method-function-type method) + stream + (sod-method-function-name method)) + (format stream "~&{~%") + (write body :stream stream :pretty nil :escape nil) + (format stream "~&}~%")) + ((class :direct-method method :end) + (terpri stream))))) + +(defmethod hook-output progn ((method basic-effective-method) (reason (eql :c)) + sequencer) + (with-slots (class functions) method + (sequence-output (stream sequencer) + ((class :effective-methods) + (dolist (func functions) + (write func :stream stream :escape nil :circle nil)))))) + +;;;-------------------------------------------------------------------------- +;;; Vtables. + +(defmethod hook-output progn ((vtable vtable) (reason (eql :c)) + sequencer) + (with-slots (class chain-head chain-tail) vtable + (sequence-output (stream sequencer) + :constraint ((class :vtables :start) + (class :vtable chain-head :start) + (class :vtable chain-head :end) + (class :vtables :end)) + ((class :vtable chain-head :start) + (format stream "/* Vtable for ~A chain. */~@ + static const struct ~A ~A = {~%" + chain-head + (vtable-struct-tag chain-tail chain-head) + (vtable-name chain-tail chain-head))) + ((class :vtable chain-head :end) + (format stream "};~2%"))))) + +(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c)) + sequencer) + (with-slots (class chain-head metaclass meta-chain-head) cptr + (sequence-output (stream sequencer) + :constraint ((class :vtable chain-head :start) + (class :vtable chain-head :class-pointer metaclass) + (class :vtable chain-head :end)) + ((class :vtable chain-head :class-pointer metaclass) + (format stream " &~A__classobj.~A.~A,~%" + (sod-class-metaclass class) + (sod-class-nickname meta-chain-head) + (sod-class-nickname metaclass)))))) + +(defmethod hook-output progn ((boff base-offset) (reason (eql :c)) + sequencer) + (with-slots (class chain-head) boff + (sequence-output (stream sequencer) + :constraint ((class :vtable chain-head :start) + (class :vtable chain-head :base-offset) + (class :vtable chain-head :end)) + ((class :vtable chain-head :base-offset) + (format stream " offsetof(struct ~A, ~A),~%" + (ilayout-struct-tag class) + (sod-class-nickname chain-head)))))) + +(defmethod hook-output progn ((choff chain-offset) (reason (eql :c)) + sequencer) + (with-slots (class chain-head target-head) choff + (sequence-output (stream sequencer) + :constraint ((class :vtable chain-head :start) + (class :vtable chain-head :chain-offset target-head) + (class :vtable chain-head :end)) + ((class :vtable chain-head :chain-offset target-head) + (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%" + (ilayout-struct-tag class) + (sod-class-nickname chain-head) + (sod-class-nickname target-head)))))) + +(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) + sequencer) + (with-slots (class subclass chain-head) vtmsgs + (sequence-output (stream sequencer) + :constraint ((subclass :vtable chain-head :start) + (subclass :vtable chain-head :vtmsgs class :start) + (subclass :vtable chain-head :vtmsgs class :slots) + (subclass :vtable chain-head :vtmsgs class :end) + (subclass :vtable chain-head :end)) + ((subclass :vtable chain-head :vtmsgs class :start) + (format stream " { /* Method entries for ~A messages. */~%" + class)) + ((subclass :vtable chain-head :vtmsgs class :end) + (format stream " },~%"))))) + +(defmethod hook-output progn ((entry method-entry) (reason (eql :c)) + sequencer) + (with-slots (method chain-head chain-tail) entry + (let* ((message (effective-method-message method)) + (class (effective-method-class method)) + (super (sod-message-class message))) + (sequence-output (stream sequencer) + ((class :vtable chain-head :vtmsgs super :slots) + (format stream " ~A,~%" + (method-entry-function-name method chain-head))))))) + +;;;-------------------------------------------------------------------------- +;;; Filling in the class object. + +(defmethod hook-output progn ((ichain ichain) (reason (eql 'class)) + sequencer) + (with-slots (class chain-head) ichain + (sequence-output (stream sequencer) + :constraint ((*instance-class* :object :start) + (*instance-class* :object chain-head :ichain :start) + (*instance-class* :object chain-head :ichain :end) + (*instance-class* :object :end)) + ((*instance-class* :object chain-head :ichain :start) + (format stream " { { /* ~A ichain */~%" + (sod-class-nickname chain-head))) + ((*instance-class* :object chain-head :ichain :end) + (format stream " } },~%"))))) + +(defmethod hook-output progn ((islots islots) (reason (eql 'class)) + sequencer) + (with-slots (class) islots + (let ((chain-head (sod-class-chain-head class))) + (sequence-output (stream sequencer) + :constraint ((*instance-class* :object chain-head :ichain :start) + (*instance-class* :object class :slots :start) + (*instance-class* :object class :slots) + (*instance-class* :object class :slots :end) + (*instance-class* :object chain-head :ichain :end)) + ((*instance-class* :object class :slots :start) + (format stream " { /* Class ~A */~%" class)) + ((*instance-class* :object class :slots :end) + (format stream " },~%")))))) + +(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class)) + sequencer) + (with-slots (class chain-head chain-tail) vtptr + (sequence-output (stream sequencer) + :constraint ((*instance-class* :object chain-head :ichain :start) + (*instance-class* :object chain-head :vtable) + (*instance-class* :object chain-head :ichain :end)) + ((*instance-class* :object chain-head :vtable) + (format stream " &~A__vtable_~A,~%" + class (sod-class-nickname chain-head)))))) + +(defgeneric find-class-initializer (slot class) + (:method ((slot effective-slot) (class sod-class)) + (let ((dslot (effective-slot-direct-slot slot))) + (or (some (lambda (super) + (find dslot (sod-class-class-initializers super) + :test #'sod-initializer-slot)) + (sod-class-precedence-list class)) + (effective-slot-initializer slot))))) + +(defgeneric output-class-initializer (slot instance stream) + (:method ((slot sod-class-effective-slot) (instance sod-class) stream) + (let ((func (effective-slot-initializer-function slot))) + (if func + (format stream " ~A,~%" (funcall func instance)) + (call-next-method)))) + (:method ((slot effective-slot) (instance sod-class) stream) + (let ((init (find-class-initializer slot instance))) + (ecase (sod-initializer-value-kind init) + (:simple (format stream " ~A,~%" + (sod-initializer-value-form init))) + (:compound (format stream " ~@<{ ~;~A~; },~:>~%" + (sod-initializer-value-form init))))))) + +(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class)) + sequencer) + (let ((instance *instance-class*) + (func (effective-slot-prepare-function slot))) + (when func + (sequence-output (stream sequencer) + ((instance :object :prepare) + (funcall func instance stream)))))) + +(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class)) + sequencer) + (with-slots (class (dslot slot)) slot + (let ((instance *instance-class*) + (super (sod-slot-class dslot))) + (sequence-output (stream sequencer) + ((instance :object super :slots) + (output-class-initializer slot instance stream)))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/package.lisp b/src/package.lisp new file mode 100644 index 0000000..60da8ea --- /dev/null +++ b/src/package.lisp @@ -0,0 +1,31 @@ +;;; -*-lisp-*- +;;; +;;; Package definition for SOD utility +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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:defpackage #:sod + (:use #:common-lisp + #:sod-utilities + #:sod-parser)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parse-c-types.lisp b/src/parse-c-types.lisp new file mode 100644 index 0000000..15de8b0 --- /dev/null +++ b/src/parse-c-types.lisp @@ -0,0 +1,314 @@ +;;; -*-lisp-*- +;;; +;;; Parser for C types +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Declaration specifiers. + +(defclass declspec () + ((label :type keyword :initarg :label :reader ds-label) + (name :type string :initarg :name :reader ds-name) + (kind :type (member type sign size qualifier tagged) + :initarg :kind :reader ds-kind))) + +(defmethod shared-initialize :after ((ds declspec) slot-names &key) + (default-slot (ds 'name slot-names) + (string-downcase (ds-label ds)))) + +(defclass declspecs () + ((type :initform nil :initarg :type :reader ds-type) + (sign :initform nil :initarg :sign :reader ds-sign) + (size :initform nil :initarg :size :reader ds-size) + (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))) + +(defparameter *declspec-map* + (let ((map (make-hash-table :test #'equal))) + (dolist (item '((type :void :char :int :float :double) + (size :short :long (:long-long "long long")) + (sign :signed :unsigned) + (qualifier :const :restrict :volatile) + (tagged :enum :struct :union))) + (let ((kind (car item))) + (dolist (spec (cdr item)) + (multiple-value-bind (label name) + (if (consp spec) + (values (car spec) (cadr spec)) + (values spec (string-downcase spec))) + (let ((ds (make-instance 'declspec + :label label :name name :kind kind))) + (setf (gethash name map) ds + (gethash label map) ds)))))) + map)) + +(defmethod ds-label ((ty c-type)) :c-type) +(defmethod ds-name ((ty c-type)) (princ-to-string ty)) +(defmethod ds-kind ((ty c-type)) 'type) + +(defparameter *good-declspecs* + '(((:int) (:signed :unsigned) (:short :long :long-long)) + ((:char) (:signed :unsigned) ()) + ((:double) () (:long)) + (t () ())) + "List of good collections of declaration specifiers. + + Each item is a list of the form (TYPES SIGNS SIZES). Each of TYPES, SIGNS + and SIZES is either a list of acceptable specifiers of the appropriate + kind, or T, which matches any specifier.") + +(defun scan-declspec (scanner) + "Scan a DECLSPEC from SCANNER. + + Value on success is either a DECLSPEC object or a C-TYPE object." + + ;; Turns out to be easier to do this by hand. + (let ((ds (and (eq (token-type scanner) :id) + (let ((kw (token-value scanner))) + (or (gethash kw *declspec-map*) + (gethash kw *module-type-map*)))))) + (cond ((not ds) + (values (list :declspec) nil nil)) + ((eq (ds-kind ds) :tagged) + (scanner-step scanner) + (if (eq (token-type scanner) :id) + (let ((ty (make-c-tagged-type (ds-label ds) + (token-value scanner)))) + (scanner-step scanner) + (values ty t t)) + (values :tag nil t))) + (t + (scanner-step scanner) + (values ds t t))))) + +(defun good-declspecs-p (specs) + "Are SPECS a good collection of declaration specifiers?" + (let ((speclist (list (ds-type specs) (ds-sign specs) (ds-size specs)))) + (some (lambda (it) + (every (lambda (spec pat) + (or (eq pat t) (null spec) + (member (ds-label spec) pat))) + speclist it)) + *good-declspecs*))) + +(defun combine-declspec (specs ds) + "Combine the declspec DS with the existing SPECS. + + Returns new DECLSPECS if they're OK, or `nil' if not. The old SPECS are + not modified." + (let* ((kind (ds-kind ds)) + (old (slot-value specs kind))) + (multiple-value-bind (ok new) + (case kind + (qualifier (values t (adjoin ds old))) + (size (cond ((not old) (values t ds)) + ((and (eq (ds-label old) :long) (eq ds old)) + (values t (gethash :long-long *declspec-map*))) + (t (values nil nil)))) + (t (values (not old) ds))) + (if ok + (let ((copy (copy-instance specs))) + (setf (slot-value copy kind) new) + (and (good-declspecs-p copy) copy)) + nil)))) + +(defun scan-and-merge-declspec (scanner specs) + (with-parser-context (token-scanner-context :scanner scanner) + (if-parse (:consumedp consumedp) (scan-declspec scanner) + (aif (combine-declspec specs it) + (values it t consumedp) + (values (list :declspec) nil consumedp))))) + +(defun declspecs-type (specs) + (let ((type (ds-type specs)) + (size (ds-size specs)) + (sign (ds-sign specs))) + (cond ((or type size sign) + (when (and (eq (ds-label sign) :signed) + (eq (ds-label type) :int)) + (setf sign nil)) + (cond ((and (or (null type) (eq (ds-label type) :int)) + (or size sign)) + (setf type nil)) + ((null type) + (setf type (gethash :int *declspec-map*)))) + (make-simple-type (format nil "~{~@[~A~^ ~]~}" + (mapcar #'ds-label + (remove nil + (list sign size type)))) + (mapcar #'ds-label (ds-qualifiers specs)))) + (t + nil)))) + +(defun parse-c-type (scanner) + (with-parser-context (token-scanner-context :scanner scanner) + (if-parse (:result specs :consumedp cp) + (many (specs (make-instance 'declspecs) it :min 1) + (scan-and-merge-declspec scanner specs)) + (let ((type (declspecs-type specs))) + (if type (values type t cp) + (values (list :declspec) nil cp)))))) + + + + + + + + + + + + ;; This is rather complicated, but extracting all the guts into a structure + ;; and passing it around makes matters worse rather than better. + ;; + ;; We categorize declaration specifiers into four kinds. + ;; + ;; * `Type specifiers' describe the actual type, whether that's integer, + ;; character, floating point, or some tagged or user-named type. + ;; + ;; * `Size specifiers' distinguish different sizes of the same basic + ;; type. This is how we tell the difference between `int' and `long'. + ;; + ;; * `Sign specifiers' distinguish different signednesses. This is how + ;; we tell the difference between `int' and `unsigned'. + ;; + ;; * `Qualifiers' are our old friends `const', `restrict' and `volatile'. + ;; + ;; These groupings are for our benefit here, in determining whether a + ;; particular declaration specifier is valid in the current context. We + ;; don't accept `function specifiers' (of which the only current example is + ;; `inline') since it's meaningless to us. + ;; + ;; Our basic strategy is to parse declaration specifiers while they're + ;; valid, and keep track of what we've read. When we've reached the end, + ;; we'll convert what we've got into a `canonical form', and then convert + ;; that into a C type object of the appropriate kind. + + (let ((specs (make-instance 'declspecs))) + + + (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil)) + (labels ((goodp (ty sg sz) + "Are (TY SG SZ) a good set of declaration specifiers?" + (some (lambda (it) + (every (lambda (spec pat) + (or (eq pat t) (eq spec nil) + (member spec pat))) + decls it)) + *good-declspecs*)) + + (scan-declspec () + "Scan a declaration specifier." + (flet ((win (value &optional (consumedp t)) + (when consumedp (scanner-step scanner)) + (return-from scan-declspec + (values value t consumedp))) + (lose (wanted &optional (consumedp nil)) + (values wanted nil consumedp))) + (unless (eq (token-type scanner) :id) (lose :declspec)) + (let* ((id (token-value scanner)) + (ds (or (gethash id *declspec-map*) + (gethash id *module-type-map*)))) + (unless ds (lose :declspec)) + (let ((label (ds-label ds))) + (ecase (ds-kind ds) + (:qualifier + (push (ds-label ds) quals) + (win ds)) + (:size + (cond ((and (not size) (goodp type label sign)) + (setf size label) + (win ds)) + (t + (lose :declspec)))) + (:sign + (cond ((and (not sign) (goodp type size label)) + (setf sign label) + (win ds)) + (t + (lose :declspec)))) + (:type + (when (and (eq type :long) (eq label :long)) + (setf label :long-long)) + (cond ((and (or (not type) (eq type :long)) + (goodp label size sign)) + (setf type label) + (win ds)) + (t + (lose :declspec)))) + (:tagged + (unless (and (not type) (goodp label size sign)) + (lose :declspec)) + (scanner-step scan) + (unless (eq (token-type scanner) :id) + (lose :tagged t)) + (setf type + (make-c-tagged-type label + (token-value scanner))) + (win type)))))))) + + (with-parser-context (token-scanner-context :scanner scanner) + (many (nil nil nil :min 1) + (scan-declspec)) + + + + + (let ((toks nil) (type nil) (size nil) (sign nil) (quals nil)) + (labels ((check (ty sz sg) + (case ty + ((nil :int) t) + (:char (null sz)) + (:double (and (null sg) (or (null sz) (eq sz :long)))) + (t (and (null sg) (null sz))))) + (set-type (ty) + (when )) + (set-size (sz) + (when (and (eq sz :long) (eq size :long)) + (setf sz :long-long)) + (when (and (or (null size) (eq sz :long-long)) + (check type sz sign)) + (setf size sz))) + (set-sign (sg) + (when (and (null sign) (check type size sg)) + (setf sign sg))) + (parse-declspec () + (multiple-value-bind (kind value) + (categorize-declspec scanner) + (if (ecase kind + (:qualifier (push value quals)) + (:type (and (null type) (check value size sign) + (setf type value))) + (:size (let ((sz (if (and (eq size :long) + (eq value :long)) + :long-long value))) + (and (or (null size) (eq sz :long-long)) + (check type value sign) + (setf size value)))) + (:sign (and (null sign) (check type size value) + (setf sign value))) + + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parse-lexical.lisp b/src/parse-lexical.lisp new file mode 100644 index 0000000..9fe6bb8 --- /dev/null +++ b/src/parse-lexical.lisp @@ -0,0 +1,198 @@ +;;; -*-lisp-*- +;;; +;;; Lexical analysis for input parser +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Class definition. + +(export 'sod-token-scanner) +(defclass sod-token-scanner (token-scanner) + ((char-scanner :initarg :char-scanner :reader token-scanner-char-scanner)) + (:documentation + "A token scanner for SOD input files. + + Not a lot here, apart from a character scanner to read from and the + standard token scanner infrastructure.")) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defun show-char (stream char &optional colonp atsignp) + "Format CHAR to STREAM in a readable way. + + Usable in `format''s ~/.../ command." + (declare (ignore colonp atsignp)) + (cond ((null char) (write-string "" stream)) + ((and (graphic-char-p char) (char/= char #\space)) + (format stream "`~C'" char)) + (t (format stream "<~(~:C~)>" char)))) + +(defun scan-comment (scanner) + "Scan a comment (either `/* ... */' or `// ...') from SCANNER. + + The result isn't interesting." + (with-parser-context (character-scanner-context :scanner scanner) + (parse (or (and "/*" + (and (skip-many () + (and (skip-many () (not #\*)) + (label "*/" (skip-many (:min 1) #\*))) + (not #\/)) + #\/)) + (and "//" + (skip-many () (not #\newline)) + (? #\newline)))))) + +;;;-------------------------------------------------------------------------- +;;; Error reporting. + +(export 'syntax-error) +(defun syntax-error (scanner expected &key (continuep t)) + "Signal a (maybe) continuable syntax error." + (labels ((show-token (type value) + (if (characterp type) + (format nil "~/sod::show-char/" type) + (case type + (:id (format nil "" value)) + (:string "") + (:char "") + (:eof "") + (:ellipsis "`...'") + (t (format nil "" type value))))) + (show-expected (thing) + (cond ((atom thing) (show-token thing nil)) + ((eq (car thing) :id) + (format nil "`~A'" (cadr thing))) + (t (format nil "" thing))))) + (funcall (if continuep #'cerror* #'error) + "Syntax error: ~ + expected ~{#[~;~A~;~A or ~A~:;~A, ~]~} ~ + but found ~A" + (mapcar #'show-expected expected) + (show-token (token-type scanner) (token-value scanner))))) + +;;;-------------------------------------------------------------------------- +;;; Token scanner protocol implementation. + +(defmethod scanner-token ((scanner sod-token-scanner)) + (with-slots (char-scanner line column) scanner + (with-parser-context (character-scanner-context :scanner char-scanner) + + (flet ((scan-digits (&key (radix 10) (min 1) (init 0)) + ;; Scan an return a sequence of digits. + (parse (many (acc init (+ (* acc radix) it) :min min) + (label (list :digit radix) + (filter (lambda (ch) + (digit-char-p ch radix))))))) + + (lexer-error (expected consumedp) + ;; Report a lexical error. + (cerror* "Lexical error: ~ + expected ~{~#[~;~A~;~A or ~A~;:~A, ~]~} ~ + but found ~/sod::show-char/~ + ~@[ at ~A~]" + (mapcar (lambda (exp) + (typecase exp + (character + (format nil "~/sod::show-char/" exp)) + (string (format nil "`~A'" exp)) + ((cons (eql :digit) *) + (format nil "" + (cadr exp))) + ((eql :eof) "") + ((eql :any) "") + (t (format nil "" exp)))) + expected) + (and (not (scanner-at-eof-p char-scanner)) + (scanner-current-char char-scanner)) + (and consumedp (file-location char-scanner))))) + + ;; Skip initial junk, and remember the place. + (loop + (setf (scanner-line scanner) (scanner-line char-scanner) + (scanner-column scanner) (scanner-column char-scanner)) + (cond-parse (:consumedp cp :expected exp) + ((satisfies whitespace-char-p) (parse :whitespace)) + ((scan-comment char-scanner)) + (t (if cp (lexer-error exp cp) (return))))) + + ;; Now parse something. + (cond-parse (:consumedp cp :expected exp) + + ;; Alphanumerics mean we read an identifier. + ((or #\_ (satisfies alpha-char-p)) + (values :id (with-output-to-string (out) + (write-char it out) + (parse (many (nil nil (write-char it out)) + (or #\_ (satisfies alphanumericp))))))) + + ;; Quotes introduce a literal. + ((seq ((quote (or #\" #\')) + (contents (many (out (make-string-output-stream) + (progn (write-char it out) out) + :final (get-output-stream-string out)) + (or (and #\\ :any) (not quote)))) + (nil (char quote))) + (ecase quote + (#\" contents) + (#\' (case (length contents) + (1 (char contents 0)) + (0 (cerror* "Empty character literal") #\?) + (t (cerror* "Too many characters in literal") + (char contents 0)))))) + (values (etypecase it + (character :char) + (string :string)) + it)) + + ;; Zero introduces a chosen-radix integer. + ((and #\0 + (or (and (or #\b #\B) (scan-digits :radix 2)) + (and (or #\o #\O) (scan-digits :radix 8)) + (and (or #\x #\X) (scan-digits :radix 16)) + (scan-digits :radix 8 :min 0))) + (values :int it)) + + ;; Any other digit forces radix-10. + ((seq ((d (filter digit-char-p)) + (i (scan-digits :radix 10 :min 0 :init d))) + i) + (values :int it)) + + ;; Some special punctuation sequences are single tokens. + ("..." (values :ellipsis nil)) + + ;; Any other character is punctuation. + (:any (values it nil)) + + ;; End of file means precisely that. + (:eof (values :eof nil)) + + ;; Report errors and try again. Because we must have consumed some + ;; input in order to get here (we've matched both :any and :eof) we + ;; must make progress on every call. + (t (assert cp) (lexer-error exp cp) (scanner-token scanner))))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-floc.lisp b/src/parser/impl-floc.lisp new file mode 100644 index 0000000..3fb6a5e --- /dev/null +++ b/src/parser/impl-floc.lisp @@ -0,0 +1,47 @@ +;;; -*-lisp-*- +;;; +;;; Implementation of file-location protocol +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; File location objects. + +(let ((null-file-location (make-file-location nil nil nil))) + (defmethod file-location ((thing t)) null-file-location)) + +(defmethod file-location ((stream stream)) + (make-file-location (stream-pathname stream) nil nil)) + +(defmethod print-object ((object file-location) stream) + (maybe-print-unreadable-object (object stream :type t) + (format stream "~:[~;~:*~A~]~@[:~D~]~@[:~D~]" + (file-location-filename object) + (file-location-line object) + (file-location-column object)))) + +(defmethod make-load-form ((object file-location) &optional environment) + (make-load-form-saving-slots object :environment environment)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-parser-expr.lisp b/src/parser/impl-parser-expr.lisp new file mode 100644 index 0000000..b5c1b57 --- /dev/null +++ b/src/parser/impl-parser-expr.lisp @@ -0,0 +1,219 @@ +;;; -*-lisp-*- +;;; +;;; Parsers for expressions with binary operators +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Basic protocol implementation. + +(defclass expression-parse-state () + ((opstack :initform nil :type list) + (valstack :initform nil :type list) + (nesting :initform 0 :type fixnum)) + (:documentation + "State for the expression parser. Largely passive.")) + +(defmethod push-value (value (state expression-parse-state)) + (with-slots (valstack) state + (push value valstack))) + +(defmethod push-operator (operator (state expression-parse-state)) + (with-slots (opstack) state + (loop + (when (null opstack) (return)) + (let ((head (car opstack))) + (ecase (operator-push-action head operator) + (:push (return)) + (:error (cerror* "Parse error: ... ~A ... ~A ... forbidden; ~ + operators aren't associative" + head operator)) + (:apply (apply-operator head state) + (setf opstack (cdr opstack)))))) + (push operator opstack))) + +(defgeneric apply-pending-operators (state) + (:documentation + "Apply all of the pending operators to their arguments. + + The return value is the final result of the parse. By the time all of the + operators have been applied, of course, there ought to be exactly one + operand remaining.") + (:method ((state expression-parse-state)) + (with-slots (opstack valstack) state + (dolist (operator opstack) + (apply-operator operator state)) + (assert (and (consp valstack) (null (cdr valstack)))) + (pop valstack)))) + +;;;-------------------------------------------------------------------------- +;;; Basic operator implementation. + +(defmethod operator-push-action (left right) + (let ((lprec (operator-right-precedence left)) + (rprec (operator-left-precedence right))) + (cond ((< lprec rprec) :push) + ((> lprec rprec) :apply) + (t (let ((lassoc (operator-associativity left)) + (rassoc (operator-associativity right))) + (cond ((not (eq lassoc rassoc)) + (cerror* "Parse error: ... ~A ... ~A ...: ~ + inconsistent associativity: ~ + ~(~A~) versus ~(~A~))" + left right + (or lassoc "none") (or rassoc "none")) + :apply) + ((not lassoc) + (cerror* "Parse error: ... ~A ... ~A ...: ~ + operators are not associative" + left right) + :apply) + ((eq lassoc :left) :apply) + ((eq lassoc :right) :push) + (t (error "Invalid associativity ~S ~ + for operators ~A and ~A" + lassoc left right)))))))) + +(defmethod print-object ((operator simple-operator) stream) + (maybe-print-unreadable-object (operator stream :type t) + (princ (operator-name operator) stream))) + +(defmethod shared-initialize :after + ((operator simple-binary-operator) slot-names &key) + (when (slot-boundp operator 'lprec) + (default-slot (operator 'rprec slot-names) + (slot-value operator 'lprec)))) + +(defmethod shared-initialize :after + ((operator simple-binary-operator) slot-names &key) + (when (slot-boundp operator 'lprec) + (default-slot (operator 'rprec slot-names) + (slot-value operator 'lprec)))) + +(defmethod push-operator + ((operator prefix-operator) (state expression-parse-state)) + + ;; It's not safe to apply stacked operators here. Already-stacked prefix + ;; operators won't have their operands yet, so we'll end up in an + ;; inconsistent state. + (with-slots (opstack) state + (push operator opstack))) + +(defmethod apply-operator + ((operator simple-unary-operator) (state expression-parse-state)) + (with-slots (function) operator + (with-slots (valstack) state + (assert (not (null valstack))) + (push (funcall function (pop valstack)) valstack)))) + +(defmethod apply-operator + ((operator simple-binary-operator) (state expression-parse-state)) + (with-slots (function) operator + (with-slots (valstack) state + (assert (not (or (null valstack) + (null (cdr valstack))))) + (let ((second (pop valstack)) + (first (pop valstack))) + (push (funcall function first second) valstack))))) + +;;;-------------------------------------------------------------------------- +;;; Parenthesis protocol implementation. + +(defmethod push-operator :after + ((paren open-parenthesis) (state expression-parse-state)) + (with-slots (nesting) state + (incf nesting))) + +(defmethod push-operator + ((paren close-parenthesis) (state expression-parse-state)) + (with-slots (opstack nesting) state + (with-slots (tag) paren + (flet ((fail () + (cerror* "Parse error: spurious `~A'" tag) + (return-from push-operator))) + (loop + (when (null opstack) (fail)) + (let ((head (car opstack))) + (cond ((not (typep head 'open-parenthesis)) + (apply-operator head state)) + ((not (eq (slot-value head 'tag) tag)) + (fail)) + (t + (return))) + (setf opstack (cdr opstack)))) + (setf opstack (cdr opstack)) + (decf nesting))))) + +(defmethod apply-operator + ((paren open-parenthesis) (state expression-parse-state)) + (with-slots (tag) paren + (cerror* "Parse error: missing `~A'" tag))) + +(defmethod operator-push-action (left (right open-parenthesis)) + :push) + +(defmethod operator-push-action ((left open-parenthesis) right) + :push) + +;;;-------------------------------------------------------------------------- +;;; Main expression parser implementation. + +(defun parse-expression (p-operand p-binop p-preop p-postop) + (let ((state (make-instance 'expression-parse-state)) + (consumed-any-p nil)) + + (labels ((fail (expected) + (return-from parse-expression + (values expected nil consumed-any-p))) + + (parse (parser) + (unless parser + (return-from parse (values nil nil))) + (multiple-value-bind (value winp consumedp) + (funcall parser (plusp (slot-value state 'nesting))) + (when consumedp (setf consumed-any-p t)) + (unless (or winp (not consumedp)) (fail value)) + (values value winp))) + + (get-operand () + (loop (multiple-value-bind (value winp) (parse p-preop) + (unless winp (return)) + (push-operator value state))) + (multiple-value-bind (value winp) (parse p-operand) + (unless winp (fail value)) + (push-value value state)) + (loop (multiple-value-bind (value winp) (parse p-postop) + (unless winp (return)) + (push-operator value state))))) + + (get-operand) + (loop + (multiple-value-bind (value winp) (parse p-binop) + (unless winp (return)) + (push-operator value state)) + (get-operand)) + + (values (apply-pending-operators state) t consumed-any-p)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-parser-plug.lisp b/src/parser/impl-parser-plug.lisp new file mode 100644 index 0000000..9af84f6 --- /dev/null +++ b/src/parser/impl-parser-plug.lisp @@ -0,0 +1,31 @@ +;;; -*-lisp-*- +;;; +;;; Pluggable extensable parser +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-parser.lisp b/src/parser/impl-parser.lisp new file mode 100644 index 0000000..0a7d667 --- /dev/null +++ b/src/parser/impl-parser.lisp @@ -0,0 +1,166 @@ +;;; -*-lisp-*- +;;; +;;; Parser protocol implementation. +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Hairy functions used by parser syntax expanders. + +(declaim (inline %many)) +(defun %many (update final parser &key (min 0) max) + "Helper function for the `many' parser syntax. + + This deals with simple repetition, without separators. See the parser + syntax documentation for details." + + (let ((consumed-any-p nil)) + (do ((i 0 (1+ i))) + ((and max (>= i max))) + (multiple-value-bind (value winp consumep) (funcall parser) + (when consumep (setf consumed-any-p t)) + (cond (winp (funcall update value)) + ((or consumep (< i min)) + (return-from %many (values value nil consumed-any-p))) + (t (return))))) + (values (funcall final) t consumed-any-p))) + +(defun %many-sep (update final parser sep &key (min 1) max (commitp t)) + "Helper function for the `many' parser syntax. + + This deals with the hairy separator and commit stuff. See the parser + syntax documentation for details." + + (let ((consumed-any-p nil) + (i 0)) + (block nil + (flet ((sep () + (multiple-value-bind (value winp consumep) (funcall sep) + (when consumep (setf consumed-any-p t)) + (unless winp + (if (and (>= i min) (not consumep)) (return) + (return-from %many-sep + (values value nil consumed-any-p)))))) + + (main (mustp) + (multiple-value-bind (value winp consumep) (funcall parser) + (when consumep (setf consumed-any-p t)) + (cond (winp (funcall update value)) + ((or mustp consumep (< i min)) + (return-from %many-sep + (values value nil consumed-any-p))) + (t (return)))) + (incf i))) + + (when (eql max 0) (return)) + + (main nil) + + (if commitp + (loop (when (and max (>= i max)) (return)) (sep) (main t)) + (loop (sep) (when (and max (>= i max)) (return)) (main nil))))) + + (values (funcall final) t consumed-any-p))) + +;;;-------------------------------------------------------------------------- +;;; Token parser implementation. + +(defmethod parser-at-eof-p ((context token-parser-context)) + `(eq ,(parser-token-type context) :eof)) + +;;;-------------------------------------------------------------------------- +;;; Simple list-based parser; useful for testing. + +(export 'list-parser) +(defclass list-parser () + ((var :initarg :var :type symbol :reader parser-var))) + +(defmethod parser-at-eof-p ((context list-parser)) + `(not ,(parser-var context))) + +(defmethod parser-capture-place ((context list-parser)) + `,(parser-var context)) + +(defmethod parser-restore-place ((context list-parser) place) + `(setf ,(parser-var context) ,place)) + +(defmethod expand-parser-spec ((context list-parser) parser) + (if (atom parser) + (expand-parser-form context 'quote (list parser)) + (call-next-method))) + +(defparse quote (:context (context list-parser) object) + `(if (and ,(parser-var context) + (eql (car ,(parser-var context)) ',object)) + (progn (pop ,(parser-var context)) (values ',object t t)) + (values (list ',object) nil nil))) + +(defparse type (:context (context list-parser) type) + `(if (and ,(parser-var context) + (typep (car ,(parser-var context)) ',type)) + (values (pop ,(parser-var context)) t t) + (values (list ',type) nil nil))) + +(defmethod parser-places-must-be-released-p ((context list-parser)) nil) + +;;;-------------------------------------------------------------------------- +;;; Simple string-based parser; useful for testing. + +(export 'string-parser) +(defclass string-parser (character-parser-context) + ((string :initarg :string :reader parser-string) + (index :initarg :index :initform 0 :reader parser-index) + (length :initform (gensym "LEN-") :reader parser-length))) + +(defmethod wrap-parser ((context string-parser) form) + (with-slots (string index length) context + `(let* (,@(unless (symbolp string) + (let ((s string)) + (setf string (gensym "STRING-")) + `((,string ,s)))) + ,@(unless (symbolp index) + (let ((i index)) + (setf index (gensym "INDEX-")) + `((,index ,i)))) + (,length (length ,string))) + ,form))) + +(defmethod parser-at-eof-p ((context string-parser)) + `(>= ,(parser-index context) ,(parser-length context))) + +(defmethod parser-current-char ((context string-parser)) + `(char ,(parser-string context) ,(parser-index context))) + +(defmethod parser-step ((context string-parser)) + `(incf ,(parser-index context))) + +(defmethod parser-capture-place ((context string-parser)) + `,(parser-index context)) + +(defmethod parser-restore-place ((context string-parser) place) + `(setf ,(parser-index context) ,place)) + +(defmethod parser-places-must-be-released-p ((context string-parser)) nil) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-scanner-charbuf.lisp b/src/parser/impl-scanner-charbuf.lisp new file mode 100644 index 0000000..aaa1b5a --- /dev/null +++ b/src/parser/impl-scanner-charbuf.lisp @@ -0,0 +1,433 @@ +;;; -*-lisp-*- +;;; +;;; Efficient buffering character scanner +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Infrastructure types. + +(defconstant charbuf-size 4096 + "Number of characters in a character buffer.") + +(deftype charbuf () + "Type of character buffers." + `(simple-string ,charbuf-size)) + +(deftype charbuf-index () + "Type of indices into character buffers." + `(integer 0 ,charbuf-size)) + +(declaim (inline make-charbuf)) +(defun make-charbuf () + "Return a fresh uninitialized character buffer." + (make-array charbuf-size :element-type 'character)) + +(defstruct charbuf-chain-link + "A link in the charbuf scanner's buffer chain. + + Usually the scanner doesn't bother maintaining a buffer chain; but if + we've rewound to a captured place then we need to be able to retrace our + steps on to later buffers. + + It turns out to be easier to have an explicit link to the next structure + in the chain than to maintain a spine of cons cells, so we do that; the + only other things we need are the buffer itself and its length, which + might be shorter than `charbuf-size', e.g., if we hit end-of-file." + (next nil :type (or charbuf-chain-link null)) + (buf nil :type (or charbuf (member nil :eof)) :read-only t) + (size 0 :type charbuf-index :read-only t)) + +(export 'charbuf-scanner-place-p) +(defstruct charbuf-scanner-place + "A captured place we can return to later. + + We remember the buffer-chain link, so that we can retrace our steps up to + the present. We also need the index at which we continue reading + characters; and the line and column numbers to resume from." + (link nil :type charbuf-chain-link :read-only t) + (index 0 :type charbuf-index :read-only t) + (line 0 :type fixnum :read-only t) + (column 0 :type fixnum :read-only t)) + +;;;-------------------------------------------------------------------------- +;;; Main class. + +(export 'charbuf-scanner) +(defclass charbuf-scanner (character-scanner) + ((stream :initarg :stream :type stream) + (buf :initform nil :type (or charbuf (member nil :eof))) + (size :initform 0 :type (integer 0 #.charbuf-size)) + (index :initform 0 :type (integer 0 #.charbuf-size)) + (captures :initform 0 :type (and fixnum unsigned-byte)) + (tail :initform nil :type (or charbuf-chain-link null)) + (unread :initform nil :type (or charbuf-chain-link nil)) + (filename :initarg :filename :type (or string null) + :reader scanner-filename) + (line :initarg line :initform 1 :type fixnum :reader scanner-line) + (column :initarg :column :initform 0 :type fixnum :reader scanner-column)) + (:documentation + "An efficient rewindable scanner for character streams. + + The scanner should be used via the parser protocol. The following notes + describe the class's slots and the invariants maintained by the class. + + The scanner reads characters from STREAM. It reads in chunks, + `charbuf-size' characters at a time, into freshly allocated arrays. At + the beginning of time, BUF is nil; and SIZE is 0, indicating that a new + buffer needs to be read in; this anomalous situation is remedied during + instance initialization. At all times thereafter: + + * If SIZE > 0 then BUF is a `charbuf' containing characters. + + * (<= 0 INDEX SIZE charbuf-size). + + When the current buffer is finished with, another one is fetched. If + we've rewound the scanner to a captured place, then there'll be a chain of + buffers starting at TAIL (which corresponds to the current buffer); and we + should use its NEXT buffer when we've finished this one. + + If there is no next buffer then we should acquire a new one and fill it + from the input stream. If there is an outstanding captured place then we + must also create a buffer chain entry for this new buffer and link it onto + the chain. If there aren't outstanding captures then we don't need to + bother with any of that -- earlier places certainly can't be captured and + a capture of the current position can allocate its own buffer chain + entry. + + Which leaves us with the need to determine whether there are outstanding + captures. We simply maintain a counter, and rely on the client releasing + captured places properly when he's finished. In practice, this is usually + done using the `peek' parser macro so there isn't a problem.")) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defgeneric charbuf-scanner-fetch (scanner) + (:documentation + "Refill the scanner buffer. + + This is an internal method, which is really only a method so that the + compiler will optimize slot references. + + Replace the current buffer with the next one, either from the buffer chain + (if we're currently rewound) or with a new buffer from the stream.")) + +(defmethod charbuf-scanner-fetch ((scanner charbuf-scanner)) + (with-slots (stream buf size index tail captures) scanner + (loop + (acond + + ;; If we've hit the end of the line, stop. + ((eq buf :eof) + (return nil)) + + ;; If there's another buffer, we should check it out. + ((and tail (charbuf-chain-link-next tail)) + (setf tail it + buf (charbuf-chain-link-buf it) + size (charbuf-chain-link-size it) + index 0)) + + ;; No joy: try reading more stuff from the input stream. + (t + (let* ((new (make-charbuf)) + (n (read-sequence new stream :start 0 :end charbuf-size))) + + ;; If there's nothing coming in then store a magical marker. + (when (zerop n) (setf new :eof)) + + ;; If there's someone watching, link a new entry onto the chain. + ;; There must, under these circumstances, be a `tail'. + (if (plusp captures) + (let ((next (make-charbuf-chain-link :buf new :size n))) + (setf (charbuf-chain-link-next tail) next + tail next)) + (setf tail nil)) + + ;; Store the new state. + (setf buf new + size n + index 0)))) + + ;; If there's stuff in the current buffer, we're done. + (when (< index size) + (return t))))) + +(export 'charbuf-scanner-map) +(defgeneric charbuf-scanner-map (scanner func &optional fail) + (:documentation + "Read characters from the SCANNER's raw buffers. + + This is intended to be an efficient and versatile interface for reading + characters from a scanner in bulk. The FUNC is invoked repeatedly with + three arguments: a simple string BUF and two nonnegative fixnums START and + END, indicating that the subsequence of BUF between START (inclusive) and + END (exclusive) should be processed. The FUNC returns two values: a + generalized boolean DONEP and a nonnegative fixnum USED. If DONEP is + false then USED is ignored: the function has consumed the entire buffer + and wishes to read more. If DONEP is true then the condition (<= START + USED END) must hold; the FUNC has consumed the buffer as far as USED + (exclusive) and has completed successfully; the values DONEP and `t' are + returned as the result of CHARBUF-SCANNER-MAP. + + If end-of-file is encountered before FUNC completes successfully then FAIL + is called with no arguments, and CHARBUF-SCANNER-MAP returns whatever + FAIL returns. + + Observe that, if FAIL returns a second value of nil, then + `charbuf-scanner-map' is usable as a parser expression.")) + +(defmethod charbuf-scanner-map + ((scanner charbuf-scanner) func &optional fail) + (with-slots (buf index size) scanner + (flet ((offer (buf start end) + + ;; Pass the buffer to the function, and see what it thought. + (multiple-value-bind (donep used) (funcall func buf start end) + + ;; Update the position as far as the function read. + (with-slots (line column) scanner + (let ((l line) (c column) (limit (if donep used end))) + (do ((i start (1+ i))) + ((>= i limit)) + (setf (values l c) + (update-position (char buf i) l c))) + (setf line l column c))) + + ;; If the function is finished then update our state and + ;; return. + (when donep + (setf index used) + (when (>= index size) + (charbuf-scanner-fetch scanner)) + (return-from charbuf-scanner-map (values donep t)))))) + + ;; If there's anything in the current buffer, offer it to the function. + (when (< index size) + (offer buf index size)) + + ;; Repeatedly fetch new buffers and offer them to the function. + ;; Because the buffers are fresh, we know that we must process them + ;; from the beginning. Note that `offer' will exit if FUNC has + ;; finished, so we don't need to worry about that. + (loop + (unless (charbuf-scanner-fetch scanner) + (return (if fail (funcall fail) (values nil nil)))) + (offer buf 0 size))))) + +;;;-------------------------------------------------------------------------- +;;; Initialization. + +(defmethod shared-initialize :after + ((scanner charbuf-scanner) slot-names &key) + + ;; Grab the filename from the underlying stream if we don't have a better + ;; guess. + (default-slot (scanner 'filename slot-names) + (with-slots (stream) scanner + (aif (stream-pathname stream) (namestring it) nil))) + + ;; Get ready with the first character. + (charbuf-scanner-fetch scanner)) + +;;;-------------------------------------------------------------------------- +;;; Scanner protocol implementation. + +(defmethod scanner-at-eof-p ((scanner charbuf-scanner)) + (with-slots (buf) scanner + (eq buf :eof))) + +(defmethod scanner-current-char ((scanner charbuf-scanner)) + (with-slots (buf index) scanner + (schar buf index))) + +(defmethod scanner-step ((scanner charbuf-scanner)) + (with-slots (buf size index line column) scanner + + ;; If there's a current character then update the position from it. When + ;; is there a current character? When the index is valid. + (when (< index size) + (setf (values line column) + (update-position (schar buf index) line column))) + + ;; Now move the position on. If there's still a character left then we + ;; win; otherwise fetch another buffer. + (or (< (incf index) size) + (charbuf-scanner-fetch scanner)))) + +(defmethod scanner-unread ((scanner charbuf-scanner) char) + (with-slots (buf index size unread tail line column) scanner + (cond + + ;; First, let's rewind the buffer index. This isn't going to work if + ;; the index is already zero. (Note that this implies that INDEX is + ;; zero in the remaining cases.) + ((plusp index) + (decf index)) + + ;; Plan B. Maybe we've been here before, in which case we'll have left + ;; the appropriate state kicking about already. Note that, according + ;; to the `unread' rules, the character must be the same as last time, + ;; so we can just reuse the whole thing unchanged. Also, note that + ;; the NEXT field in UNREAD is not nil due to the way that we construct + ;; the link below. + ((and unread (eql (charbuf-chain-link-next unread) tail)) + (setf tail unread size 1 + buf (charbuf-chain-link-buf unread))) + + ;; Nope, we've not been here, at least not recently. We'll concoct a + ;; new buffer and put the necessary stuff in it. Store it away for + ;; later so that repeated read/unread oscillations at this position + ;; don't end up consing enormous arrays too much. + (t + (let* ((next (or tail (make-charbuf-chain-link :buf buf :size size))) + (fake (make-charbuf)) + (this (make-charbuf-chain-link :buf fake :size 1 :next next))) + (setf (schar fake 0) char buf fake size 1 + tail this unread this)))) + + ;; That's that sorted; now we have to fiddle the position. + (setf (values line column) (backtrack-position char line column)))) + +(defmethod scanner-capture-place ((scanner charbuf-scanner)) + (with-slots (buf size index captures tail line column) scanner + (incf captures) + (unless tail + (setf tail (make-charbuf-chain-link :buf buf :size size))) + (make-charbuf-scanner-place :link tail :index index + :line line :column column))) + +(defmethod scanner-restore-place ((scanner charbuf-scanner) place) + (with-slots (buf size index tail line column) scanner + (let ((link (charbuf-scanner-place-link place))) + (setf buf (charbuf-chain-link-buf link) + size (charbuf-chain-link-size link) + index (charbuf-scanner-place-index place) + line (charbuf-scanner-place-line place) + column (charbuf-scanner-place-column place) + tail link)))) + +(defmethod scanner-release-place ((scanner charbuf-scanner) place) + (with-slots (captures) scanner + (decf captures))) + +(defstruct (charbuf-slice + (:constructor make-charbuf-slice + (buf &optional (start 0) %end + &aux (end (or %end (length buf)))))) + (buf nil :type (or charbuf (eql :eof)) :read-only t) + (start 0 :type (and fixnum unsigned-byte) :read-only t) + (end 0 :type (and fixnum unsigned-byte) :read-only t)) + +(declaim (inline charbuf-slice-length)) +(defun charbuf-slice-length (slice) + (- (charbuf-slice-end slice) (charbuf-slice-start slice))) + +(defun concatenate-charbuf-slices (slices) + (let* ((len (reduce #'+ slices + :key #'charbuf-slice-length + :initial-value 0)) + (string (make-array len :element-type 'character)) + (i 0)) + (dolist (slice slices) + (let ((buf (charbuf-slice-buf slice)) + (end (charbuf-slice-end slice))) + (do ((j (charbuf-slice-start slice) (1+ j))) + ((>= j end)) + (setf (schar string i) (schar buf j)) + (incf i)))) + string)) + +(defmethod scanner-interval + ((scanner charbuf-scanner) place-a &optional place-b) + (let* ((slices nil) + (place-b (or place-b + (with-slots (index tail) scanner + (make-charbuf-scanner-place :link tail + :index index)))) + (last-link (charbuf-scanner-place-link place-b))) + (flet ((bad () + (error "Incorrect places ~S and ~S to SCANNER-INTERVAL." + place-a place-b))) + (do ((link (charbuf-scanner-place-link place-a) + (charbuf-chain-link-next link)) + (start (charbuf-scanner-place-index place-a) 0)) + ((eq link last-link) + (let ((end (charbuf-scanner-place-index place-b))) + (when (< end start) + (bad)) + (push (make-charbuf-slice (charbuf-chain-link-buf link) + start end) + slices) + (concatenate-charbuf-slices (nreverse slices)))) + (when (null link) (bad)) + (push (make-charbuf-slice (charbuf-chain-link-buf link) + start + (charbuf-chain-link-size link)) + slices))))) + +;;;-------------------------------------------------------------------------- +;;; Specialized streams. + +(export 'charbuf-scanner-stream) +(defclass charbuf-scanner-stream (character-scanner-stream) + ((scanner :initarg :scanner :type charbuf-scanner))) + +(defmethod stream-read-sequence + ((stream charbuf-scanner-stream) (seq string) &optional (start 0) end) + (with-slots (scanner) stream + (unless end (setf end (length seq))) + (let ((i start) (n (- end start))) + (labels ((copy (i buf start end) + (do ((j i (1+ j)) + (k start (1+ k))) + ((>= k end)) + (setf (char seq j) (schar buf k)))) + (snarf (buf start end) + (let ((m (- end start))) + (cond ((< m n) + (copy i buf start end) (decf n m) (incf i m) + (values nil 0)) + (t + (copy i buf start (+ start n)) (incf i n) + (values t n)))))) + (charbuf-scanner-map scanner #'snarf) + i)))) + +(defmethod stream-read-line ((stream charbuf-scanner-stream)) + (with-slots (scanner) stream + (let ((slices nil)) + (flet ((snarf (buf start end) + (let ((pos (position #\newline buf :start start :end end))) + (push (make-charbuf-slice buf start (or pos end)) slices) + (if pos + (values (concatenate-charbuf-slices (nreverse slices)) + (1+ pos)) + (values nil 0)))) + (fail () + (values (concatenate-charbuf-slices (nreverse slices)) t))) + (charbuf-scanner-map scanner #'snarf #'fail))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-scanner-context.lisp b/src/parser/impl-scanner-context.lisp new file mode 100644 index 0000000..cbedd31 --- /dev/null +++ b/src/parser/impl-scanner-context.lisp @@ -0,0 +1,88 @@ +;;; -*-lisp-*- +;;; +;;; Parser contexts for scanners +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Basic scanner behaviour. + +;; Basic scanners. + +(defmethod parser-step ((context scanner-context)) + `(scanner-step ,(parser-scanner context))) + +(defmethod parser-at-eof-p ((context scanner-context)) + `(scanner-at-eof-p ,(parser-scanner context))) + +(defmethod parser-capture-place ((context scanner-context)) + `(scanner-capture-place ,(parser-scanner context))) + +(defmethod parser-restore-place ((context scanner-context) place) + `(scanner-restore-place ,(parser-scanner context) ,place)) + +(defmethod parser-release-place ((context scanner-context) place) + `(scanner-release-place ,(parser-scanner context) ,place)) + +;; Character scanners. + +(defmethod parser-current-char ((context character-scanner-context)) + `(scanner-current-char ,(parser-scanner context))) + +;; Token scanners. + +(defmethod parser-token-type ((context token-scanner-context)) + `(token-type ,(parser-scanner context))) + +(defmethod parser-token-value ((context token-scanner-context)) + `(token-value ,(parser-scanner context))) + +;;;-------------------------------------------------------------------------- +;;; Contexts for specific scanner classes. + +;; String scanner. + +(defclass string-scanner-context (character-scanner-context) + () + (:documentation + "Specialized parser context for scanning strings. + + Most notably, string positions don't need to be released, which means that + the expanded code doesn't need to do install `unwind-protect' handlers.")) + +(defmethod parser-places-must-be-released-p + ((context string-scanner-context)) + nil) + +;; List scanner. + +(defclass list-scanner-context (token-scanner-context) + () + (:documentation + "Specialized scanner contexts for the list scanner.")) + +(defmethod parser-places-must-be-released-p ((context list-scanner-context)) + nil) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-scanner-token.lisp b/src/parser/impl-scanner-token.lisp new file mode 100644 index 0000000..e058b27 --- /dev/null +++ b/src/parser/impl-scanner-token.lisp @@ -0,0 +1,78 @@ +;;; -*-lisp-*- +;;; +;;; Tokenizing scanner +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Token scanner implementation. + +(defmethod shared-initialize :after + ((scanner token-scanner) slot-names &key) + (declare (ignore slot-names)) + (scanner-step scanner)) + +(defmethod scanner-at-eof-p ((scanner token-scanner)) + (with-slots (type) scanner + (eq type :eof))) + +(defmethod scanner-step ((scanner token-scanner)) + (with-slots (type value tail captures line column) scanner + (cond (tail + (let ((next (token-scanner-place-next tail))) + (setf type (token-scanner-place-type next) + value (token-scanner-place-value next) + line (token-scanner-place-line next) + column (token-scanner-place-column next) + tail next))) + (t + (multiple-value-bind (ty val) (scanner-token scanner) + (setf type ty + value val) + (when (plusp captures) + (let ((next (make-token-scanner-place + :type ty :value val :line line :column column))) + (setf (token-scanner-place-next tail) next + tail next)))))))) + +(defmethod scanner-capture-place ((scanner token-scanner)) + (with-slots (type value captures tail line column) scanner + (incf captures) + (or tail + (setf tail (make-token-scanner-place + :type type :value value :line line :column column))))) + +(defmethod scanner-restore-place ((scanner token-scanner) place) + (with-slots (type value tail line column) scanner + (setf type (token-scanner-place-type place) + value (token-scanner-place-value place) + line (token-scanner-place-line place) + column (token-scanner-place-column place) + tail place))) + +(defmethod scanner-release-place ((scanner token-scanner) place) + (with-slots (captures) scanner + (decf captures))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-scanner.lisp b/src/parser/impl-scanner.lisp new file mode 100644 index 0000000..aa8a98a --- /dev/null +++ b/src/parser/impl-scanner.lisp @@ -0,0 +1,120 @@ +;;; -*-lisp-*- +;;; +;;; Basic scanner interface +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Common scanner implementation.. + +(defmethod file-location ((scanner character-scanner)) + (scanner-file-location scanner)) + +;;;-------------------------------------------------------------------------- +;;; Streams on character scanners. + +(defmethod stream-read-char ((stream character-scanner-stream)) + (with-slots (scanner) stream + (if (scanner-at-eof-p scanner) + :eof + (prog1 (scanner-current-char scanner) + (scanner-step scanner))))) + +(defmethod stream-unread-char ((stream character-scanner-stream) char) + (with-slots (scanner) stream + (scanner-unread scanner char))) + +(defmethod stream-peek-char ((stream character-scanner-stream)) + (with-slots (scanner) stream + (scanner-current-char scanner))) + +;;;-------------------------------------------------------------------------- +;;; String scanner. + +;; This is much more convenient for testing lexers than the full character +;; buffer scanner. + +(export '(string-scanner make-string-scanner string-scanner-p)) +(defstruct (string-scanner + (:constructor make-string-scanner + (string &key (start 0) end + &aux (index start) + (limit (or end (length string)))))) + "Scanner structure for a simple string scanner." + (string "" :type string :read-only t) + (index 0 :type (and fixnum unsigned-byte)) + (limit nil :type (and fixnum unsigned-byte) :read-only t)) + +(defmethod scanner-at-eof-p ((scanner string-scanner)) + (>= (string-scanner-index scanner) (string-scanner-limit scanner))) + +(defmethod scanner-current-char ((scanner string-scanner)) + (char (string-scanner-string scanner) (string-scanner-index scanner))) + +(defmethod scanner-step ((scanner string-scanner)) + (incf (string-scanner-index scanner))) + +(defmethod scanner-capture-place ((scanner string-scanner)) + (string-scanner-index scanner)) + +(defmethod scanner-restore-place ((scanner string-scanner) place) + (setf (string-scanner-index scanner) place)) + +(defmethod scanner-interval + ((scanner string-scanner) place-a &optional place-b) + (with-slots (string index) scanner + (subseq string place-a (or place-b index)))) + +;;;-------------------------------------------------------------------------- +;;; List scanner. + +(export 'list-scanner) +(defstruct (list-scanner + (:constructor make-list-scanner (list))) + "Simple token scanner for lists. + + The list elements are the token semantic values; the token types are the + names of the elements' classes. This is just about adequate for testing + purposes, but is far from ideal for real use." + (list nil :type list)) + +(defmethod scanner-step ((scanner list-scanner)) + (pop (list-scanner-list scanner))) + +(defmethod scanner-at-eof-p ((scanner list-scanner)) + (null (list-scanner-list scanner))) + +(defmethod token-type ((scanner list-scanner)) + (class-name (class-of (car (list-scanner-list scanner))))) + +(defmethod token-value ((scanner list-scanner)) + (car (list-scanner-list scanner))) + +(defmethod scanner-capture-place ((scanner list-scanner)) + (list-scanner-list scanner)) + +(defmethod scanner-restore-place ((scanner list-scanner) place) + (setf (list-scanner-list scanner) place)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/impl-streams.lisp b/src/parser/impl-streams.lisp new file mode 100644 index 0000000..6094b56 --- /dev/null +++ b/src/parser/impl-streams.lisp @@ -0,0 +1,382 @@ +;;; -*-lisp-*- +;;; +;;; Additional streams. +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Compatibility hacking. + +;; ECL is different and strange. In early versions (0.9j and thereabouts) +;; the Gray streams functions are in the SI package; CLOSE and STREAM- +;; ELEMENT-TYPE are not generic, and call the generic functions SI:STREAM- +;; CLOSE and SI:STREAM-ELT-TYPE if they find that they can't handle their +;; argument. The STREAM-CLOSE generic function doesn't have a method for the +;; built-in streams. In later versions (9.6.1 and thereabouts) the Gray +;; streams functions are in the GRAY package; CLOSE and STREAM-ELEMENT-TYPE +;; are still not generic, but now they call correspondingly-named generic +;; functions in GRAY, and the generic versions do cover the built-in streams. +;; +;; The right thing to, then, seems to be as follows. +;; +;; * ECL is the weird system, so we'll hack it to be less weird. Hacking +;; non-weird platforms seems wrong-headed. +;; +;; * Since SI:STREAM-CLOSE is missing a method which works on standard +;; streams, we should add one if we're running that version of ECL. +;; +;; * Then we can shadow CLOSE and drop SI:STREAM-CLOSE or GRAY:CLOSE over +;; the top. In the latter case, we can just do a SHADOWING-IMPORT; in +;; the latter, we'll need to mess with FDEFINITION. +;; +;; * We'll do something similar for STREAM-ELEMENT-TYPE. +;; +;; Note that the following are all separate top-level forms so that later +;; ones will be read with different symbols than earlier ones. This also +;; means that we can use the *FEATURES* mechanism and avoid lots of the +;; tedious messing about with FIND-SYMBOL. + +#+ecl +(eval-when (:compile-toplevel :load-toplevel :execute) + (if (find-package '#:gray) + (push :sod-ecl-broken-gray-streams *features*))) + +#+(and ecl (not sod-ecl-broken-gray-streams)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadowing-import '(gray:close gray:stream-element-type))) + +#+(and ecl sod-ecl-broken-gray-streams) +(eval-when (:compile-toplevel :load-toplevel :execute) + (shadow '(close stream-element-type))) +#+(and ecl sod-ecl-broken-gray-streams) +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf (fdefinition 'close) #'si:stream-close + (fdefinition 'stream-element-type #'si:stream-elt-type))) + +;;;-------------------------------------------------------------------------- +;;; Proxy streams. + +;; Base classes for proxy streams. + +(defclass proxy-stream (fundamental-stream) + ((ustream :initarg :stream :type stream + :reader position-aware-stream-underlying-stream)) + (:documentation + "Base class for proxy streams. + + A proxy stream is one that works by passing most of its work to an + underlying stream. We provide some basic functionality for the later + classes.")) + +(defmethod close ((stream proxy-stream) &key abort) + (with-slots (ustream) stream + (close ustream :abort abort))) + +(defmethod stream-element-type ((stream proxy-stream)) + (with-slots (ustream) stream + (stream-element-type ustream))) + +(defmethod stream-file-position + ((stream proxy-stream) &optional (position nil posp)) + (with-slots (ustream) stream + (if posp + (file-position ustream position) + (file-position ustream)))) + +(defmethod stream-pathname ((stream proxy-stream)) + (with-slots (ustream) stream + (stream-pathname ustream))) + +;; Base class for input streams. + +(defclass proxy-input-stream (proxy-stream fundamental-input-stream) + () + (:documentation + "Base class for proxy input streams.")) + +(defmethod stream-clear-input ((stream proxy-input-stream)) + (with-slots (ustream) stream + (clear-input ustream))) + +(defmethod stream-read-sequence + ((stream proxy-input-stream) seq &optional (start 0) end) + (with-slots (ustream) stream + (read-sequence seq ustream :start start :end end))) + +;; Base class for output streams. + +(defclass proxy-output-stream (proxy-stream fundamental-output-stream) + () + (:documentation + "Base class for proxy output streams.")) + +(defmethod stream-clear-output ((stream proxy-output-stream)) + (with-slots (ustream) stream + (clear-output ustream))) + +(defmethod stream-finish-output ((stream proxy-output-stream)) + (with-slots (ustream) stream + (finish-output ustream))) + +(defmethod stream-force-output ((stream proxy-output-stream)) + (with-slots (ustream) stream + (force-output ustream))) + +(defmethod stream-write-sequence + ((stream proxy-output-stream) seq &optional (start 0) end) + (with-slots (ustream) stream + (write-sequence seq ustream :start start :end end))) + +;; Character input streams. + +(defclass proxy-character-input-stream + (proxy-input-stream fundamental-character-input-stream) + () + (:documentation + "A character-input-stream which is a proxy for an existing stream. + + This doesn't actually change the behaviour of the underlying stream very + much, but it's a useful base to work on when writing more interesting + classes.")) + +(defmethod stream-read-char ((stream proxy-character-input-stream)) + (with-slots (ustream) stream + (read-char ustream nil :eof nil))) + +(defmethod stream-read-line ((stream proxy-character-input-stream)) + (with-slots (ustream) stream + (read-line ustream nil "" nil))) + +(defmethod stream-unread-char ((stream proxy-character-input-stream) char) + (with-slots (ustream) stream + (unread-char char ustream))) + +;; Character output streams. + +(defclass proxy-character-output-stream + (proxy-stream fundamental-character-output-stream) + () + (:documentation + "A character-output-stream which is a proxy for an existing stream. + + This doesn't actually change the behaviour of the underlying stream very + much, but it's a useful base to work on when writing more interesting + classes.")) + +(defmethod stream-line-column ((stream proxy-character-output-stream)) + nil) + +(defmethod stream-line-length ((stream proxy-character-output-stream)) + nil) + +(defmethod stream-terpri ((stream proxy-character-output-stream)) + (with-slots (ustream) stream + (terpri ustream))) + +(defmethod stream-write-char ((stream proxy-character-output-stream) char) + (with-slots (ustream) stream + (write-char char ustream))) + +(defmethod stream-write-string + ((stream proxy-character-output-stream) string &optional (start 0) end) + (with-slots (ustream) stream + (write-string string ustream :start start :end end))) + +;;;-------------------------------------------------------------------------- +;;; The position-aware stream. + +;; Base class. + +(export '(position-aware-stream + position-aware-stream-line position-aware-stream-column)) +(defclass position-aware-stream (proxy-stream) + ((file :initarg :file :initform nil + :type pathname :accessor position-aware-stream-file) + (line :initarg :line :initform 1 + :type fixnum :accessor position-aware-stream-line) + (column :initarg :column :initform 0 + :type fixnum :accessor position-aware-stream-column)) + (:documentation + "Character stream which keeps track of the line and column position. + + A position-aware-stream wraps an existing character stream and tracks the + line and column position of the current stream position. A newline + character increases the line number by one and resets the column number to + zero; most characters advance the column number by one, but tab advances + to the next multiple of eight. (This is consistent with Emacs, at least.) + The position can be read using STREAM-LINE-AND-COLUMN. + + This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or + POSITION-AWARE-OUTPUT-STREAM.")) + +(defgeneric stream-line-and-column (stream) + (:documentation + "Returns the current stream position of STREAM as line/column numbers. + + Returns two values: the line and column numbers of STREAM's input + position.") + (:method ((stream stream)) + (values nil nil)) + (:method ((stream position-aware-stream)) + (with-slots (line column) stream + (values line column)))) + +(defmethod stream-pathname ((stream position-aware-stream)) + "Return the pathname corresponding to a POSITION-AWARE-STREAM. + + A POSITION-AWARE-STREAM can be given an explicit pathname, which is + returned in preference to the pathname of the underlying stream. This is + useful in two circumstances. Firstly, the pathname associated with a file + stream will have been subjected to TRUENAME, and may be less pleasant to + present back to a user. Secondly, a name can be attached to a stream + which doesn't actually have a file backing it." + + (with-slots (file) stream + (or file (call-next-method)))) + +(defmethod file-location ((stream position-aware-stream)) + (multiple-value-bind (line column) (stream-line-and-column stream) + (make-file-location (stream-pathname stream) line column))) + +;; Utilities. + +(defmacro with-position ((stream) &body body) + "Convenience macro for tracking the read position. + + Within the BODY, the macro (update CHAR) is defined to update the STREAM's + position according to the character CHAR. + + The position is actually cached in local variables, but will be written + back to the stream even in the case of non-local control transfer from the + BODY. What won't work well is dynamically nesting WITH-POSITION forms." + + (with-gensyms (line column char) + (once-only (stream) + `(let* ((,line (position-aware-stream-line ,stream)) + (,column (position-aware-stream-column ,stream))) + (macrolet ((update (,char) + ;; This gets a little hairy. Hold tight. + `(multiple-value-setq (,',line ,',column) + (update-position ,,char ,',line ,',column)))) + (unwind-protect + (progn ,@body) + (setf (position-aware-stream-line ,stream) ,line + (position-aware-stream-column ,stream) ,column))))))) + +;; Input stream. + +(export 'position-aware-input-stream) +(defclass position-aware-input-stream + (position-aware-stream proxy-character-input-stream) + () + (:documentation + "A character input stream which tracks the input position. + + This is particularly useful for parsers and suchlike, which want to + produce accurate error-location information.")) + +(defmethod stream-unread-char ((stream position-aware-input-stream) char) + + ;; I could have written this as a :before or :after method, but I think + ;; this is the right answer. All of the other methods have to be primary + ;; (or around) methods, so at least it's consistent. + (with-slots (line column) stream + (setf (values line column) (backtrack-position char line column))) + (call-next-method)) + +(defmethod stream-read-sequence + ((stream position-aware-input-stream) seq &optional (start 0) end) + (declare (ignore end)) + (let ((pos (call-next-method))) + (with-position (stream) + (dosequence (ch seq :start start :end pos) + (update ch))) + pos)) + +(defmethod stream-read-char ((stream position-aware-input-stream)) + (let ((char (call-next-method))) + (with-position (stream) + (update char)) + char)) + +(defmethod stream-read-line ((stream position-aware-input-stream)) + (multiple-value-bind (line eofp) (call-next-method) + (if eofp + (with-position (stream) + (dotimes (i (length line)) + (update (char line i)))) + (with-slots (line column) stream + (incf line) + (setf column 0))) + (values line eofp))) + +;; Output stream. + +(export 'position-aware-output-stream) +(defclass position-aware-output-stream + (position-aware-stream proxy-character-output-stream) + () + (:documentation + "A character output stream which tracks the output position. + + This is particularly useful when generating C code: the position can be + used to generate `#line' directives referring to the generated code after + insertion of some user code.")) + +(defmethod stream-write-sequence + ((stream position-aware-output-stream) seq &optional (start 0) end) + (with-position (stream) + (dosequence (ch seq :start start :end end) + (update ch)) + (call-next-method))) + +(defmethod stream-line-column ((stream position-aware-output-stream)) + (with-slots (column) stream + column)) + +(defmethod stream-start-line-p ((stream position-aware-output-stream)) + (with-slots (column) stream + (zerop column))) + +(defmethod stream-terpri ((stream position-aware-output-stream)) + (with-slots (line column) stream + (incf line) + (setf column 0)) + (call-next-method)) + +(defmethod stream-write-char ((stream position-aware-output-stream) char) + (with-position (stream) + (update char)) + (call-next-method)) + +(defmethod stream-write-string + ((stream position-aware-output-stream) string &optional (start 0) end) + (with-position (stream) + (do ((i start (1+ i)) + (end (or end (length string)))) + ((>= i end)) + (update (char string i)))) + (call-next-method)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/opprec.lisp b/src/parser/opprec.lisp new file mode 100644 index 0000000..2f1f728 --- /dev/null +++ b/src/parser/opprec.lisp @@ -0,0 +1,6 @@ +;;; operator precedence parser hacking + +(in-package #:sod-parser) + +;;;-------------------------------------------------------------------------- +;;; Testing. diff --git a/package.lisp b/src/parser/package.lisp similarity index 82% rename from package.lisp rename to src/parser/package.lisp index 92e6a0c..6439f62 100644 --- a/package.lisp +++ b/src/parser/package.lisp @@ -1,13 +1,13 @@ ;;; -*-lisp-*- ;;; -;;; Package definition for SOD utility +;;; Package definition for the Sod parser infrastructure ;;; ;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Simple Object Definition system. +;;; This file is part of the Sensble 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 @@ -23,14 +23,9 @@ ;;; along with SOD; if not, write to the Free Software Foundation, ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. -(cl:defpackage #:sod +(cl:defpackage #:sod-parser (:use #:common-lisp - - ;; Find the meta-object protocol. Our demands are not particularly - ;; heavy. - #+sbcl #:sb-mop - #+(or cmu clisp) #:mop - #+ecl #:mop + #:sod-utilities ;; Try to find Gray streams support from somewhere. ECL tucks them ;; somewhere unhelpful. @@ -40,5 +35,4 @@ #+clisp #:gray #-(or sbcl cmu ecl clisp) ...)) - ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/proto-floc.lisp b/src/parser/proto-floc.lisp new file mode 100644 index 0000000..9e246ab --- /dev/null +++ b/src/parser/proto-floc.lisp @@ -0,0 +1,299 @@ +;;; -*-lisp-*- +;;; +;;; Protocol for file locations +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; File location objects. + +(export '(file-location make-file-location file-location-p + file-location-filename file-location-line file-location-column)) +(defstruct (file-location + (:constructor make-file-location + (%filename line column + &aux (filename + (etypecase %filename + ((or string null) %filename) + (pathname (namestring %filename))))))) + "A simple structure containing file location information. + + Construct using MAKE-FILE-LOCATION; the main useful function is + ERROR-FILE-LOCATION." + (filename nil :type (or string null) :read-only t) + (line nil :type (or fixnum null) :read-only t) + (column nil :type (or fixnum null) :read-only t)) + +(defgeneric file-location (thing) + (:documentation + "Convert THING into a FILE-LOCATION, if possible. + + A THING which can be converted into a FILE-LOCATION is termed a + `file-location designator'.") + (:method ((thing file-location)) thing)) + +;;;-------------------------------------------------------------------------- +;;; Enclosing conditions. + +(export '(enclosing-condition enclosed-condition)) +(define-condition enclosing-condition (condition) + ((enclosed-condition :initarg :condition :type condition + :reader enclosed-condition)) + (:documentation + "A condition which encloses another condition + + This is useful if one wants to attach additional information to an + existing condition. The enclosed condition can be obtained using the + ENCLOSED-CONDITION function.") + (:report (lambda (condition stream) + (princ (enclosed-condition condition) stream)))) + +;;;-------------------------------------------------------------------------- +;;; Conditions with location information. + +(export 'condition-with-location) +(define-condition condition-with-location (condition) + ((location :initarg :location :reader file-location :type file-location)) + (:documentation + "A condition which has some location information attached.")) + +(export 'enclosing-condition-with-location) +(define-condition enclosing-condition-with-location + (condition-with-location enclosing-condition) + ()) + +(export 'error-with-location) +(define-condition error-with-location (condition-with-location error) + ()) + +(export 'warning-with-location) +(define-condition warning-with-location (condition-with-location warning) + ()) + +(export 'enclosing-error-with-location) +(define-condition enclosing-error-with-location + (enclosing-condition-with-location error) + ()) + +(export 'enclosing-warning-with-location) +(define-condition enclosing-warning-with-location + (enclosing-condition-with-location warning) + ()) + +(export 'simple-condition-with-location) +(define-condition simple-condition-with-location + (condition-with-location simple-condition) + ()) + +(export 'simple-error-with-location) +(define-condition simple-error-with-location + (error-with-location simple-error) + ()) + +(export 'simple-warning-with-location) +(define-condition simple-warning-with-location + (warning-with-location simple-warning) + ()) + +;;;-------------------------------------------------------------------------- +;;; Reporting errors. + +(export 'make-condition-with-location) +(defun make-condition-with-location (default-type floc datum &rest arguments) + "Construct a CONDITION-WITH-LOCATION given a condition designator. + + The returned condition will always be a CONDITION-WITH-LOCATION. The + process consists of two stages. In the first stage, a condition is + constructed from the condition designator DATUM and ARGUMENTS with default + type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM: + + * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an + empty list. + + * If DATUM is a symbol, then it must name a condition type. An instance + of this class is constructed using ARGUMENTS as initargs, i.e., as + if (apply #'make-condition ARGUMENTS); if the type is a subtype of + CONDITION-WITH-LOCATION then FLOC is attached as the location. + + * If DATUM is a format control (i.e., a string or function), then the + condition is constructed as if, instead, DEFAULT-TYPE had been + supplied as DATUM, and the list (:format-control DATUM + :format-arguments ARGUMENTS) supplied as ARGUMENTS. + + In the second stage, the condition constructed by the first stage is + converted into a CONDITION-WITH-LOCATION. If the condition already has + type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is + wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION: + if the condition was a subtype of ERROR or WARNING then the resulting + condition will also be subtype of ERROR or WARNING as appropriate." + + (labels ((wrap (condition) + (make-condition + (etypecase condition + (error 'enclosing-error-with-location) + (warning 'enclosing-warning-with-location) + (condition 'enclosing-condition-with-location)) + :condition condition + :location (file-location floc))) + (make (type &rest initargs) + (if (subtypep type 'condition-with-location) + (apply #'make-condition type + :location (file-location floc) + initargs) + (wrap (apply #'make-condition type initargs))))) + (etypecase datum + (condition-with-location datum) + (condition (wrap datum)) + (symbol (apply #'make arguments)) + ((or string function) (make default-type + :format-control datum + :format-arguments arguments))))) + +(export 'error-with-location) +(defun error-with-location (floc datum &rest arguments) + "Report an error with attached location information." + (error (apply #'make-condition-with-location + 'simple-error-with-location + floc datum arguments))) + +(export 'warn-with-location) +(defun warn-with-location (floc datum &rest arguments) + "Report a warning with attached location information." + (warn (apply #'make-condition-with-location + 'simple-warning-with-location + floc datum arguments))) + +(export 'cerror-with-location) +(defun cerror-with-location (floc continue-string datum &rest arguments) + "Report a continuable error with attached location information." + (cerror continue-string + (apply #'make-condition-with-location + 'simple-error-with-location + floc datum arguments))) + +(export 'cerror*) +(defun cerror* (datum &rest arguments) + (apply #'cerror "Continue" datum arguments)) + +(export 'cerror*-with-location) +(defun cerror*-with-location (floc datum &rest arguments) + (apply #'cerror-with-location floc "Continue" datum arguments)) + +;;;-------------------------------------------------------------------------- +;;; Stamping errors with location information. + +(defun with-default-error-location* (floc thunk) + "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and + other conditions) which do not have file location information attached to + them already. + + See the WITH-DEFAULT-ERROR-LOCATION macro for more details." + + (if floc + (handler-bind + ((condition-with-location + (lambda (condition) + (declare (ignore condition)) + :decline)) + (condition + (lambda (condition) + (signal (make-condition-with-location nil floc condition))))) + (funcall thunk)) + (funcall thunk))) + +(export 'with-default-error-location) +(defmacro with-default-error-location ((floc) &body body) + "Evaluate BODY, as an implicit progn, in a dynamic environment which + attaches FLOC to errors (and other conditions) which do not have file + location information attached to them already. + + If a condition other than a CONDITION-WITH-LOCATION is signalled during + the evaluation of the BODY, then an instance of an appropriate subcalass + of ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the + original condition, and signalled. In particular, if the original + condition was a subtype of ERROR or WARNING, then the new condition will + also be a subtype of ERROR or WARNING as appropriate. + + The FLOC argument is coerced to a FILE-LOCATION object each time a + condition is signalled. For example, if FLOC is a lexical analyser object + which reports its current position in response to FILE-LOCATION, then each + condition will be reported as arising at the lexer's current position at + that time, rather than all being reported at the same position. + + If the new enclosing condition is not handled, the handler established by + this macro will decline to handle the original condition. Typically, + however, the new condition will be handled by COUNT-AND-REPORT-ERRORS. + + As a special case, if FLOC is nil, then no special action is taken, and + BODY is simply evaluated, as an implicit progn." + + `(with-default-error-location* ,floc (lambda () ,@body))) + +;;;-------------------------------------------------------------------------- +;;; Front-end error reporting. + +(defun count-and-report-errors* (thunk) + "Invoke THUNK in a dynamic environment which traps and reports errors. + + See the COUNT-AND-REPORT-ERRORS macro for more detais." + + (let ((errors 0) + (warnings 0)) + (handler-bind + ((error (lambda (error) + (let ((fatal (not (find-restart 'continue error)))) + (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%" + (file-location error) + fatal + error) + (incf errors) + (if fatal + (return-from count-and-report-errors* + (values nil errors warnings)) + (invoke-restart 'continue))))) + (warning (lambda (warning) + (format *error-output* "~&~A: Warning: ~A~%" + (file-location warning) + warning) + (incf warnings) + (invoke-restart 'muffle-warning)))) + (values (funcall thunk) + errors + warnings)))) + +(export 'count-and-report-errors) +(defmacro count-and-report-errors (() &body body) + "Evaluate BODY in a dynamic environment which traps and reports errors. + + The BODY is evaluated. If an error or warning is signalled, it is + reported (using its report function), and counted. Warnings are otherwise + muffled; continuable errors (i.e., when a CONTINUE restart is defined) are + continued; non-continuable errors cause an immediate exit from the BODY. + + The final value consists of three values: the primary value of the BODY + (or NIL if a non-continuable error occurred), the number of errors + reported, and the number of warnings reported." + `(count-and-report-errors* (lambda () ,@body))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/proto-parser-expr.lisp b/src/parser/proto-parser-expr.lisp new file mode 100644 index 0000000..b2919d6 --- /dev/null +++ b/src/parser/proto-parser-expr.lisp @@ -0,0 +1,253 @@ +;;; -*-lisp-*- +;;; +;;; Parsers for expressions with binary operators +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Basic protocol. + +(export 'push-operator) +(defgeneric push-operator (operator state) + (:documentation + "Push an OPERATOR onto the STATE's operator stack. + + This should apply existing stacked operators as necessary to obey the + language's precedence rules.")) + +(export 'push-vlaue) +(defgeneric push-value (value state) + (:documentation + "Push VALUE onto the STATE's value stack. + + The default message just does that without any fuss. It's unlikely that + this will need changing unless you invent some really weird values.")) + +(export 'apply-operator) +(defgeneric apply-operator (operator state) + (:documentation + "Apply the OPERATOR to argument on the STATE's value stack. + + This should pop any necessary arguments, and push the result.")) + +(export 'operator-push-action) +(defgeneric operator-push-action (left right) + (:documentation + "Determine relative precedence between LEFT and RIGHT operators. + + Returns one of three possible values: + + * `:push' means to push the RIGHT operator onto the stack, above the + LEFT operator -- i.e., RIGHT has higher precedence than LEFT. + + * `:apply' means to apply the LEFT operator to arguments immediately + and try again, comparing RIGHT to the new topmost operator -- i.e., + LEFT has higher precedence than RIGHT. + + * `:error' means that the situation is erroneous: a continuable error is + signalled and the situation resolved by applying the LEFT operator and + then pushing the RIGHT one -- i.e., treating them as having similar + precedence and left associativity). + + There is a default method which decides between `:push' and `:apply' by + comparing numerical precedence values.")) + +(export 'expr) +(defparse expr ((&key (nestedp (gensym "NESTEDP-"))) + operand binop preop postop) + "Parse an expression involving unary and binary operators." + (flet ((wrap (parser) + `(parser (,nestedp) + (declare (ignorable ,nestedp)) + ,parser))) + `(parse-expression ,(wrap operand) + ,(wrap binop) + ,(wrap preop) + ,(wrap postop)))) + +;;;-------------------------------------------------------------------------- +;;; Numerical precedence. + +(export '(operator-left-precedence operator-right-precedence)) +(defgeneric operator-left-precedence (operator) + (:documentation + "Return the OPERATOR's left-precedence. + + Higher precedence numbers indicate tighter leftward binding. Under the + default method for `operator-push-action', the OPERATOR's left precedence + is compared to the existing operators' right precedences to determine the + parser's behaviour: if it is higher, then the OPERATOR is pushed; + otherwise the existing operator is applied. Thus, equal precedences cause + left-associative parsing.")) +(defgeneric operator-right-precedence (operator) + (:documentation + "Return the OPERATOR's right-precedence. + + Higher precedence numbers indicate tighter rightward binding. Under the + default method for `operator-push-action', a new operator's left + precedence may be compared to the existing OPERATOR'S right precedences to + determine the parser's behaviour: if it is higher, then the new operator + is pushed; otherwise the existing OPERATOR is applied. Thus, equal + precedences cause left-associative parsing.")) + +(defgeneric operator-associativity (operator) + (:documentation + "Returns an OPERATOR's associativity, as a symbol. + + The return value is one of `:left', `:right' or `nil'. If two adjacent + operators have the same precedence, their associativities are compared. + If both associativities are `:left' then the left-hand operator is + considered to have higher precedence; if both are `:right' then the + right-hand operator is considered to have higher precedence. If they're + inconsistent or `nil', then an error is reported and the behaviour is as + if both were `:left'.") + (:method (operator) :left)) + +;;;-------------------------------------------------------------------------- +;;; Basic operator protocol. + +(export 'prefix-operator) +(defclass prefix-operator () + () + (:documentation + "Prefix operator base class. + + Prefix operators are special because they are pushed at a time when the + existing topmost operator on the stack may not have its operand + available. It is therefore incorrect to attempt to apply any existing + operators without careful checking. This class provides a method on + `push-operator' which immediately pushes the new operator without + inspecting the existing stack.")) + +(export 'simple-operator) +(defclass simple-operator () + ((function :initarg :function :reader operator-function) + (name :initarg :name :initform "" + :reader operator-name)) + (:documentation + "A simple operator applies a FUNCTION to arguments when it is applied. + + The precise details of the function are left to subclasses to sort out.")) + +(export 'simple-unary-operator) +(defclass simple-unary-operator (simple-operator) + () + (:documentation + "A unary operator works on the topmost value on the value stack. + + The topmost item is popped, the FUNCTION is applied to it, and the result + is pushed back on.")) + +(export 'simple-binary-operator) +(defclass simple-binary-operator (simple-operator) + ((lprec :initarg :left-precedence :initarg :precedence + :reader operator-left-precedence) + (rprec :initarg :right-precedence :reader operator-right-precedence) + (associativity :initarg :associative :initform :left + :reader operator-associativity)) + (:documentation + "A binary operator works on the two topmost values on the value stack. + + The function's arguments are the two topmost items in /reverse/ order -- + so the topmost item is second. This is usually what you want. + + The left and right precedences are settable independently. Usually (and + this is the default) you will set them equal, and use the `:associativity' + initarg to determine associativity; however, right-associativity can also + be obtained by setting the right-precedence lower than the left. Special + effects can be obtained by setting them in other ways. Use your + imagination.")) + +(export 'simple-postfix-operator) +(defclass simple-postfix-operator (simple-unary-operator) + ((lprec :initarg :left-precedence :initarg :precedence + :reader operator-left-precedence) + (rprec :initarg :right-precedence :reader operator-right-precedence)) + (:documentation + "A postfix operator is applied to a single operand. + + The left and right precedences are settable independently. Usually you + will want to set them equal (this is the default) and quite high. Special + effects can be obtained by doing other things instead; but note that you + will get an incorrect parse if the right precedence is lower than the left + precedence of a binary operator because the postfix operator will be + applied to the result of the binary operator.")) + +(export 'simple-prefix-operator) +(defclass simple-prefix-operator (prefix-operator simple-unary-operator) + ((rprec :initarg :precedence :reader operator-right-precedence)) + (:documentation + "A prefix operator is applied to a single operand. + + There is only one precedence value for a prefix operator: the + `prefix-operator' superclass arranges that the left precedence is + effectively minus infinity.")) + +(export 'preop) +(defmacro preop (name (x prec) &body body) + `(make-instance 'simple-prefix-operator + :name ,name + :precedence ,prec + :function (lambda (,x) ,@body))) + +(export 'postop) +(defmacro postop (name (x prec &key rprec) &body body) + (once-only (name prec rprec) + `(make-instance 'simple-postfix-operator + :name ,name + :left-precedence ,prec + :right-precedence ,(or rprec prec) + :function (lambda (,x) ,@body)))) + +(export 'binop) +(defmacro binop (name (x y prec &key rprec (assoc :left)) &body body) + (once-only (name prec rprec assoc) + `(make-instance 'simple-binary-operator + :name ,name + :left-precedence ,prec + :right-precedence ,(or rprec prec) + :associative ,assoc + :function (lambda (,x ,y) ,@body)))) + +;;;-------------------------------------------------------------------------- +;;; Parentheses. + +(defclass parenthesis () + ((tag :initarg :tag :initform nil)) + (:documentation + "Base class for parenthesis operators.")) + +(export 'open-parenthesis) +(defclass open-parenthesis (parenthesis prefix-operator) ()) + +(export 'close-parenthesis) +(defclass close-parenthesis (parenthesis) ()) + +(export '(lparen rparen)) +(defun lparen (tag) + (make-instance 'open-parenthesis :tag tag)) +(defun rparen (tag) + (make-instance 'close-parenthesis :tag tag)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/proto-parser.lisp b/src/parser/proto-parser.lisp new file mode 100644 index 0000000..f32a304 --- /dev/null +++ b/src/parser/proto-parser.lisp @@ -0,0 +1,890 @@ +;;; -*-lisp-*- +;;; +;;; Protocol for parsing. +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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. + +;;;-------------------------------------------------------------------------- +;;; Parser protocol discussion. +;;; +;;; Other languages, notably Haskell and ML, have `parser combinator +;;; libraries', which allow one to construct recursive descent parsers using +;;; approximately pleasant syntax. While attempts have been made to +;;; introduce the benefits of these libraries to Lisp, they've not been +;;; altogether successful; this seems due to Lisp's lack of features such as +;;; pattern matching, currying and lazy evaluation. Rather than fight with +;;; Lisp's weaknesses, this library plays to its strength, making heavy use +;;; of macros. Effectively, the `combinators' we build here are /compile- +;;; time/ combinators, not run-time ones. +;;; +;;; A `parser' is simply an expression which returns three values. +;;; +;;; * If the second value is nil, then the parser is said to have /failed/, +;;; and the first value is a list describing the things that the parser +;;; expected to find but didn't. (The precise details of the list items +;;; are important to error-reporting functions, but not to the low-level +;;; machinery, and are left up to higher-level protocols to nail down +;;; harder.) +;;; +;;; * If the second value is not nil, then the parser is said to have +;;; /succeeded/, and the first value is its /result/. +;;; +;;; * The third value indicates whether the parser consumed any of its +;;; input. Parsers don't backtrack implicitly (to avoid space leaks and +;;; bad performance), so the `consumedp' return value is used to decide +;;; whether the parser has `committed' to a particular branch. If the +;;; parser context supports place-capture (many do) then `peek' can be +;;; used to suppress consumption of input in the case of parser failure. +;;; +;;; The functions and macros here are simply ways of gluing together +;;; expressions which obey this protocol. +;;; +;;; The main contribution of this file is a macro WITH-PARSER-CONTEXT which +;;; embeds a parsing-specific S-expressions language entered using the new +;;; macro PARSE. The behaviour of this macro is controlled by a pair of +;;; compile-time generic functions EXPAND-PARSER-SPEC and EXPAND-PARSER-FORM. +;;; As well as the parser expression they're meant to process, these +;;; functions dispatch on a `context' argument, which is intended to help +;;; `leaf' parsers find the terminal symbols which they're meant to process. +;;; +;;; Note that the context is a compile-time object, constructed by the PARSE +;;; macro expansion function, though the idea is that it will contain the +;;; name or names of variables holding the run-time parser state (which will +;;; typically be a lexical analyser or an input stream or suchlike). + +(cl:in-package #:sod-parser) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defun combine-parser-failures (failures) + "Combine the failure indicators listed in FAILURES. + + (Note that this means that FAILURES is a list of lists.)" + + (reduce (lambda (f ff) (union f ff :test #'equal)) + failures + :initial-value nil)) + +;;;-------------------------------------------------------------------------- +;;; Basic protocol. + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (export 'expand-parser-spec) + (defgeneric expand-parser-spec (context spec) + (:documentation + "Expand a parser specifier SPEC in a particular parser CONTEXT.") + (:method (context (spec list)) + (expand-parser-form context (car spec) (cdr spec)))) + + (export 'expand-parser-form) + (defgeneric expand-parser-form (context head tail) + (:documentation + "Expand a parser list-form given by HEAD and TAIL, in CONTEXT.") + (:method (context head tail) + (cons head tail))) + + (export 'wrap-parser) + (defgeneric wrap-parser (context form) + (:documentation + "Enclose FORM in whatever is necessary to make the parser work.") + (:method (context form) form))) + +(export 'defparse) +(defmacro defparse (name bvl &body body) + "Define a new parser form. + + The full syntax is hairier than it looks: + + defparse NAME ( [[ :context (CTX SPEC) ]] . BVL ) + { FORM }* + + The macro defines a new parser form (NAME ...) which is expanded by the + body FORMs. The BVL is a destructuring lambda-list to be applied to the + tail of the form. The body forms are enclosed in a block called NAME. + + Within the FORMs, a function `expand' is available: it takes a parser + specifier as its argument and returns its expansion in the parser's + context. + + If the :context key is provided, then the parser form is specialized on a + particular class of parser contexts SPEC; specialized expanders take + priority over less specialized or unspecialized expanders -- so you can + use this to override the built-in forms safely if they don't seem to be + doing the right thing for you. Also, the context -- which is probably + interesting to you if you've bothered to specialize -- is bound to the + variable CTX." + + ;; BUG! misplaces declarations: if you declare the CONTEXT argument + ;; `special' it won't be bound properly. I'm really not at all sure I know + ;; how to fix this. + + (with-gensyms (head tail context) + (let ((ctxclass t)) + (loop + (unless (and bvl (keywordp (car bvl))) (return)) + (ecase (pop bvl) + (:context (destructuring-bind (name spec) (pop bvl) + (setf ctxclass spec context name))))) + (multiple-value-bind (doc decls body) (parse-body body) + `(defmethod expand-parser-form + ((,context ,ctxclass) (,head (eql ',name)) ,tail) + ,@doc + (block ,name + (destructuring-bind ,bvl ,tail + ,@decls + ,@body))))))) + +(export '(with-parser-context parse)) +(defmacro with-parser-context ((class &rest initargs) &body body) + "Evaluate BODY with a macro `parse' which expands parser forms. + + Evaluate BODY as an implicit progn. At compile time, a parser context is + constructed by (apply #'make-instance CLASS INITARGS). The BODY can make + use of the macro `parse': + + parse SPEC + + which parses the input in the manner described by SPEC, in the context of + the parser context." + + (let ((context (apply #'make-instance class initargs))) + (wrap-parser context + `(macrolet ((parse (form) + (expand-parser-spec ',context form))) + ,@body)))) + +;;;-------------------------------------------------------------------------- +;;; Common parser context protocol. + +(export 'parser-at-eof-p) +(defgeneric parser-at-eof-p (context) + (:documentation + "Return whether the parser has reached the end of its input. + + Be careful: all of this is happening at macro expansion time.")) + +(export 'parser-step) +(defgeneric parser-step (context) + (:documentation + "Advance the parser to the next character. + + Be careful: all of this is happening at macro-expansion time.")) + +(defmethod expand-parser-spec (context (spec (eql :eof))) + "Tests succeeds if the parser has reached the end of its input. + + The failure indicator is the keyword `:eof'." + + `(if ,(parser-at-eof-p context) + (values :eof t nil) + (values '(:eof) nil nil))) + +;;;-------------------------------------------------------------------------- +;;; Useful macros for dealing with parsers. + +(export 'it) +(export 'if-parse) +(defmacro if-parse ((&key (result 'it) expected (consumedp (gensym "CP"))) + parser consequent &optional (alternative nil altp)) + "Conditional parsing construction. + + If PARSER succeeds, then evaluate CONSEQUENT with RESULT bound to the + result; otherwise evaluate ALTERNATIVE with EXPECTED bound to the + expected-item list. If ALTERNATIVE is omitted, then propagate the failure + following the parser protocol." + + (with-gensyms (value win) + `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser) + (declare (ignorable ,consumedp)) + (if ,win + (let ((,result ,value)) + (declare (ignorable ,result)) + ,consequent) + ,(cond ((not altp) + `(values ,value nil ,consumedp)) + (expected + `(let ((,expected ,value)) ,alternative)) + (t + alternative)))))) + +(export 'when-parse) +(defmacro when-parse ((&optional (result 'it)) parser &body body) + "Convenience macro for conditional parsing. + + If PARSER succeeds then evaluate BODY with RESULT bound to the result; + otherwise propagate the failure." + `(if-parse (:result ,result) ,parser (progn ,@body))) + +(export 'cond-parse) +(defmacro cond-parse ((&key (result 'it) expected + (consumedp (gensym "CP"))) + &body clauses) + "Frightening conditional parsing construct. + + Each of the CLAUSES has the form (PARSER &rest FORMS); the special `fake' + parser form `t' may be used to describe a default action. If the PARSER + succeeds then evaluate FORMS in order with RESULT bound to the parser + result (if there are no forms, then propagate the success); if the PARSER + fails without consuming input, then move onto the next clause. + + If the default clause (if any) is reached, or a parser fails after + consuming input, then EXPECTED is bound to a list of failure indicators + and the default clause's FORMS are evaluated and with CONSUMEDP bound to a + generalized boolean indicating whether any input was consumed. If there + is no default clause, and either some parser fails after consuming input, + or all of the parsers fail without consuming, then a failure is reported + and the input-consumption indicator is propagated. + + If a parser fails after consuming input, then the failure indicators are + whatever that parser reported; if all the parsers fail without consuming + then the failure indicators are the union of the indicators reported by + the various parsers." + + (with-gensyms (block fail failarg) + (labels ((walk (clauses failures) + (cond ((null clauses) + (values `(,fail nil (list ,@(reverse failures))) + `(values (combine-parser-failures ,failarg) + nil + ,consumedp))) + ((eq (caar clauses) t) + (values `(,fail nil (list ,@(reverse failures))) + `(,@(if expected + `(let ((,expected + (combine-parser-failures + ,failarg)))) + `(progn)) + ,@(cdar clauses)))) + (t + (with-gensyms (value win cp) + (multiple-value-bind (inner failbody) + (walk (cdr clauses) (cons value failures)) + (values `(multiple-value-bind (,value ,win ,cp) + (parse ,(caar clauses)) + (when ,win + (return-from ,block + (let ((,result ,value) + (,consumedp ,cp)) + (declare (ignorable ,result + ,consumedp)) + ,@(cdar clauses)))) + (when ,cp + (,fail t (list ,value))) + ,inner) + failbody))))))) + (multiple-value-bind (inner failbody) (walk clauses nil) + `(block ,block + (flet ((,fail (,consumedp ,failarg) + (declare (ignorable ,consumedp ,failarg)) + ,failbody)) + ,inner)))))) + +(export 'parser) +(defmacro parser (bvl &body parser) + "Functional abstraction for parsers." + (multiple-value-bind (doc decls body) (parse-body parser) + `(lambda ,bvl ,@doc ,@decls (parse ,@body)))) + +;;;-------------------------------------------------------------------------- +;;; Standard parser forms. + +(export 'label) +(defparse label (label parser) + "If PARSER fails, use LABEL as the expected outcome. + + The LABEL is only evaluated if necessary." + (with-gensyms (value win consumedp) + `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser) + (if ,win + (values ,value ,win ,consumedp) + (values (list ,label) nil ,consumedp))))) + +(defparse t (value) + "Succeed, without consuming input, with result VALUE." + `(values ,value t nil)) + +(defparse when (cond &body parser) + "If CONDITION is true, then match PARSER; otherwise fail." + `(if ,cond (parse ,@parser) (values nil nil nil))) + +(defmethod expand-parser-spec (context (spec (eql t))) + "Always matches without consuming input." + '(values t t nil)) + +(export 'seq) +(defparse seq (binds &body body) + "Parse a sequence of heterogeneous items. + + Syntax: + + seq ( { ATOMIC-PARSER-FORM | ([VAR] PARSER-FORM) }* ) + { FORM }* + + The behaviour is similar to `let*'. The PARSER-FORMs are processed in + order, left to right. If a parser succeeds, then its value is bound to + the corresponding VAR, and available within Lisp forms enclosed within + subsequent PARSER-FORMs and/or the body FORMs. If any parser fails, then + the entire sequence fails. If all of the parsers succeeds, then the FORMs + are evaluated as an implicit progn, and the sequence will succeed with the + result computed by the final FORM." + + (with-gensyms (block consumedp) + (labels ((walk (binds lets ignores) + (if (endp binds) + `(let* ((,consumedp nil) + ,@(nreverse lets)) + ,@(and ignores + `((declare (ignore ,@(nreverse ignores))))) + (values (progn ,@body) t ,consumedp)) + (destructuring-bind (x &optional (y nil yp)) + (if (listp (car binds)) + (car binds) + (list (car binds))) + (with-gensyms (var value win cp) + (multiple-value-bind (var parser ignores) + (if (and yp x) + (values x y ignores) + (values var (if yp y x) (cons var ignores))) + (walk (cdr binds) + (cons `(,var (multiple-value-bind + (,value ,win ,cp) + (parse ,parser) + (when ,cp (setf ,consumedp t)) + (unless ,win + (return-from ,block + (values ,value ,nil + ,consumedp))) + ,value)) + lets) + ignores))))))) + `(block ,block ,(walk binds nil nil))))) + +(export 'and) +(defparse and (:context (context t) &rest parsers) + "Parse a sequence of heterogeneous items, but ignore their values. + + This is just like (and is implemented using) `seq' with all the bindings + set to `nil'. The result is `nil'." + (with-gensyms (last) + (if (null parsers) + '(seq () nil) + (expand-parser-spec context + `(seq (,@(mapcar (lambda (parser) + `(nil ,parser)) + (butlast parsers)) + (,last ,(car (last parsers)))) + ,last))))) + +(export 'lisp) +(defparse lisp (&rest forms) + "Evaluate FORMs, which should obey the parser protocol." + `(progn ,@forms)) + +(export 'many) +(defparse many ((acc init update + &key (new 'it) (final acc) (min nil minp) max (commitp t)) + parser &optional (sep nil sepp)) + "Parse a sequence of homogeneous items. + + The behaviour is similar to `do'. Initially an accumulator ACC is + established, and bound to the value of INIT. The PARSER is then evaluated + repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults + to `it') bound to the result of the parse, and the value returned by + UPDATE is stored back into ACC. If the PARSER fails, then the parse + ends. The scope of ACC includes the UPDATE and FINAL forms, and the + PARSER and SEP parsers; it is updated by side effects, not rebound. + + If a SEP parser is provided, then the behaviour changes as follows. + Before each attempt to parse a new item using PARSER, the parser SEP is + invoked. If SEP fails then the parse ends; if SEP succeeds, and COMMITP + is true, then the PARSER must also succeed or the overall parse will + fail. If COMMITP is false then a trailing SEP is permitted and ignored. + + If MAX (which will be evaluated) is not nil, then it must be a number: the + parse ends automatically after PARSER has succeeded MAX times. When the + parse has ended, if the PARSER succeeded fewer than MIN (which will be + evaluated) times then the parse fails. Otherwise, the FINAL form (which + defaults to simply returning ACC) is evaluated and its value becomes the + result of the parse. MAX defaults to nil -- i.e., no maximum; MIN + defaults to 1 if a SEP parser is given, or 0 if not. + + Note that `many' cannot fail if MIN is zero." + + ;; Once upon a time, this was a macro of almost infinite hairiness which + ;; tried to do everything itself, including inspecting its arguments for + ;; constant-ness to decide whether it could elide bits of code. This + ;; became unsustainable. Nowadays, it packages up its parser arguments + ;; into functions and calls some primitive functions to do the heavy + ;; lifting. + ;; + ;; The precise protocol between this macro and the backend functions is + ;; subject to change: don't rely on it. + + (let* ((accvar (or acc (gensym "ACC-"))) + (func (if sepp '%many-sep '%many))) + `(let ((,accvar ,init)) + (declare (ignorable ,accvar)) + (,func (lambda (,new) + (declare (ignorable ,new)) + (setf ,accvar ,update)) + (lambda () + ,final) + (parser () ,parser) + ,@(and sepp (list `(parser () ,sep))) + ,@(and minp `(:min ,min)) + ,@(and max `(:max ,max)) + ,@(and (not (eq commitp t)) `(:commitp ,commitp)))))) + +(export 'list) +(defparse list ((&rest keys) parser &optional (sep nil sepp)) + "Like MANY, but simply returns a list of the parser results." + (with-gensyms (acc) + `(parse (many (,acc nil (cons it ,acc) :final (nreverse ,acc) ,@keys) + ,parser ,@(and sepp (list sep)))))) + +(export 'skip-many) +(defparse skip-many ((&rest keys) parser &optional (sep nil sepp)) + "Like MANY, but ignores the results." + `(parse (many (nil nil nil ,@keys) + ,parser ,@(and sepp (list sep))))) + +(export 'or) +(defparse or (&rest parsers) + "Try a number of alternative parsers. + + Each of the PARSERS in turn is tried. If any succeeds, then its result + becomes the result of the parse. If any parser fails after consuming + input, or if all of the parsers fail, then the overall parse fails, with + the union of the expected items from the individual parses." + + (with-gensyms (fail cp failarg) + (labels ((walk (parsers failures) + (if (null parsers) + `(,fail nil (list ,@(reverse failures))) + (with-gensyms (value win consumedp) + `(multiple-value-bind (,value ,win ,consumedp) + (parse ,(car parsers)) + (cond (,win + (values ,value ,win ,consumedp)) + (,consumedp + (,fail t (list ,value))) + (t + ,(walk (cdr parsers) + (cons value failures))))))))) + `(flet ((,fail (,cp ,failarg) + (values (combine-parser-failures ,failarg) nil ,cp))) + ,(walk parsers nil))))) + +(export '?) +(defparse ? (parser &optional (value nil)) + "Matches PARSER or nothing; fails if PARSER fails after consuming input." + `(parse (or ,parser (t ,value)))) + +;;;-------------------------------------------------------------------------- +;;; Pluggable parsers. + +(export 'call-pluggable-parser) +(defun call-pluggable-parser (symbol &rest args) + "Call the pluggable parser denoted by SYMBOL. + + A `pluggable parser' is an indirection point at which a number of + alternative parsers can be attached dynamically. The parsers are tried in + some arbitrary order, so one should be careful to avoid ambiguities; each + is paseed the given ARGS. + + If any parser succeeds then it determines the result; if any parser fails + having consumed input then the pluggable parser fails immediately. If all + of the parsers fail without consuming input then the pluggable parser + fails with the union of the individual failure indicators." + + (let ((expected nil)) + (dolist (item (get symbol 'parser)) + (multiple-value-bind (value winp consumedp) (apply (cdr item) args) + (when (or winp consumedp) + (return-from call-pluggable-parser (values value winp consumedp))) + (push value expected))) + (values (combine-parser-failures expected) nil nil))) + +(export 'plug) +(defparse plug (symbol &rest args) + "Call the pluggable parser denoted by SYMBOL. + + This is just like the function `call-pluggable-parser', but the SYMBOL is + not evaluated." + `(call-pluggable-parser ',symbol ,@args)) + +(export 'pluggable-parser-add) +(defun pluggable-parser-add (symbol tag parser) + "Adds an element to a pluggable parser. + + The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'- + comparable object which identifies the element. The PARSER is a parser + function; it will be passed arguments via `pluggable-parser'. + + If a parser with the given TAG is already attached to SYMBOL then the new + parser replaces the old one; otherwise it is added to the collection." + + (let ((alist (get symbol 'parser))) + (aif (assoc tag alist) + (setf (cdr it) parser) + (setf (get symbol 'parser) (acons tag parser alist))))) + +(export 'define-pluggable-parser) +(defmacro define-pluggable-parser (symbol tag (&rest bvl) &body body) + "Adds an element to a pluggable parser. + + The pluggable parser itself is denoted by SYMBOL; the TAG is any `eql'- + comparable object which identifies the element. Neither SYMBOL nor TAG is + evaluated. The BODY is a parser expression; the BVL is a lambda list + describing how to bind the argumens supplied via `pluggable-parser'. + + If a parser with the given TAG is already attached to SYMBOL then the new + parser replaces the old one; otherwise it is added to the collection." + + `(pluggable-parser-add ',symbol ',tag (lambda ,bvl ,@body))) + +;;;-------------------------------------------------------------------------- +;;; Rewindable parser context protocol. + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (export 'parser-capture-place) + (defgeneric parser-capture-place (context) + (:documentation + "Capture the current position of a parser CONTEXT. + + The return value may later be used with `parser-restore-place'. Be + careful: all of this is happening at macro-expansion time.") + (:method (context) + (error "Parser context ~S doesn't support rewinding." context))) + + (export 'parser-restore-place) + (defgeneric parser-restore-place (context place) + (:documentation + "`Rewind' the parser CONTEXT back to the captured PLACE. + + The place was previously captured by `parser-capture-place'. Be careful: + all of this is happening at macro-expansion time.")) + + (export 'parser-release-place) + (defgeneric parser-release-place (context place) + (:documentation + "Release a PLACE captured from the parser CONTEXT. + + The place was previously captured by `parser-capture-place'. The + underlying scanner can use this call to determine whether there are + outstanding captured places, and thereby optimize its behaviour. Be + careful: all of this is happening at macro-expansion time.") + (:method (context place) nil)) + + (export 'parser-places-must-be-released-p) + (defgeneric parser-places-must-be-released-p (context) + (:documentation + "Answer whether places captured from the parser CONTEXT need releasing. + + Some contexts -- well, actually, their run-time counterparts -- work + better if they can keep track of which places are captured, or at least if + there are captured places outstanding. If this function returns true + (which is the default) then `with-parser-place' (and hence parser macros + such as `peek') will expand to `unwind-protect' forms in order to perform + the correct cleanup. If it returns false, then the `unwind-protect' is + omitted so that the runtime code does't have to register cleanup + handlers.") + (:method (context) t))) + +(export 'with-parser-place) +(defmacro with-parser-place ((place context) &body body) + "Evaluate BODY surrounded with a binding of PLACE to a captured place. + + The surrounding code will release the PLACE properly on exit from the body + forms. This is all happening at macro-expansion time." + ;; ... which means that it's a bit hairy. Fortunately, the nested + ;; backquotes aren't that bad. + (once-only (context) + (with-gensyms (bodyfunc) + `(with-gensyms (,place) + (flet ((,bodyfunc () ,@body)) + `(let ((,,place ,(parser-capture-place ,context))) + ,(if (parser-places-must-be-released-p ,context) + `(unwind-protect ,(,bodyfunc) + ,(parser-release-place ,context ,place)) + (,bodyfunc)))))))) + +(export 'peek) +(defparse peek (:context (context t) parser) + "Attempt to run PARSER, but rewind the underlying source if it fails." + (with-gensyms (value win consumedp) + (with-parser-place (place context) + `(multiple-value-bind (,value ,win ,consumedp) (parse ,parser) + (cond (,win + (values ,value ,win ,consumedp)) + (t + ,(parser-restore-place context place) + (values ,value ,win nil))))))) + +;;;-------------------------------------------------------------------------- +;;; Character parser context protocol. + +(export 'character-parser-context) +(defclass character-parser-context () + () + (:documentation + "Base class for parsers which read one character at a time.")) + +(export 'parser-current-char) +(defgeneric parser-current-char (context) + (:documentation + "Return the parser's current character. + + It is an error to invoke this operation if the parser is at end-of-file; + you must check this first. Be careful: all of this is happening at + macro-expansion time.")) + +(defparse if-char (:context (context character-parser-context) + (&optional (char 'it)) condition consequent alternative) + "Basic character-testing parser. + + If there is a current character, bind it to CHAR and evaluate the + CONDITION; if that is true, then step the parser and evaluate CONSEQUENT; + otherwise, if either we're at EOF or the CONDITION returns false, evaluate + ALTERNATIVE. The result of `if-char' are the values returned by + CONSEQUENT or ALTERNATIVE." + + (with-gensyms (block) + `(block ,block + (unless ,(parser-at-eof-p context) + (let ((,char ,(parser-current-char context))) + (when ,condition + ,(parser-step context) + (return-from ,block ,consequent)))) + ,alternative))) + +(defmethod expand-parser-spec + ((context character-parser-context) (spec (eql :any))) + "Matches any character; result is the character. + + The failure indicator is the keyword `:any'." + (expand-parser-spec context + '(if-char () t + (values it t t) + (values '(:any) nil nil)))) + +(export 'char) +(defparse char (:context (context character-parser-context) char) + "Matches the character CHAR (evaluated); result is the character. + + The failure indicator is CHAR." + + (once-only (char) + (with-gensyms (it) + (expand-parser-spec context + `(if-char (,it) (char= ,it ,char) + (values ,it t t) + (values (list ,char) nil nil)))))) + +(defmethod expand-parser-spec + ((context character-parser-context) (char character)) + (expand-parser-spec context `(char ,char))) + +(export 'satisfies) +(defparse satisfies (:context (context character-parser-context) predicate) + "Matches a character that satisfies the PREDICATE + + The PREDICATE is a function designator. On success, the result is the + character. The failure indicator is PREDICATE; you probably want to apply + a `label'." + + (with-gensyms (it) + (expand-parser-spec context + `(if-char (,it) (,predicate ,it) + (values ,it t t) + (values '(,predicate) nil nil))))) + +(export 'not) +(defparse not (:context (context character-parser-context) char) + "Matches any character other than CHAR; result is the character. + + The failure indicator is (not CHAR)." + + (once-only (char) + (with-gensyms (it) + (expand-parser-spec context + `(if-char (,it) (char/= ,it ,char) + (values ,it t t) + (values `((not ,,char)) nil nil)))))) + +(export 'filter) +(defparse filter (:context (context character-parser-context) predicate) + "Matches a character that satisfies the PREDICATE; result is the output of + PREDICATE. + + The failure indicator is PREDICATE; you probably want to apply a `label'." + + ;; Can't do this one with `if-char'. + (with-gensyms (block value) + `(block ,block + (unless ,(parser-at-eof-p context) + (let ((,value (,predicate ,(parser-current-char context)))) + (when ,value + ,(parser-step context) + (return-from ,block (values ,value t t))))) + (values '(,predicate) nil nil)))) + +(defmethod expand-parser-spec + ((context character-parser-context) (spec (eql :whitespace))) + "Matches any sequence of whitespace; result is nil. + + Cannot fail." + + `(progn + (cond ((and (not ,(parser-at-eof-p context)) + (whitespace-char-p ,(parser-current-char context))) + (loop + ,(parser-step context) + (when (or ,(parser-at-eof-p context) + (not (whitespace-char-p + ,(parser-current-char context)))) + (return (values nil t t))))) + (t + (values nil t nil))))) + +(defmethod expand-parser-spec + ((context character-parser-context) (string string)) + "Matches the constituent characters of STRING; result is the string. + + The failure indicator is STRING; on failure, the input is rewound, so this + only works on rewindable contexts." + + (with-gensyms (i) + (unless (typep string 'simple-string) + (setf string (make-array (length string) :initial-contents string))) + (with-parser-place (place context) + `(dotimes (,i ,(length string) (values ,string t + ,(plusp (length string)))) + (when (or ,(parser-at-eof-p context) + (char/= ,(parser-current-char context) + (schar ,string ,i))) + ,(parser-restore-place context place) + (return (values '(,string) nil nil))) + ,(parser-step context))))) + +;;;-------------------------------------------------------------------------- +;;; Token parser context protocol. + +(export 'token-parser-context) +(defclass token-parser-context () + () + (:documentation + "Base class for parsers which read tokens with associated semantic values. + + A token, according to the model suggested by this class, has a /type/, + which classifies the token and is the main contributer to guiding the + parse, and a /value/, which carries additional semantic information. + + This may seem redundant given Lisp's dynamic type system; but it's not + actually capable of drawing sufficiently fine distinctions easily. For + example, we can represent a symbol either as a string or a symbol; but + using strings conflicts with being able to represent string literals, and + using symbols looks ugly and they don't get GCed. Similarly, it'd be + convenient to represent punctuation as characters, but that conflicts with + using them for character literals. So, we introduce our own notion of + token type. + + Token scanners are expected to signal end-of-file with a token of type + `:eof'.")) + +(export 'parser-token-type) +(defgeneric parser-token-type (context) + (:documentation + "Return the parser's current token type.")) + +(export 'parser-token-value) +(defgeneric parser-token-value (context) + (:documentation + "Return the parser's current token's semantic value.")) + +(export 'token) +(defparse token (:context (context token-parser-context) + type &optional (value nil valuep) &key peekp) + "Match tokens of a particular type. + + A token matches under the following conditions: + + * If the value of TYPE is `t' then the match succeeds if and only if the + parser it not at end-of-file. + + * If the value of TYPE is not `eql' to the token type then the match + fails. + + * If VALUE is specified, and the value of VALUE is not `equal' to the + token semantic value then the match fails. + + * Otherwise the match succeeds. + + If the match is successful and the parser is not at end-of-file, and the + value of PEEKP is nil then the parser advances to the next token; the + result of the match is the token's value. + + If the match fails then the failure indicator is either TYPE or (TYPE + VALUE), depending on whether a VALUE was specified." + + (once-only (type value peekp) + (with-gensyms (tokty tokval) + `(let ((,tokty ,(parser-token-type context)) + (,tokval ,(parser-token-value context))) + (if ,(if (eq type t) + `(not (eq ,tokty :eof)) + (flet ((check-value (cond) + (if valuep + `(and ,cond (equal ,tokval ,value)) + cond))) + (if (constantp type) + (check-value `(eql ,tokty ,type)) + `(if (eq ,type t) + (not (eq ,tokty :eof)) + ,(check-value `(eql ,tokty ,type)))))) + ,(let* ((result `(values ,tokval t ,(if (constantp peekp) + (not peekp) + `(not ,peekp)))) + (step (parser-step context))) + (cond ((not (constantp peekp)) + `(multiple-value-prog1 ,result + (unless ,peekp ,step))) + (peekp + result) + (t + `(multiple-value-prog1 ,result + ,step)))) + (values (list ,(if valuep `(list ,type ,value) type)) + nil nil)))))) + +(defmethod expand-parser-spec ((context token-parser-context) spec) + (if (atom spec) + (expand-parser-spec context `(token ,spec)) + (call-next-method))) + +(defmethod expand-parser-spec ((context token-parser-context) (spec string)) + (expand-parser-spec context `(token :id ,spec))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/proto-scanner.lisp b/src/parser/proto-scanner.lisp new file mode 100644 index 0000000..87a382e --- /dev/null +++ b/src/parser/proto-scanner.lisp @@ -0,0 +1,258 @@ +;;; -*-lisp-*- +;;; +;;; Scanner protocol definitions. +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Scanner context protocol. + +(export 'parser-scanner) +(defgeneric parser-scanner (context) + (:documentation + "Return the symbol naming the CONTEXT's run-time scanner.")) + +(export 'scanner-context) +(defclass scanner-context () + ((scanner :initarg :scanner :type symbol :reader parser-scanner)) + (:documentation + "Base class for scanner contexts. + + A scanner is simply an object maintaining the run-time state of a parsing + operation, in the same way as a parser context maintains the compile-time + state. So the scanner context is a compile-time context which expands to + calls to use the run-time scanner. See? + + This class provides common compile-time behaviour for PARSER-AT-EOF-P and + friends by invoking corresponding methods on the scanner object at + run-time.")) + +;;;-------------------------------------------------------------------------- +;;; Basic scanner protocol. + +(export 'scanner-at-eof-p) +(defgeneric scanner-at-eof-p (scanner) + (:documentation + "Answer whether the SCANNER is at end-of-file. + + It is an error to query the current item when at end-of-file.")) + +(export 'scanner-step) +(defgeneric scanner-step (scanner) + (:documentation + "Advance the SCANNER to the next item. + + The precise nature of the items isn't known at this level, so a protocol + for accessing them is left for later.")) + +;;;-------------------------------------------------------------------------- +;;; Scanner place-capture protocol. + +(export 'scanner-capture-place) +(defgeneric scanner-capture-place (scanner) + (:documentation + "Capture the SCANNER's current place and return it.") + (:method (scanner) + (error "Scanner ~S doesn't support rewinding." scanner))) + +(export 'scanner-restore-place) +(defgeneric scanner-restore-place (scanner place) + (:documentation + "`Rewind' the SCANNER to the captured PLACE. + + The place was previously captured by `scanner-capture-place'.")) + +(export 'scanner-release-place) +(defgeneric scanner-release-place (scanner place) + (:documentation + "Release a PLACE captured from the SCANNER. + + The place was previously captured by `scanner-capture-place'.") + (:method (scanner place) nil)) + +(export 'with-scanner-place) +(defmacro with-scanner-place ((place scanner) &body body) + "Evaluate BODY with PLACE bound to the captured current place. + + Automatically releases the place when the BODY finishes. Note that + if you wanted to circumvent the cleanup then you should have used + `with-parser-place', which does all of this in the meta-level." + (once-only (scanner) + `(let ((,place (scanner-capture-place ,scanner))) + (unwind-protect (progn ,@body) + (scanner-release-place ,scanner ,place))))) + +;;;-------------------------------------------------------------------------- +;;; Character scanner protocol. + +(export 'character-scanner) +(defclass character-scanner () + () + (:documentation "Base class for character scanners.")) + +(export 'character-scanner-context) +(defclass character-scanner-context + (scanner-context character-parser-context) + () + (:documentation + "A context for a richer character-oriented scanner.")) + +(export 'scanner-current-char) +(defgeneric scanner-current-char (scanner) + (:documentation + "Returns the SCANNER's current character. + + You advance to the next one using `scanner-step'.")) + +(export 'scanner-unread) +(defgeneric scanner-unread (scanner char) + (:documentation + "Rewind SCANNER by one character, specifically CHAR. + + CHAR must be the character most recently stepped over by `scanner-step' -- + it is an error to unread before the first call to `scanner-step'. It is + also an error to unread after encountering end-of-file.")) + +(export 'scanner-interval) +(defgeneric scanner-interval (scanner place-a &optional place-b) + (:documentation + "Return the characters from PLACE-A up to (but not including) PLACE-B. + + The characters are returned as a string. If PLACE-B is omitted, return + the characters up to (but not including) the current position. It is an + error if PLACE-B precedes PLACE-A or they are from different scanners.")) + +(export '(scanner-filename scanner-line scanner-column)) +(defgeneric scanner-filename (scanner) + (:documentation "Return the filename backing the SCANNER.") + (:method (scanner) nil)) +(defgeneric scanner-line (scanner) + (:documentation "Return the SCANNER's current line number.") + (:method (scanner) nil)) +(defgeneric scanner-column (scanner) + (:documentation "Return the SCANNER's current column number.") + (:method (scanner) nil)) + +(defun scanner-file-location (scanner) + "Capture the current location of the SCANNER. + + This uses the generic functions `scanner-filename', `scanner-line' and + `scanner-column' to compute its result. There are default methods on + these functions which make up dummy results. + + There is a method for `file-location' defined on `character-scanner' which + simply calls this function; but since some scanners are structure-objects + rather than standard-objects they can't include `character-scanner' as a + superclass." + (make-file-location (scanner-filename scanner) + (scanner-line scanner) + (scanner-column scanner))) + +;;;-------------------------------------------------------------------------- +;;; Token scanner protocol. + +;; A place marker. + +(export '(token-scanner-place token-scanner-place-p)) +(defstruct token-scanner-place + "A link in the chain of lookahead tokens; capturable as a place. + + If the scanner's place is captured, it starts to maintain a list of + lookahead tokens. The list contains internal links -- it works out + slightly easier that way. This is basically a simpler version of the + charbuf scanner (q.v.); most significantly, the chain links here do double + duty as place markers. + + The details of this structure are not a defined part of the token scanner + protocol." + + (next nil :type (or token-scanner-place null)) + (type nil :read-only t) + (value nil :read-only t) + (line 1 :type fixnum :read-only t) + (column 0 :type fixnum :read-only t)) + +;; The token scanner base class and parser context. + +(export '(token-scanner token-type token-value)) +(defclass token-scanner () + ((type :reader token-type) + (value :reader token-value) + (captures :initform 0 :type fixnum) + (tail :initform nil :type (or token-scanner-place null)) + (filename :initarg filename :type string :reader scanner-filename) + (line :initarg :line :initform 1 :type fixnum :accessor scanner-line) + (column :initarg :column :initform 0 + :type fixnum :accessor scanner-column)) + (:documentation + "A rewindable scanner for tokenizing. + + The scanner should be used via the parser protocol; see also the token + scanner protocol, which explains the model. + + Subclasses must provide the detailed scanning behaviour -- most notably + the `scanner-token' generic function. This function should also update + the `line' and `column' slots to track the position in the underlying + source, if appropriate, and also implement a method on `file-location' to + return the location. This class will handle the remaining details, such + as dealing correctly with rewinding.")) + +(export 'token-scanner-context) +(defclass token-scanner-context (scanner-context token-parser-context) + () + (:documentation + "A parser context for a richer token-based scanners.")) + +;; Protocol. + +(export 'scanner-token) +(defgeneric scanner-token (scanner) + (:documentation + "Internal protocol: read the next token from the SCANNER. + + This function is called by `scanner-step' to actually read the next token + if necessary. It should return two values: the token's `type' and its + `value'.")) + +;;;-------------------------------------------------------------------------- +;;; Character scanner streams. +;;; +;;; This seems like an abstraction inversion, but it's important if we're to +;;; `read' from a character scanner. + +(export 'character-scanner-stream) +(defclass character-scanner-stream (fundamental-character-input-stream) + ((scanner :initarg :scanner)) + (:documentation + "A stream which reads from a character scanner. + + The SCANNER must implement the character scanner protcol, including + `scanner-current-char', `scanner-step', and `scanner-unread'; it is not + necessary that the scanner implement the place-capture protocol. + + The stream can be made more efficient by implementing + `stream-read-sequence' and `stream-read-line' in a scanner-specific + manner.")) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/proto-streams.lisp b/src/parser/proto-streams.lisp new file mode 100644 index 0000000..bcce02a --- /dev/null +++ b/src/parser/proto-streams.lisp @@ -0,0 +1,46 @@ +;;; -*-lisp-*- +;;; +;;; Additional stream protocol. +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-parser) + +;;;-------------------------------------------------------------------------- +;;; Discovery of file names. + +(export 'stream-pathname) +(defgeneric stream-pathname (stream) + (:documentation + "Returns the pathname of the file that STREAM is open on. + + If STREAM is open on a file, then return the pathname of that file. + Otherwise return NIL.") + + ;; Provide some default methods. Most streams don't have a pathname. + ;; File-based streams provide a pathname, but it's usually been merged with + ;; *DEFAULT-PATHNAME-DEFAULTS* or some such, which has made it absolute, + ;; which isn't ideal. We'll hack around this in more useful classes later. + (:method ((stream stream)) nil) + (:method ((stream file-stream)) (pathname stream))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/test-parser.lisp b/src/parser/test-parser.lisp new file mode 100644 index 0000000..f25961e --- /dev/null +++ b/src/parser/test-parser.lisp @@ -0,0 +1,444 @@ +;;; -*-lisp-*- +;;; +;;; Test parser infrastructure +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-test) + +(defclass test-parser (test-case) + ()) +(add-test *sod-test-suite* (get-suite test-parser)) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defmacro assert-parse + ((string value winp consumedp &key (scanner (gensym "SCANNER-"))) + &body parser) + (once-only (string value winp consumedp) + (with-gensyms (my-value my-winp my-consumedp label what) + `(let ((,scanner (make-string-scanner ,string))) + (multiple-value-bind (,my-value ,my-winp ,my-consumedp) + (with-parser-context + (character-scanner-context :scanner ,scanner) + (parse ,@parser)) + (flet ((,label (,what) + (format nil "~A; parsing ~S with ~S" + ,what ,string ',@parser))) + (cond (,winp + (assert-true ,my-winp (,label "winp")) + (if (eq ,value t) + (assert-not-eql ,my-value nil + (,label "parser result")) + (assert-equal ,my-value ,value + (,label "parser result")))) + (t + (assert-false ,my-winp (,label "winp")) + (assert-true (and (null (set-difference ,my-value ,value + :test #'equal)) + (null (set-difference ,value ,my-value + :test #'equal))) + (,label "failure indicator")))) + (if ,consumedp + (assert-true ,my-consumedp (,label "consumedp")) + (assert-false ,my-consumedp (,label "consumedp"))))))))) + +;;;-------------------------------------------------------------------------- +;;; Simple parser tests. +;;; +;;; This lot causes SBCL to warn like a mad thing. It's too clever for us, +;;; and does half of the work at compile time! + +(def-test-method test-simple ((test test-parser) :run nil) + "Test simple atomic parsers, because we rely on them later." + + ;; Characters match themselves. For a character known only at run-time, + ;; use (char CH). + (assert-parse ("abcd" #\a t t) #\a) + (let ((ch #\b)) + (assert-parse ("abcd" '(#\b) nil nil) (char ch))) + + ;; A character can't match at EOF. + (assert-parse ("" '(#\z) nil nil) #\z) + + ;; All characters match :any; but EOF isn't a character. + (assert-parse ("z" #\z t t) :any) + (assert-parse ("" '(:any) nil nil) :any) + + ;; The parser (satisfies PREDICATE) succeeds if the PREDICATE returns + ;; true when applied to the current character. + (assert-parse ("a" #\a t t) (satisfies alpha-char-p)) + (assert-parse ("0" '(alpha-char-p) nil nil) (satisfies alpha-char-p)) + + ;; The parser (not CHAR) matches a character other than CHAR; but it won't + ;; match EOF. + (assert-parse ("a" #\a t t) (not #\b)) + (assert-parse ("b" '((not #\b)) nil nil) (not #\b)) + (assert-parse ("" '((not #\b)) nil nil) (not #\b)) + + ;; But :eof matches only at EOF. + (assert-parse ("" :eof t nil) :eof) + (assert-parse ("abcd" '(:eof) nil nil) :eof) + + ;; Strings match themselves without consuming if they fail. + (assert-parse ("abcd" "ab" t t) "ab") + (assert-parse ("abcd" '("cd") nil nil) "cd")) + +(def-test-method test-sequence ((test test-parser) :run nil) + + ;; An empty sequence always succeeds and never consumes. And provokes + ;; warnings: don't do this. + (assert-parse ("" :win t nil) (seq () :win)) + (assert-parse ("abcd" :win t nil) (seq () :win)) + + ;; A `seq' matches the individual parsers in order, and binds their results + ;; to variables -- if given. The result is the value of the body. If any + ;; parser fails having consumed input, then input stays consumed. There's + ;; no backtracking. + (assert-parse ("abcd" '(#\a . #\c) t t) + (seq ((foo #\a) #\b (bar #\c)) (cons foo bar))) + (assert-parse ("abcd" '(#\c) nil t) + (seq ((foo #\a) (bar #\c)) (cons foo bar))) + (assert-parse ("abcd" '(#\c) nil nil) + (seq ((bar #\c) (foo #\a)) (cons foo bar)))) + +(def-test-method test-repeat ((test test-parser) :run nil) + + ;; A `many' matches a bunch of similar things in a row. You can compute a + ;; result using `do'-like accumulation. + (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc)) #\a)) + + ;; The default minimum is zero; so the parser always succeeds. + (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc)) #\b)) + + ;; You can provide an explicit minimum. Then the match might fail. + (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min 2) #\a)) + (assert-parse ("aabb" '(#\a) nil t) (many (acc 0 (1+ acc) :min 3) #\a)) + + ;; You can also provide an explicit maximum. This will cause the parser to + ;; stop searching, but it can't make it fail. + (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max 3) #\a)) + + ;; You can provide both a maximum and a minimum at the same time. If + ;; they're consistent, you won't be surprised. If they aren't, then the + ;; maximum wins and the minimum is simply ignored (currently). + (assert-parse ("aaaaab" 4 t t) + (many (acc 0 (1+ acc) :min 3 :max 4) #\a)) + (assert-parse ("aabbbb" '(#\a) nil t) + (many (acc 0 (1+ acc) :min 3 :max 4) #\a)) + (assert-parse ("aaabbb" 3 t t) + (many (acc 0 (1+ acc) :min 3 :max 3) #\a)) + (assert-parse ("aaabbb" 3 t t) + (many (acc 0 (1+ acc) :min 17 :max 3) #\a)) + + ;; You can provide a separator. The `many' parser will look for the + ;; separator between each of the main items, but will ignore the results. + (assert-parse ("a,a,abc" 3 t t) (many (acc 0 (1+ acc)) #\a #\,)) + (assert-parse ("a,a,abc" 2 t t) (many (acc 0 (1+ acc) :max 2) #\a #\,)) + + ;; If `many' sees a separator then by default it commits to finding another + ;; item; so this can cause a parse to fail. + (assert-parse ("a,a,bc" '(#\a) nil t) (many (acc 0 (1+ acc)) #\a #\,)) + (assert-parse ("abc" 1 t t) (many (acc 0 (1+ acc)) #\a #\,)) + + ;; If you specify a separator then the default minimum number of + ;; repetitions becomes 1 rather than 0. But you can override this + ;; explicitly. + (assert-parse ("bc" '(#\a) nil nil) (many (acc 0 (1+ acc)) #\a #\,)) + (assert-parse ("bc" 0 t nil) (many (acc 0 (1+ acc) :min 0) #\a #\,)) + + ;; The parser will fail looking for a separator if there aren't enough + ;; items. + (assert-parse ("a,abc" '(#\,) nil t) + (many (acc 0 (1+ acc) :min 3) #\a #\,)) + + ;; You can override the commit-on-separator behaviour by using :commit. + ;; This makes a trailing separator legal (but optional), so it also affects + ;; the behaviour regarding maximum and minimum repetitions. (Commitment is + ;; irrelevant if you don't have a separator.) + (assert-parse ("a,a,bc" 2 t t) + (many (acc 0 (1+ acc) :commitp nil) #\a #\,)) + (assert-parse ("a,a,abc" 3 t t) + (many (acc 0 (1+ acc) :commitp nil) #\a #\,)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp t) #\a #\,)) + #\,) + n)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp nil) #\a #\,)) + #\b) + n)) + (assert-parse ("a,a,bc" '(#\a) nil t) + (many (acc 0 (1+ acc) :min 3 :commitp nil) #\a #\,)) + + ;; The `many' parser won't backtrack. The `many' eats as many `a's as + ;; possible; asking for another one is sure to fail. + (assert-parse ("aaaabc" '(#\a) nil t) (and (skip-many () #\a) #\a))) + +(def-test-method test-repeat-hairy ((test test-parser) :run nil) + ;; The `many' expander is very hairy and does magical things if it notices + ;; that some of its arguments are constants. So here we test a number of + ;; the above things again, using variables so that it has to produce code + ;; which makes decisions at run-time. (I've no doubt that SBCL will issue + ;; an infinite number of notes explaining how clever it is and how it can + ;; do it all at compile-time anyway. Of course, suppressing these notes is + ;; the main reason `many' is so hairy anyway.) + + (let ((zero 0) (two 2) (three 3) (yes t) (no nil)) + + ;; Minima. + (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :min zero) #\a)) + (assert-parse ("aaaab" 0 t nil) (many (acc 0 (1+ acc) :min zero) #\b)) + (assert-parse ("aabb" 2 t t) (many (acc 0 (1+ acc) :min two) #\a)) + (assert-parse ("aabb" '(#\a) nil t) + (many (acc 0 (1+ acc) :min three) #\a)) + + ;; Maxima. + (assert-parse ("aaaab" 4 t t) (many (acc 0 (1+ acc) :max no) #\a)) + (assert-parse ("aaaab" 3 t t) (many (acc 0 (1+ acc) :max three) #\a)) + + ;; And now together with separators and commitment. Oh, my. + (assert-parse ("a,a,a,bc" 3 t t) + (many (acc 0 (1+ acc) :commitp no) #\a #\,)) + (assert-parse ("a,a,a,bc" '(#\a) nil t) + (many (acc 0 (1+ acc) :commitp yes) #\a #\,)) + (assert-parse ("a,a,bc" '(#\a) nil t) + (many (acc 0 (1+ acc) :min three :commitp yes) #\a #\,)) + (assert-parse ("a,a,bc" '(#\a) nil t) + (many (acc 0 (1+ acc) :min 3 :commitp yes) #\a #\,)) + (assert-parse ("a,a,bc" '(#\a) nil t) + (many (acc 0 (1+ acc) :min three :commitp t) #\a #\,)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max three :commitp no) #\a #\,)) #\b) + n)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max three :commitp yes) #\a #\,)) #\,) + n)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp no) #\a #\,)) #\b) + n)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max 3 :commitp yes) #\a #\,)) #\,) + n)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max three :commitp nil) #\a #\,)) #\b) + n)) + (assert-parse ("a,a,a,bc" 3 t t) + (seq ((n (many (acc 0 (1+ acc) :max three :commitp t) #\a #\,)) #\,) + n)))) + +(def-test-method test-alternate ((test test-parser) :run nil) + + ;; An `or' matches the first parser that either succeeds or fails having + ;; consumed input. + (assert-parse ("abcd" #\a t t) (or #\a #\b)) + (assert-parse ("abcd" #\a t t) (or #\b #\a)) + (assert-parse ("abcd" '(#\b #\c) nil nil) (or #\b #\c)) + + ;; Strings don't consume if they fail. + (assert-parse ("abcd" "ab" t t) (or "cd" "ab")) + (assert-parse ("abcd" "ab" t t) (or "ad" "ab")) + (assert-parse ("abcd" '("ad" "ac") nil nil) (or "ad" "ac")) + + ;; But `seq' will if some component consumes. + (assert-parse ("abcd" '(#\d) nil t) (or (and #\a #\d) "ab")) + (assert-parse ("abcd" "ab" t t) (or (and #\c #\d) "ab")) + + ;; We can tame this using `peek' which rewinds the source if its argument + ;; fails, so as to hide consumption of input. + (assert-parse ("abcd" "ab" t t) (or (peek (and #\a #\d)) "ab")) + (assert-parse ("abcd" '(#\a #\b "cd") t t) + (seq ((foo (peek (seq ((foo #\a) (bar #\b)) (list foo bar)))) + (bar "cd")) + (append foo (list bar)))) + + ;; Failure indicators are union'd if they all fail. + (assert-parse ("abcd" '(#\q #\x #\z) nil nil) + (or #\q (peek (and #\a (or #\x #\q))) #\z)) + + ;; But if any of them consumed input then you only get the indicators from + ;; the consuming branch, because we committed to it when we consumed the + ;; input. + (assert-parse ("abcd" '(#\x #\q) nil t) + (or #\q #\z (and #\a (or #\q #\x))))) + +;;;-------------------------------------------------------------------------- +;;; Some tests with a simple recursive parser. + +(defstruct (node + (:predicate nodep) + (:constructor make-node (left data right))) + "Structure type for a simple binary tree." + left data right) + +(defun parse-tree (scanner) + "Parse a textual representation into a simple binary tree. + + The syntax is simple: + + TREE ::= EMPTY | `(' TREE CHAR TREE `)' + + There's an ambiguity in this syntax, at least if you have limited + lookahead: suppose you've just parsed the opening `(' of a TREE, and you + see another `(' -- is it the start of the non-empty left sub-TREE, or is + it the CHAR following an empty left sub-TREE? We opt for the first choice + always." + + ;; This came from another project, although it isn't actually used there. + ;; It exposed the weakness in an earlier design which prompted the addition + ;; of the CONSUMEDP flags to the parser protocol. + + (with-parser-context (character-scanner-context :scanner scanner) + (labels ((tree () + (parse (or (seq (#\( + (left (tree)) + (data :any) + (right (tree)) + #\)) + (make-node left data right)) + (values nil t nil))))) + (parse (seq ((tree (tree)) :eof) + tree))))) + +(defun parse-tree-lookahead (scanner) + "Parse a textual representation into a simple binary tree. + + The syntax is simple, and, indeed, the grammar's the same as for + `sod-parse-tree': + + TREE ::= EMPTY | `(' TREE CHAR TREE `)' + + But the rules are different. Instead of resolving the `ambiguity' between + TREE and CHAR when we find another `(' after the opening `(' of a TREE + deterministically in favour of TREE as `parse-tree' does, we try that + first, and backtrack if necessary." + + ;; Bison can do this, but you have to persuade it to use the scary GLR + ;; parser algorithm + + (with-parser-context (character-scanner-context :scanner scanner) + (labels ((tree () + (parse (or (peek (seq (#\( + (left (tree)) + (data :any) + (right (tree)) + #\)) + (make-node left data right))) + (values nil t nil))))) + (parse (seq ((tree (tree)) :eof) + tree))))) + +(def-test-method test-simple-tree-parser ((test test-parser) :run nil) + (assert-parse ("" nil t nil :scanner sc) (parse-tree sc)) + (assert-parse ("((a)b((c)d(e)))" t t t :scanner sc) (parse-tree sc)) + (assert-parse ("((a)b((c)d(e)))z" '(:eof) nil t :scanner sc) + (parse-tree sc)) + (assert-parse ("((a)b((c)d(e))" '(#\)) nil t :scanner sc) (parse-tree sc)) + (assert-parse ("(([)*(]))" t t t :scanner sc) (parse-tree sc)) + (assert-parse ("((()-()))" '(#\)) nil t :scanner sc) (parse-tree sc)) + (assert-parse ("((()-()))" t t t :scanner sc) (parse-tree-lookahead sc))) + +;;;-------------------------------------------------------------------------- +;;; Test expression parser. + +(defparse token (:context (context character-parser-context) parser) + (with-gensyms (value) + (expand-parser-spec context + `(seq ((,value ,parser) :whitespace) ,value)))) + +(let ((add (binop "+" (x y 5) `(+ ,x ,y))) + (sub (binop "-" (x y 5) `(- ,x ,y))) + (mul (binop "*" (x y 7) `(* ,x ,y))) + (div (binop "/" (x y 7) `(/ ,x ,y))) + (eq (binop "=" (x y 3 :assoc nil) `(= ,x ,y))) + (ne (binop "/=" (x y 3 :assoc nil) `(/= ,x ,y))) + (lt (binop "<" (x y 3 :assoc nil) `(< ,x ,y))) + (gt (binop ">" (x y 3 :assoc nil) `(> ,x ,y))) + (and (binop "&" (x y 2) `(and ,x ,y))) + (or (binop "|" (x y 1) `(or ,x ,y))) + (expt (binop "**" (x y 8 :assoc :right) `(** ,x ,y))) + (neg (preop "-" (x 9) `(- ,x))) + (not (preop "!" (x 2) `(not ,x))) + (fact (postop "!" (x 10) `(! ,x))) + (lp (lparen #\))) (rp (rparen #\))) + (lb (lparen #\])) (rb (rparen #\]))) + (defun test-parse-expr (string) + (with-parser-context (string-parser :string string) + (parse (seq (:whitespace + (value (expr (:nestedp nestedp) + (token (many (a 0 (+ (* a 10) it) :min 1) + (filter digit-char-p))) + (token (or (seq ("**") expt) + (seq ("/=") ne) + (seq (#\+) add) + (seq (#\-) sub) + (seq (#\*) mul) + (seq (#\/) div) + (seq (#\=) eq) + (seq (#\<) lt) + (seq (#\>) gt) + (seq (#\&) and) + (seq (#\|) or))) + (token (or (seq (#\() lp) + (seq (#\-) neg) + (seq (#\!) not))) + (token (or (seq (#\!) fact) + (when nestedp (seq (#\)) rp)))))) + (next (or :any (t :eof)))) + (cons value next)))))) + +(defun assert-expr-parse (string value winp consumedp) + (multiple-value-bind (v w c) (test-parse-expr string) + (flet ((message (what) + (format nil "expression ~S; ~A" string what))) + (cond (winp (assert-true w (message "winp")) + (assert-equal v value (message "value"))) + (t (assert-false w (message "winp")) + (assert-equal v value (message "expected")))) + (assert-eql c consumedp (message "consumedp"))))) + +(def-test-method test-expression-parser ((test test-parser) :run nil) + (assert-expr-parse "1 + 2 + 3" '((+ (+ 1 2) 3) . :eof) t t) + (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t) + (assert-expr-parse "1 * 2 + 3" '((+ (* 1 2) 3) . :eof) t t) + (assert-expr-parse "(1 + 2) * 3" '((* (+ 1 2) 3) . :eof) t t) + (assert-expr-parse "1 ** 2 ** 3" '((** 1 (** 2 3)) . :eof) t t) + (assert-expr-parse "1 + 2) * 3" '((+ 1 2) . #\)) t t) + (assert-expr-parse "1 + 2 * 3" '((+ 1 (* 2 3)) . :eof) t t) + + (assert-expr-parse "! 1 + 2 = 3 | 6 - 3 /= 12/6" + '((or (not (= (+ 1 2) 3)) + (/= (- 6 3) (/ 12 6))) + . :eof) + t t) + (assert-expr-parse "! 1 > 2 & ! 4 < 6 | 3 < 4 & 9 > 10" + '((or (and (not (> 1 2)) (not (< 4 6))) + (and (< 3 4) (> 9 10))) + . :eof) + t t) + + (assert-condition 'simple-error (test-parse-expr "(1 + 2")) + (assert-condition 'simple-error (test-parse-expr "(1 + 2]")) + (assert-condition 'simple-error (test-parse-expr "1 < 2 < 3"))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/test-scanner-charbuf.lisp b/src/parser/test-scanner-charbuf.lisp new file mode 100644 index 0000000..299e552 --- /dev/null +++ b/src/parser/test-scanner-charbuf.lisp @@ -0,0 +1,353 @@ +;;; -*-lisp-*- +;;; +;;; Test for the charbuf scanner +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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. + +;;; The charbuf scanner is a hairy beast and in need of a thorough going +;;; over. + +(cl:in-package #:sod-test) + +;;;-------------------------------------------------------------------------- +;;; Tests of the low-level seeking and fetching machinery. + +(defclass charbuf-test (test-case) (scanner)) +(add-test *sod-test-suite* (get-suite charbuf-test)) + +(defparameter *background-pattern* + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789." + "Basic pattern underlying our initial buffer contents. + + The pattern is one character short of the base-64 sequence `A-Za-z0-9./', + with the aim of making its length be prime to the actual buffer length -- + so that the pattern doesn't repeat exactly for many buffers.") +(assert (= (gcd (length *background-pattern*) charbuf-size) 1)) + +(defun make-pattern-string (start end) + "Return a string containing the buffer pattern between START and END. + + The most interesting cases occur at the boundaries between buffers; so we + shall want to put recognizable patterns there. The buffers are quite big + (we import `charbuf-size' off the books so that we don't actually have to + know exactly) but we should still fill with a repeating pattern so that we + can detect synchronization failures. + + We fill most of the buffer with the `*background-pattern*', which has been + chosen so as not to align nicely with the buffer size. Across the joins, + we write a string `<>', where the boundary is between `]' and `[', + and the numbers N and N + 1 are the numbers, in words, of the respective + buffers." + + (with-output-to-string (out) + (multiple-value-bind (n0 i0) (floor start charbuf-size) + (multiple-value-bind (n1 i1) (floor end charbuf-size) + + (do ((n n0 (1+ n))) ((> n n1)) + (let* ((l (format nil "[~R>>" n)) + (r (format nil "<<~R]" n)) + (m (length l)) + (q (length *background-pattern*)) + (i (if (= n n0) i0 0)) + (e (if (= n n1) i1 charbuf-size)) + (k (min (- charbuf-size m) e))) + (when (< i (length l)) + (write-string l out :start i :end (min e m)) + (setf i m)) + (do ((o (mod (+ (* charbuf-size n) i) q) 0)) + ((>= i k)) + (let ((p (min (- k i) (- q o)))) + (write-string *background-pattern* out :start o :end (+ o p)) + (incf i p))) + (when (< k e) + (write-string r out :start (- i k) :end (- e k))))))))) + +(defparameter *test-pattern* (make-pattern-string 0 10000) + "The pattern that our test scanner is reading.") + +(defmethod set-up ((test charbuf-test)) + (with-slots (scanner) test + (let ((stream (make-string-input-stream *test-pattern*))) + (setf scanner (make-instance 'charbuf-scanner + :stream stream + :filename ""))))) + +(defun skip (scanner n) + (assert (>= n 0)) + (charbuf-scanner-map scanner + (lambda (buf start end) + (declare (ignore buf)) + (let ((d (- end start))) + (if (>= d n) + (values t (+ start n)) + (progn (decf n d) (values nil 0))))))) + +(defun assert-string-next (scanner pos len) + "Assert that the next LEN characters from SCANNER are correct. + + That is, that they match the corresponding LEN characters starting at + position POS as returned by `make-pattern-string'." + (let ((want (make-pattern-string pos (+ pos len)))) + (dotimes (i len) + (assert-false (scanner-at-eof-p scanner)) + (assert-eql (scanner-current-char scanner) (char want i)) + (scanner-step scanner)))) + +(def-test-method test-pattern ((test charbuf-test) :run nil) + ;; Make sure the pattern is what we expect. This is a completely different + ;; (and considerably more stupid) way of generating the basic pattern up to + ;; a particular length. + (let* ((len (length *background-pattern*)) + (string "")) + (loop while (< (length string) len) + do (setf string (concatenate 'string string *test-pattern*))) + (loop for n from 0 + for i from 0 by charbuf-size below len + for l = (format nil "[~R>>" n) and r = (format nil "<<~R]" n) + for e = (- (+ i charbuf-size) (length r)) + do (setf (subseq string i) l) + when (< e len) do (setf (subseq string e) r)) + (assert-equal (subseq string 0 len) + (make-pattern-string 0 len)))) + +(def-test-method test-read ((test charbuf-test) :run nil) + ;; Test reading from various places. + (with-slots (scanner) test + (loop for prev = 0 then (+ pos len) + for (pos len) in '((0 10) (50 250) (4086 20) + (5000 3192) (9800 200)) do + (assert (>= pos prev)) + (skip scanner (- pos prev)) + (assert-string-next scanner pos len)) + (assert-true (scanner-at-eof-p scanner)))) + +(def-test-method test-unread ((test charbuf-test) :run nil) + ;; Torture test for `scanner-unread', which is distressingly hairy. + (with-slots (scanner) test + + (flet ((test (here next skip there note) + (assert-eql (scanner-current-char scanner) here + (format nil "Here (~A)." note)) + (scanner-step scanner) + (assert-eql (scanner-current-char scanner) next + (format nil "Next (~A)." note)) + (scanner-unread scanner here) + (with-scanner-place (place scanner) + (assert-eql (scanner-current-char scanner) here + (format nil "Here again (~A)." note)) + (scanner-step scanner) + (assert-eql (scanner-current-char scanner) next + (format nil "Next again (~A)." note)) + (skip scanner skip) + (assert-eql (scanner-current-char scanner) there + (format nil "There (~A)." note)) + (scanner-unread scanner there) + (with-scanner-place (another-place scanner) + (scanner-restore-place scanner place) + (assert-eql (scanner-current-char scanner) here + (format nil "Here restored (~A)." note)))))) + + (test #\[ #\z 51 #\0 "start") + (skip scanner 4095) + (test #\] #\[ 4096 #\[ "edge") + + ;; Check behaviour at EOF. Ought to test behaviour when EOF is on a + ;; buffer boundary too. + (skip scanner 5904) + (assert-false (scanner-at-eof-p scanner)) + (assert-eql (scanner-current-char scanner) #\t "EOF.") + (scanner-step scanner) + (assert-true (scanner-at-eof-p scanner)) + (scanner-unread scanner #\t) + (assert-false (scanner-at-eof-p scanner)) + (assert-eql (scanner-current-char scanner) #\t "EOF again.")))) + +(def-test-method test-rewind ((test charbuf-test) :run nil) + ;; Test reading, like before, but this time with rewinding. + (with-slots (scanner) test + (let* ((list '((0 10) (0 10000) (50 250) (4086 20) + (4095 4097) (5000 3192) (9999 1))) + (places (loop for prev = 0 then pos + for (pos) in list + do (skip scanner (- pos prev)) + collect (scanner-capture-place scanner)))) + (loop for (pos len) in list + for place in places do + (scanner-restore-place scanner place) + (assert-string-next scanner pos len)) + (assert-true (scanner-at-eof-p scanner))))) + +(def-test-method test-interval ((test charbuf-test) :run nil) + ;; Test fetching intervals of text. + (with-slots (scanner) test + (let* ((posns '(0 12 4080 4110 5000 9000 10000)) + (places (loop for prev = 0 then pos + for pos in posns + do (skip scanner (- pos prev)) + collect (scanner-capture-place scanner)))) + (loop for p0 in places + for i0 in posns do + (loop for p1 in places + for i1 in posns do + (if (< i1 i0) + (assert-condition 'error (scanner-interval p0 p1)) + (assert-equal (scanner-interval scanner p0 p1) + (make-pattern-string i0 i1) + (format nil "Mismatch interval ~A .. ~A." + i0 i1))) + (assert-true (scanner-at-eof-p scanner))))))) + +;;;-------------------------------------------------------------------------- +;;; Tests of the position tracking machinery. + +(defparameter *position-test-text* + ;; Use a roundabout method of getting tabs in there, so that they don't get + ;; screwed by strange editors and suchlike. + (substitute #\tab #\@ "Line one +Line two is rather longer, but not noticeably more interesting. +Line three explains that line four contains column numbers mod 10. +012345678@6789@@2345678@012 +@@Line five is indented somewhat.") + "Text for the position-tracking test. + + The text should /look/ like the following. Note that this text here may + get trashed by tab/space conversions and whatever, and I've indented it so + that it doesn't look daft in the source; but the columns should remain + where they are. + + 0 1 2 3 4 5 6 7 + 0123456789012345678901234567890123456789012345678901234567890123456789012 + Line one + Line two is rather longer, but not noticeably more interesting. + Line three explains that line four contains column numbers mod 10. + 012345678 6789 2345678 012 + Line five is indented somewhat. + + It would be nice at some point to add additional tests for edge cases + around buffer boundaries. This isn't completely essential, though: the + current implementation manages positions fairly independently of the + buffering.") + +(defparameter *known-positions* + '( + ;; The first few line aren't actually very interesting. We'll + ;; check the start and end positions, and maybe a few in the + ;; middle. Note that a newline character is logically a part of + ;; the preceding line. + (0 #\L 1 0 #\i 1 1 0) (5 #\o 1 5 #\n 1 6 5) (8 #\newline 1 8 #\L 2 0 0) + (9 #\L 2 0 #\i 2 1 0) (72 #\newline 2 63 #\L 3 0 0) + (73 #\L 3 0 #\i 3 1 0) (139 #\newline 3 66 #\0 4 0 0) + + ;; Now for the line with the fancy tabbings. + (140 #\0 4 0 #\1 4 1 0) + (148 #\8 4 8 #\tab 4 9 8) ; nothing so far + (149 #\tab 4 9 #\6 4 16 15) ; the tab itself just follows on + (150 #\6 4 16 #\7 4 17 16) ; but the char after is tabbed + (154 #\tab 4 20 #\tab 4 24 23) ; next tab position + (155 #\tab 4 24 #\2 4 32 31) ; two in a row + (156 #\2 4 32 #\3 4 33 32) ; should be here now + (162 #\8 4 38 #\tab 4 39 38) ; skip to the next bit + (163 #\tab 4 39 #\0 4 40 39) ; tab is here + (164 #\0 4 40 #\1 4 41 40) ; and doesn't move us much + (166 #\2 4 42 #\newline 4 43 42) ; last actual character on the line + (167 #\newline 4 43 #\tab 5 0 0) ; and the ending newline + + ;; And the final line. + (168 #\tab 5 0 #\tab 5 8 7) ; first tab on next line + (169 #\tab 5 8 #\L 5 16 15) ; and the second + (170 #\L 5 16 #\i 5 17 16) ; beginning of the text + (200 #\. 5 46 :eof 5 47 46) ; last character in the stream + (201 :eof 5 47)) ; but eof has a position too + "List of character positions, characters and line/column numbers. + + The characters are there for sanity-checking purposes. The format is + + (INDEX CHAR LINE COLUMN NEXT-CHAR + NEXT-LINE NEXT-COLUMN REWIND-COLUMN) + + which asserts that the character at INDEX is CHAR, found at the given LINE + and COLUMN, that the next character is NEXT-CHAR, at the NEXT-LINE and + NEXT-COLUMN, and if one unreads from there, it will be (possibly + erroneously) claimed that the character at INDEX is at REWIND-COLUMN. + (Restoring a captured place shouldn't get the column wrong -- only + unreading.) + + The symbol `:eof' means that there is no character at the given INDEX, + because the file has already ended. However, EOF has a position which + should be correct, and it should be possible to unread from EOF.") + +(defclass charbuf-position-test (test-case) (scanner)) +(add-test *sod-test-suite* (get-suite charbuf-position-test)) + +(defmethod set-up ((test charbuf-position-test)) + (with-slots (scanner) test + (let ((stream (make-string-input-stream *position-test-text*))) + (setf scanner (make-instance 'charbuf-scanner + :stream stream + :filename ""))))) + +(defun check-position (scanner pos char line column note) + (if (eq char :eof) + (assert-true (scanner-at-eof-p scanner) + (format nil "EOF, position ~A (~A)." pos note)) + (assert-eql char (scanner-current-char scanner) + (format nil "Character, position ~A (~A)." pos note))) + (assert-eql line (scanner-line scanner) + (format nil "Line number, position ~A (~A)." pos note)) + (assert-eql column (scanner-column scanner) + (format nil "Column number, position ~A (~A)." pos note))) + +(def-test-method test-simple-positions + ((test charbuf-position-test) :run nil) + (with-slots (scanner) test + (loop for prev = 0 then pos + for (pos char line column) in *known-positions* do + (loop repeat (- pos prev) do (scanner-step scanner)) + (check-position scanner pos char line column "simple")))) + +(def-test-method test-rewind-positions + ((test charbuf-position-test) :run nil) + (with-slots (scanner) test + (let ((places (loop for prev = 0 then pos + for (pos char line column) in *known-positions* do + (skip scanner (- pos prev)) + (check-position scanner pos char line column "skip") + collect (scanner-capture-place scanner)))) + (loop for place in places + for (pos char line column + next-char next-line next-column + rewind-column) + in *known-positions* do + (scanner-restore-place scanner place) + (check-position scanner pos char line column "rewind") + (unless (eq char :eof) + (scanner-step scanner) + (check-position scanner (1+ pos) next-char + next-line next-column "step") + (scanner-unread scanner char) + (check-position scanner pos char line rewind-column + "unread") + (scanner-step scanner) + (check-position scanner (1+ pos) next-char + next-line next-column "restep")))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-c-types.lisp b/src/proto-c-types.lisp new file mode 100644 index 0000000..304562a --- /dev/null +++ b/src/proto-c-types.lisp @@ -0,0 +1,259 @@ +;;; -*-lisp-*- +;;; +;;; Protocol for C type representation +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Root classes and common access protocol. + +;; It seems more useful to put the root class here, so that we can provide +;; methods specialized on it, e.g., PRINT-OBJECT. + +(export 'c-type) +(defclass c-type () + () + (:documentation + "Base class for C type objects.")) + +(export '(qualifiable-c-type c-type-qualifiers)) +(defclass qualifiable-c-type (c-type) + ((qualifiers :initarg :qualifiers :initform nil + :type list :reader c-type-qualifiers)) + (:documentation + "Base class for C types which can be qualified.")) + +(export 'canonify-qualifiers) +(defun canonify-qualifiers (qualifiers) + "Return a canonical list of qualifiers." + (delete-duplicates (sort (copy-list qualifiers) #'string<))) + +(export 'c-type-subtype) +(defgeneric c-type-subtype (type) + (:documentation + "For compound types, return the base type.")) + +;;;-------------------------------------------------------------------------- +;;; Comparison protocol. + +(export 'c-type-equal-p) +(defgeneric c-type-equal-p (type-a type-b) + (:method-combination and) + (:documentation + "Answers whether two types TYPE-A and TYPE-B are structurally equal. + + Here, `structurally equal' means that they have the same qualifiers, + similarly spelt names, and structurally equal components.") + (:method and (type-a type-b) + (eql (class-of type-a) (class-of type-b)))) + +(defmethod c-type-equal-p and ((type-a qualifiable-c-type) + (type-b qualifiable-c-type)) + (equal (canonify-qualifiers (c-type-qualifiers type-a)) + (canonify-qualifiers (c-type-qualifiers type-b)))) + +;;;-------------------------------------------------------------------------- +;;; C syntax output protocol. + +(export 'pprint-c-type) +(defgeneric pprint-c-type (type stream kernel) + (:documentation + "Pretty-printer for C types. + + Print TYPE to STREAM. In the middle of the declarator, call the function + KERNEL with one argument: whether it needs a leading space.") + (:method :around (type stream kernel) + (typecase kernel + (null (pprint-c-type type stream + (lambda (stream prio spacep) + (declare (ignore stream prio spacep)) + nil))) + ((or function symbol) (call-next-method)) + (t (pprint-c-type type stream + (lambda (stream prio spacep) + (declare (ignore prio)) + (when spacep + (c-type-space stream)) + (princ kernel stream))))))) + +(export 'c-type-space) +(defun c-type-space (stream) + "Print a space and a miser-mode newline to STREAM. + + This is the right function to call in a PPRINT-C-TYPE kernel function when + the SPACEP argument is true." + (pprint-indent :block 2 stream) + (write-char #\space stream) + (pprint-newline :miser stream)) + +(defun maybe-in-parens* (stream condition thunk) + "Helper function for the MAYBE-IN-PARENS macro." + (multiple-value-bind (prefix suffix) + (if condition (values "(" ")") (values "" "")) + (pprint-logical-block (stream nil :prefix prefix :suffix suffix) + (funcall thunk stream)))) + +(export 'maybe-in-parens) +(defmacro maybe-in-parens ((stream condition) &body body) + "Evaluate BODY; if CONDITION, write parens to STREAM around it. + + This macro is useful for implementing the PPRINT-C-TYPE method on compound + types. The BODY is evaluated in the context of a logical block printing + to STREAM. If CONDITION is non-nil, then the block will have open/close + parens as its prefix and suffix; otherwise they will be empty. + + The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol." + `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body))) + +(export 'format-qualifiers) +(defun format-qualifiers (quals) + "Return a string listing QUALS, with a space after each." + (format nil "~{~(~A~) ~}" quals)) + +;;;-------------------------------------------------------------------------- +;;; S-expression notation protocol. + +(export 'print-c-type) +(defgeneric print-c-type (stream type &optional colon atsign) + (:documentation + "Print an abbreviated syntax for TYPE to the STREAM. + + This function is suitable for use in FORMAT's ~/.../ command.")) + +(export 'expand-c-type-spec) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defgeneric expand-c-type-spec (spec) + (:documentation + "Expand SPEC into Lisp code to construct a C type.") + (:method ((spec list)) + (expand-c-type-form (car spec) (cdr spec)))) + (defgeneric expand-c-type-form (head tail) + (:documentation + "Expand a C type list beginning with HEAD.") + (:method ((name (eql 'lisp)) tail) + `(progn ,@tail)))) + +(export 'c-type) +(defmacro c-type (spec) + "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC." + (expand-c-type-spec spec)) + +(export 'define-c-type-syntax) +(defmacro define-c-type-syntax (name bvl &rest body) + "Define a C-type syntax function. + + A function defined by BODY and with lambda-list BVL is associated with the + NAME. When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this + function with the argument list STUFF." + (with-gensyms (head tail) + (multiple-value-bind (doc decls body) (parse-body body) + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defmethod expand-c-type-form ((,head (eql ',name)) ,tail) + ,@doc + (destructuring-bind ,bvl ,tail + ,@decls + ,@body)) + ',name)))) + +(export 'c-type-alias) +(defmacro c-type-alias (original &rest aliases) + "Make ALIASES behave the same way as the ORIGINAL type." + (with-gensyms (head tail) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(mapcar (lambda (alias) + `(defmethod expand-c-type-form + ((,head (eql ',alias)) ,tail) + (expand-c-type-form ',original ,tail))) + aliases) + ',aliases))) + +(export 'defctype) +(defmacro defctype (names value) + "Define NAMES all to describe the C-type VALUE. + + NAMES can be a symbol (treated as a singleton list), or a list of symbols. + The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE. It will + be expanded once at run-time." + (let* ((names (if (listp names) names (list names))) + (namevar (gensym "NAME")) + (typevar (symbolicate 'c-type- (car names)))) + `(progn + (defparameter ,typevar ,(expand-c-type-spec value)) + (eval-when (:compile-toplevel :load-toplevel :execute) + ,@(mapcar (lambda (name) + `(defmethod expand-c-type-spec ((,namevar (eql ',name))) + ',typevar)) + names)) + 'names))) + +(export 'c-name-case) +(defun c-name-case (name) + "Convert NAME to suitable case. + + Strings are returned as-is; symbols are squashed to lower-case and hyphens + are replaced by underscores." + (typecase name + (symbol (with-output-to-string (out) + (loop for ch across (symbol-name name) + do (cond ((alpha-char-p ch) + (write-char (char-downcase ch) out)) + ((or (digit-char-p ch) + (char= ch #\_)) + (write-char ch out)) + ((char= ch #\-) + (write-char #\_ out)) + (t + (error "Bad character in C name ~S." name)))))) + (t name))) + +;;;-------------------------------------------------------------------------- +;;; Function arguments. + +(export '(argument argumentp make-argument argument-name argument-type)) +(defstruct (argument (:constructor make-argument (name type)) + (:predicate argumentp)) + "Simple structure representing a function argument." + name + type) + +(export 'commentify-argument-name) +(defgeneric commentify-argument-name (name) + (:documentation + "Produce a `commentified' version of the argument. + + The default behaviour is that temporary argument names are simply omitted + (NIL is returned); otherwise, `/*...*/' markers are wrapped around the + printable representation of the argument.") + (:method ((name null)) nil) + (:method ((name t)) (format nil "/*~A*/" name))) + +;;;-------------------------------------------------------------------------- +;;; Printing objects. + +(defmethod print-object ((object c-type) stream) + (if *print-escape* + (format stream "~:@" object) + (pprint-c-type object stream nil))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-class-finalize.lisp b/src/proto-class-finalize.lisp new file mode 100644 index 0000000..c7de255 --- /dev/null +++ b/src/proto-class-finalize.lisp @@ -0,0 +1,96 @@ +;;; -*-lisp-*- +;;; +;;; Class finalization protocol +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Protocol definition. + +(defgeneric compute-cpl (class) + (:documentation + "Returns the class precedence list for CLASS.")) + +(defgeneric compute-chains (class) + (:documentation + "Compute the layout chains for CLASS. + + Returns the following three values. + + * the head of the class's primary chain; + + * the class's primary chain as a list, most- to least-specific; and + + * the complete collection of chains, as a list of lists, each most- to + least-specific, with the primary chain first. + + These values will be stored in the CHAIN-HEAD, CHAIN and CHAINS slots. + + If the chains are ill-formed (i.e., not distinct) then an error is + signalled.")) + +(defgeneric check-sod-class (class) + (:documentation + "Check the CLASS for validity. + + This is done as part of class finalization. The checks performed are as + follows. + + * The class name and nickname, and the names of messages, obey the + rules (see VALID-NAME-P). + + * The messages and slots have distinct names. + + * The classes in the class-precedence-list have distinct nicknames. + + * The chain-link is actually a proper (though not necessarily direct) + superclass. + + * The chosen metaclass is actually a subclass of all of the + superclasses' metaclasses. + + Returns true if all is well; false (and signals errors) if anything was + wrong.")) + +(defgeneric finalize-sod-class (class) + (:documentation + "Computes all of the gory details about a class. + + Once one has stopped inserting methods and slots and so on into a class, + one needs to finalize it to determine the layout structure and the class + precedence list and so on. More precisely that gets done is this: + + * Related classes (i.e., direct superclasses and the metaclass) are + finalized if they haven't been already. + + * If you've been naughty and failed to store a list of slots or + whatever, then an empty list is inserted. + + * The class precedence list is computed and stored. + + * The class is checked for compiance with the well-formedness rules. + + * The layout chains are computed.")) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-class-layout.lisp b/src/proto-class-layout.lisp new file mode 100644 index 0000000..bf1480b --- /dev/null +++ b/src/proto-class-layout.lisp @@ -0,0 +1,320 @@ +;;; -*-lisp-*- +;;; +;;; Class layout protocol +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Effective slot objects. + +(export '(effective-slot effective-slot-class + effective-slot-direct-slot effective-slot-initializer)) +(defclass effective-slot () + ((class :initarg :class :type sod-slot :reader effective-slot-class) + (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot) + (initializer :initarg :initializer :type (or sod-initializer null) + :reader effective-slot-initializer)) + (:documentation + "Describes a slot and how it's meant to be initialized. + + Specifically, an effective slot object states that in an instance of + CLASS, a particular SLOT is initializd by a particular INITIALIZER. Note + that the CLASS is a subclass of the SLOT's defining class, and not + necessarily the same. + + Effective slot objects are usually found in `islots' objects.")) + +(export 'find-slot-initializer) +(defgeneric find-slot-initializer (class slot) + (:documentation + "Return the most specific initializer for SLOT, starting from CLASS.")) + +(export 'compute-effective-slot) +(defgeneric compute-effective-slot (class slot) + (:documentation + "Construct an effective slot from the supplied direct slot. + + SLOT is a direct slot defined on CLASS or one of its superclasses. + (Metaclass initializers are handled using a different mechanism.)")) + +;;;-------------------------------------------------------------------------- +;;; Instance layout. + +;;; islots + +(export '(islots islots-class islots-subclass islots-slots)) +(defclass islots () + ((class :initarg :class :type sod-class :reader islots-class) + (subclass :initarg :subclass :type sod-class :reader islots-subclass) + (slots :initarg :slots :type list :reader islots-slots)) + (:documentation + "Contains effective slot definitions for a class's direct slots. + + In detail: SLOTS is a list of effective slot objects corresponding to + CLASS's direct slots, and containing initializers computed relative to + SUBCLASS.")) + +(export 'compute-islots) +(defgeneric compute-islots (class subclass) + (:documentation + "Return `islots' for a particular CLASS and SUBCLASS. + + Initializers for the slots should be taken from the most specific + superclass of SUBCLASS.")) + +;;; vtable-pointer + +(export '(vtable-pointer vtable-pointer-class + vtable-pointer-chain-head vtable-pointer-chain-tail)) +(defclass vtable-pointer () + ((class :initarg :class :type sod-class :reader vtable-pointer-class) + (chain-head :initarg :chain-head :type sod-class + :reader vtable-pointer-chain-head) + (chain-tail :initarg :chain-tail :type sod-class + :reader vtable-pointer-chain-tail)) + (:documentation + "Represents a pointer to a class's vtable. + + There's one of these for each of CLASS's chains. This particular one + belongs to the chain headed by CHAIN-HEAD; the most specific superclass of + CLASS on that chain is CHAIN-TAIL. (The tail is useful because we can -- + and do -- use structure types defined by the tail class for non-primary + chains.)")) + +;;; ichain + +(export '(ichain ichain-class ichain-head ichain-tail ichain-body)) +(defclass ichain () + ((class :initarg :class :type sod-class :reader ichain-class) + (chain-head :initarg :chain-head :type sod-class :reader ichain-head) + (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail) + (body :initarg :body :type list :reader ichain-body)) + (:documentation + "Contains instance data for a particular chain of superclasses. + + In detail: describes instance data for one of CLASS's chains, specifically + the chain headed by CHAIN-HEAD. The CHAIN-TAIL is the most specific + superclass of CLASS on the chain in question. The BODY is a list of + layout objects to be included. + + An `ilayout' object maintains a list of `ichain' objects, one for each of + a class's chains.")) + +(export 'compute-ichain) +(defgeneric compute-ichain (class chain) + (:documentation + "Return an ICHAIN for a particular CHAIN of CLASS's superclasses. + + The CHAIN is a list of classes, with the least specific first -- so the + chain head is the first element.")) + +;;; ilayout + +(export '(ilayout ilayout-class ilayout-ichains)) +(defclass ilayout () + ((class :initarg :class :type sod-class :reader ilayout-class) + (ichains :initarg :ichains :type list :reader ilayout-ichains)) + (:documentation + "All of the instance layout for a class. + + Describes the layout of an instance of CLASS. The list ICHAINS contains + an `ichain' object for each chain of CLASS.")) + +(export 'compute-ilayout) +(defgeneric compute-ilayout (class) + (:documentation + "Compute and return an instance layout for CLASS.")) + +;;;-------------------------------------------------------------------------- +;;; Vtable layout. + +;;; vtmsgs + +(defclass vtmsgs () + ((class :initarg :class :type sod-class :reader vtmsgs-class) + (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass) + (chain-head :initarg :chain-head :type sod-class + :reader vtmsgs-chain-head) + (chain-tail :initarg :chain-tail :type sod-class + :reader vtmsgs-chain-tail) + (entries :initarg :entries :type list :reader vtmsgs-entries)) + (:documentation + "The message dispatch table for a particular class. + + In detail, this lists the `method-entry' objects for the messages defined + by a particular CLASS, where the effective methods are specialized for the + SUBCLASS; the method entries adjust the instance pointer argument + appropriately for a call via the vtable for the chain headed by + CHAIN-HEAD. The CHAIN-TAIL is the most specific superclass of SUBCLASS on + this chain. The ENTRIES are a list of `method-entry' objects.")) + +(export 'compte-vtmsgs) +(defgeneric compute-vtmsgs (class subclass chain-head chain-tail) + (:documentation + "Return a VTMSGS object containing method entries for CLASS. + + The CHAIN-HEAD describes which chain the method entries should be + constructed for. + + The default method simply calls MAKE-METHOD-ENTRY for each of the methods + and wraps a VTMSGS object around them. This ought to be enough for almost + all purposes.")) + +;;; class-pointer + +(export '(class-pointer class-pointer-class class-pointer-chain-head + class-pointer-metaclass class-pointer-meta-chain-head)) +(defclass class-pointer () + ((class :initarg :class :type sod-class :reader class-pointer-class) + (chain-head :initarg :chain-head :type sod-class + :reader class-pointer-chain-head) + (metaclass :initarg :metaclass :type sod-class + :reader class-pointer-metaclass) + (meta-chain-head :initarg :meta-chain-head :type sod-class + :reader class-pointer-meta-chain-head)) + (:documentation + "Represents a pointer to a class object for the instance's class. + + This is somewhat complicated because there are two degrees of freedom. An + instance of `class-pointer' is a pointer from a vtable to an `ichain' of + the the class's metaclass instance. In particular, `class-pointer' + instance represents a pointer in a vtable constructed for CLASS and + attached to the chain headed by CHAIN-HEAD; it points to an instance of + METACLASS, and specifically to the `ichain' substructure corresponding to + the chain headed by META-CHAIN-HEAD, which will be a superclass of + METACLASS. + + I'm sorry if this is confusing.")) + +(export 'make-class-pointer) +(defgeneric make-class-pointer (class chain-head metaclass meta-chain-head) + (:documentation + "Return a class pointer to a metaclass chain.")) + +;;; base-offset + +(export '(base-offset base-offset-class base-offset-chain-head)) +(defclass base-offset () + ((class :initarg :class :type sod-class :reader base-offset-class) + (chain-head :initarg :chain-head :type sod-class + :reader base-offset-chain-head)) + (:documentation + "The offset of this chain to the `ilayout' base. + + We're generating a vtable for CLASS, attached to the chain headed by + CHAIN-HEAD. Fortunately (and unlike `class-pointer'), the chain head can + do double duty, since it also identifies the `ichain' substructure of the + class's `ilayout' whose offset we're interested in.")) + +(export 'make-base-offset) +(defgeneric make-base-offset (class chain-head) + (:documentation + "Return the base offset object for CHAIN-HEAD ichain.")) + +;;; chain-offset + +(export '(chain-offset chain-offset-class + chain-offset-chain-head chain-offset-target-head)) +(defclass chain-offset () + ((class :initarg :class :type sod-class :reader chain-offset-class) + (chain-head :initarg :chain-head :type sod-class + :reader chain-offset-chain-head) + (target-head :initarg :target-head :type sod-class + :reader chain-offset-target-head)) + (:documentation + "The offset to a different `ichain'. + + We're generating a vtable for CLASS, attached to the chain headed by + CHAIN-HEAD. This instance represents an offset to the (different) chain + headed by TARGET-HEAD. + + This is, strictly speaking, redundant. We could do as well by using the + base offset and finding the offset to the target class in the class + object's metadata; but that would either require a search or we'd have to + be able work out the target chain's index in the table.")) + +(defgeneric make-chain-offset (class chain-head target-head) + (:documentation + "Return the offset from CHAIN-HEAD to TARGET-HEAD.")) + +;;; vtable + +(export '(vtable vtable-class vtable-body + vtable-chain-head vtable-chain-tail)) +(defclass vtable () + ((class :initarg :class :type sod-class :reader vtable-class) + (chain-head :initarg :chain-head :type sod-class + :reader vtable-chain-head) + (chain-tail :initarg :chain-tail :type sod-class + :reader vtable-chain-tail) + (body :initarg :body :type list :reader vtable-body)) + (:documentation + "A vtable holds all of the per-chain static information for a class. + + Each chain of CLASS has its own vtable; the `vtable' object remembers the + least specific (CHAIN-HEAD) and most specific (CHAIN-TAIL) superclasses of + CLASS on that chain. (This is useful because we can reuse vtable + structure types from superclasses for chains other than the primary chain + -- i.e., the one in which CLASS itself appears.) + + The BODY is a list of vtable items, including `vtmsgs' structures, + `chain-offset's, `class-pointers', and a `base-offset'.")) + +(export 'compute-vtable-items) +(defgeneric compute-vtable-items (class super chain-head chain-tail emit) + (:documentation + "Emit vtable items for a superclass of CLASS. + + This function is called for each superclass SUPER of CLASS reached on the + chain headed by CHAIN-HEAD. The function should call EMIT for each + vtable item it wants to write. + + The right way to check to see whether items have already been emitted + (e.g., has an offset to some other chain been emitted?) is as follows: + + * In a method (ideally an `:around'-method) on `compute-vtable', bind a + special variable to an empty list or hash table. + + * In a method on this function, check the variable or hash table. + + This function is the real business end of `compute-vtable'.")) + +(export 'compute-vtable) +(defgeneric compute-vtable (class chain) + (:documentation + "Compute the vtable layout for a chain of CLASS. + + The CHAIN is a list of classes, with the least specific first. + + There is a default method which invokes `compute-vtable-items' to do the + difficult work.")) + +(export 'compute-vtables) +(defgeneric compute-vtables (class) + (:documentation + "Compute the vtable layouts for CLASS. + + Returns a list of VTABLE objects in the order of CLASS's chains.")) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-class-make.lisp b/src/proto-class-make.lisp new file mode 100644 index 0000000..692da40 --- /dev/null +++ b/src/proto-class-make.lisp @@ -0,0 +1,293 @@ +;;; -*-lisp-*- +;;; +;;; Class construction protocol +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Classes. + +(export 'make-sod-class) +(defun make-sod-class (name superclasses pset &optional location) + "Construct and return a new SOD class with the given NAME and SUPERCLASSES. + + This is the main constructor function for classes. The protocol works as + follows. The `:lisp-class' property in PSET is checked: if it exists, it + must be a symbol naming a (CLOS) class, which is used in place of + `sod-class'. All of the arguments are then passed to `make-instance'; + further behaviour is left to the standard CLOS instance construction + protocol; for example, `sod-class' defines an `:after'-method on + SHARED-INITIALIZE. + + Minimal sanity checking is done during class construction; most of it is + left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS). + + Unused properties in PSET are diagnosed as errors." + + (with-default-error-location (location) + (let* ((pset (property-set pset)) + (class (make-instance (get-property pset :lisp-class :symbol + 'sod-class) + :name name + :superclasses superclasses + :location (file-location location) + :pset pset))) + (check-unused-properties pset) + class))) + +(export 'guess-metaclass) +(defgeneric guess-metaclass (class) + (:documentation + "Determine a suitable metaclass for the CLASS. + + The default behaviour is to choose the most specific metaclass of any of + the direct superclasses of CLASS, or to signal an error if that failed.")) + +;;;-------------------------------------------------------------------------- +;;; Slots and slot initializers. + +(export 'make-sod-slot) +(defgeneric make-sod-slot (class name type pset &optional location) + (:documentation + "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS. + + This is the main constructor function for slots. This is a generic + function primarily so that the CLASS can intervene in the construction + process. The default method uses the `:lisp-class' property (defaulting + to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then + constructed by `make-instance' passing the arguments as initargs; further + behaviour is left to the standard CLOS instance construction protocol; for + example, `sod-slot' defines an `:after'-method on `shared-initialize'. + + Unused properties on PSET are diagnosed as errors.")) + +(export 'make-sod-instance-initializer) +(defgeneric make-sod-instance-initializer + (class nick name value-kind value-form pset &optional location) + (:documentation + "Construct and attach an instance slot initializer, to CLASS. + + This is the main constructor function for instance initializers. This is + a generic function primarily so that the CLASS can intervene in the + construction process. The default method looks up the slot using + `find-instance-slot-by-name', calls `make-sod-initializer-using-slot' to + actually make the initializer object, and adds it to the appropriate list + in CLASS. + + Unused properties on PSET are diagnosed as errors.")) + +(export 'make-sod-class-initializer) +(defgeneric make-sod-class-initializer + (class nick name value-kind value-form pset &optional location) + (:documentation + "Construct and attach a class slot initializer, to CLASS. + + This is the main constructor function for class initializers. This is a + generic function primarily so that the CLASS can intervene in the + construction process. The default method looks up the slot using + `find-class-slot-by-name', calls `make-sod-initializer-using-slot' to + actually make the initializer object, and adds it to the appropriate list + in CLASS. + + Unused properties on PSET are diagnosed as errors.")) + +(export 'make-sod-initializer-using-slot) +(defgeneric make-sod-initializer-using-slot + (class slot init-class value-kind value-form pset location) + (:documentation + "Common construction protocol for slot initializers. + + This generic function does the common work for constructing instance and + class initializers. It can usefully be specialized according to both the + class and slot types. The default method uses the `:lisp-class' property + (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The + slot is then constructed by `make-instance' passing the arguments as + initargs; further behaviour is left to the standard CLOS instance + construction protocol; for example, `sod-initializer' defines an + `:after'-method on `shared-initialize'. + + Diagnosing unused properties is left for the caller (usually + `make-sod-instance-initializer' or `make-sod-class-initializer') to do. + The caller is also expected to have set `with-default-error-location' if + appropriate. + + You are not expected to call this generic function directly; it's more + useful as a place to hang methods for custom initializer classes.")) + +;;;-------------------------------------------------------------------------- +;;; Messages and methods. + +(export 'make-sod-message) +(defgeneric make-sod-message (class name type pset &optional location) + (:documentation + "Construct and attach a new message with given NAME and TYPE, to CLASS. + + This is the main constructor function for messages. This is a generic + function primarily so that the CLASS can intervene in the construction + process. The default method uses the `:lisp-class' property (defaulting + to `sod-message') to choose a (CLOS) class to instantiate. The message is + then constructed by `make-instance' passing the arguments as initargs; + further behaviour is left to the standard CLOS instance construction + protocol; for example, `sod-message' defines an `:after'-method on + `shared-initialize'. + + Unused properties on PSET are diagnosed as errors.")) + +(export 'make-sod-method) +(defgeneric make-sod-method + (class nick name type body pset &optional location) + (:documentation + "Construct and attach a new method to CLASS. + + This is the main constructor function for methods. This is a generic + function primarily so that the CLASS can intervene in the message lookup + process, though this is actually a fairly unlikely occurrence. + + The default method looks up the message using `find-message-by-name', + invokes `make-sod-method-using-message' to make the method object, and + then adds the method to the class's list of methods. This split allows + the message class to intervene in the class selection process, for + example. + + Unused properties on PSET are diagnosed as errors.")) + +(export 'make-sod-method-using-message) +(defgeneric make-sod-method-using-message + (message class type body pset location) + (:documentation + "Main construction subroutine for method construction. + + This is a generic function so that it can be specialized according to both + a class and -- more particularly -- a message. The default method uses + the `:lisp-class' property (defaulting to the result of calling + `sod-message-method-class') to choose a (CLOS) class to instantiate. The + method is then constructed by `make-instance' passing the arguments as + initargs; further behaviour is left to the standard CLOS instance + construction protocol; for example, `sod-method' defines an + `:after'-method on `shared-initialize'. + + Diagnosing unused properties is left for the caller (usually + `make-sod-method') to do. The caller is also expected to have set + `with-default-error-location' if appropriate. + + You are not expected to call this generic function directly; it's more + useful as a place to hang methods for custom method classes.")) + +(export 'sod-message-method-class) +(defgeneric sod-message-method-class (message class pset) + (:documentation + "Return the preferred class for methods on MESSAGE. + + The message can inspect the PSET to decide on a particular message. A + `:lisp-class' property will usually override this decision: it's then the + programmer's responsibility to ensure that the selected method class is + appropriate.")) + +(export 'check-message-type) +(defgeneric check-message-type (message type) + (:documentation + "Check that TYPE is a suitable type for MESSAGE. Signal errors if not. + + This is separated out of `shared-initialize', where it's called, so that + it can be overridden conveniently by subclasses.")) + +(export 'check-method-type) +(defgeneric check-method-type (method message type) + (:documentation + "Check that TYPE is a suitable type for METHOD. Signal errors if not. + + This is separated out of `shared-initialize', where it's called, so that + it can be overridden conveniently by subclasses.")) + +;;;-------------------------------------------------------------------------- +;;; Builder macros. + +(export 'define-sod-class) +(defmacro define-sod-class (name (&rest superclasses) &body body) + "Construct a new SOD class called NAME in the current module. + + The new class has the named direct SUPERCLASSES, which should be a list of + strings. + + The BODY begins with a sequence of alternating keyword/value pairs + defining properties for the new class. The keywords are (obviously) not + evaluated, but the value forms are. + + The remainder of the BODY are a sequence of forms to be evaluated as an + implicit `progn'. Additional macros are available to the BODY, to make + defining the class easier. + + In the following, NAME is a string giving a C identifier; NICK is a string + giving the nickname of a superclass; TYPE is a C type using S-expression + notation. + + * message NAME TYPE &rest PLIST + + * method NICK NAME TYPE BODY &rest PLIST + + * slot NAME TYPE &rest PLIST + + * instance-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST + + * class-initializer NICK NAME VALUE-KIND VALUE-FORM &rest PLIST" + + (let ((plist nil) + (classvar (gensym "CLASS-"))) + (loop + (when (or (null body) + (not (keywordp (car body)))) + (return)) + (push (pop body) plist) + (push (pop body) plist)) + `(let ((,classvar (make-sod-class ,name + (mapcar #'find-sod-class + (list ,@superclasses)) + (make-property-set + ,@(nreverse plist))))) + (macrolet ((message (name type &rest plist) + `(make-sod-message ,',classvar ,name (c-type ,type) + (make-property-set ,@plist))) + (method (nick name type body &rest plist) + `(make-sod-method ,',classvar ,nick ,name (c-type ,type) + ,body (make-property-set ,@plist))) + (slot (name type &rest plist) + `(make-sod-slot ,',classvar ,name (c-type ,type) + (make-property-set ,@plist))) + (instance-initializer + (nick name value-kind value-form &rest plist) + `(make-sod-instance-initializer ,',classvar ,nick ,name + ,value-kind ,value-form + (make-property-set + ,@plist))) + (class-initializer + (nick name value-kind value-form &rest plist) + `(make-sod-class-initializer ,',classvar ,nick ,name + ,value-kind ,value-form + (make-property-set + ,@plist)))) + ,@body + (finalize-sod-class ,classvar) + (add-to-module *module* ,classvar))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/codegen.lisp b/src/proto-codegen.lisp similarity index 66% rename from codegen.lisp rename to src/proto-codegen.lisp index fc6a408..24b8c38 100644 --- a/codegen.lisp +++ b/src/proto-codegen.lisp @@ -1,13 +1,13 @@ ;;; -*-lisp-*- ;;; -;;; Code generator for effective methods +;;; Code generation protocol ;;; ;;; (c) 2009 Straylight/Edgeware ;;; ;;;----- Licensing notice --------------------------------------------------- ;;; -;;; This file is part of the Simple Object Definition system. +;;; This file is part of the Sensble 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,53 +28,47 @@ ;;;-------------------------------------------------------------------------- ;;; Temporary names. -(defclass temporary-name () - ((tag :initarg :tag :reader temp-tag)) +;; Protocol. + +(export 'format-temporary-name) +(defgeneric format-temporary-name (var stream) (:documentation - "Base class for temporary variable and argument names.")) + "Write the name of a temporary variable VAR to STREAM.")) -(defclass temporary-argument (temporary-name) ()) -(defclass temporary-function (temporary-name) ()) +(export 'var-in-use-p) +(defgeneric var-in-use-p (var) + (:documentation + "Answer whether VAR is currently being used. See WITH-TEMPORARY-VAR.") + (:method (var) + "Non-temporary variables are always in use." + t)) +(defgeneric (setf var-in-use-p) (value var) + (:documentation + "Record whether VAR is currently being used. See WITH-TEMPORARY-VAR.")) -(defclass temporary-variable (temporary-name) - ((in-use-p :initarg :in-use-p :initform nil - :type boolean :accessor var-in-use-p))) +;; Root class. -(defmethod var-in-use-p ((var t)) - "Non-temporary variables are always in use." - t) +(export 'temporary-name) +(defclass temporary-name () + ((tag :initarg :tag :reader temp-tag)) + (:documentation + "Base class for temporary variable and argument names.")) -(defmethod commentify-argument-name ((name temporary-name)) - nil) +;; Important variables. (defparameter *temporary-index* 0 "Index for temporary name generation. This is automatically reset to zero before the output functions are invoked to write a file. This way, we can ensure that the same output - file is always produced from the same input.") + file is always produced from the same input." + ;; FIXME: this is currently a lie. Need some protocol to ensure that this + ;; happens. +) -(defun temporary-function () - "Return a temporary function name." - (make-instance 'temporary-function - :tag (prog1 *temporary-index* (incf *temporary-index*)))) - -(defgeneric format-temporary-name (var stream) - (:method ((var temporary-name) stream) - (format stream "~A" (temp-tag var))) - (:method ((var temporary-argument) stream) - (format stream "sod__a~A" (temp-tag var))) - (:method ((var temporary-variable) stream) - (format stream "sod__v~A" (temp-tag var))) - (:method ((var temporary-function) stream) - (format stream "sod__f~A" (temp-tag var)))) - -(defmethod print-object ((var temporary-name) stream) - (if *print-escape* - (print-unreadable-object (var stream :type t) - (prin1 (temp-tag var) stream)) - (format-temporary-name var stream))) +;; Important temporary names. +(export '(*sod-ap* *sod-master-ap*)) (defparameter *sod-ap* (make-instance 'temporary-name :tag "sod__ap")) (defparameter *sod-master-ap* @@ -83,6 +77,9 @@ ;;;-------------------------------------------------------------------------- ;;; Instructions. +;; Classes. + +(export 'inst) (defclass inst () () (:documentation "A base class for instructions. @@ -98,6 +95,7 @@ This doesn't really do very much, but it acts as a handy marker for instruction subclasses.")) +(export 'inst-metric) (defgeneric inst-metric (inst) (:documentation "Returns a `metric' describing how complicated INST is. @@ -111,6 +109,9 @@ code fairly simply.") (:method (inst) 1)) +;; Instruction definition. + +(export 'definst) (defmacro definst (code (streamvar) args &body body) "Define an instruction type and describe how to output it. @@ -153,6 +154,35 @@ ,@(mappend #'list keys args))) (progn ,@body))))))) +;; Important instruction classes. + +(export '(block-inst make-block-inst var-inst make-var-inst + function-inst make-function-inst set-inst make-set-inst + return-inst make-return-inst expr-inst make-expr-inst + inst-decls inst-body inst-name inst-type inst-init inst-var + inst-expr)) + +(definst var (stream) (name type init) + (pprint-c-type type stream name) + (when init + (format stream " = ~A" init))) +(definst set (stream) (var expr) + (format stream "~@<~A = ~@_~2I~A;~:>" var expr)) +(definst return (stream) (expr) + (format stream "return~@[ (~A)~];" expr)) +(definst expr (stream) (expr) + (format stream "~A;" expr)) +(definst block (stream) (decls body) + (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}" + decls body)) +(definst function (stream) (name type body) + (pprint-logical-block (stream nil) + (princ "static " stream) + (pprint-c-type type stream name) + (format stream "~:@_~A~:@_~:@_" body))) + +;; Formatting utilities. + (defun format-compound-statement* (stream child morep thunk) "Underlying function for FORMAT-COMPOUND-STATEMENT." (cond ((typep child 'block-inst) @@ -172,9 +202,10 @@ (:space (write-char #\space stream) (pprint-newline :linear stream)) - (t + ((t) (pprint-newline :mandatory stream))))))) +(export 'format-compound-statement) (defmacro format-compound-statement ((stream child &optional morep) &body body) "Format a compound statement to STREAM. @@ -186,106 +217,16 @@ (lambda (,stream) ,@body))) ;;;-------------------------------------------------------------------------- -;;; Instruction types. - -;; Compound statements. - -(definst block (stream) (decls body) - (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}" - decls body)) - -(definst if (stream) (condition consequent alternative) - (format-compound-statement (stream consequent alternative) - (format stream "if (~A)" condition)) - (when alternative - (format-compound-statement (stream alternative) - (write-string "else" stream)))) - -(definst while (stream) (condition body) - (format-compound-statement (stream body) - (format stream "while (~A)" condition))) - -(definst do-while (stream) (body condition) - (format-compound-statement (stream body :space) - (write-string "do" stream)) - (format stream "while (~A);" condition)) - -;; Simple statements. - -(definst set (stream) (var expr) - (format stream "~@<~A = ~@_~2I~A;~:>" var expr)) - -(definst return (stream) (expr) - (format stream "return~@[ (~A)~];" expr)) - -(definst expr (stream) (expr) - (format stream "~A;" expr)) - -;; Special varargs hacks. - -(definst va-start (stream) (ap arg) - (format stream "va_start(~@<~A, ~_~A~:>);" ap arg)) +;;; Code generation. -(definst va-copy (stream) (to from) - (format stream "va_copy(~@<~A, ~_~A~:>);" to from)) +;; Accessors. -(definst va-end (stream) (ap) - (format stream "va_end(~A);" ap)) - -;; Declarations. These should appear at the heads of BLOCK-INSTs. - -(definst var (stream) (name type init) - (pprint-c-type type stream name) - (when init - (format stream " = ~A" init))) - -;; Expressions. - -(definst call (stream) (func args) - (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args)) - -;; Top level things. - -(definst function (stream) (name type body) - (pprint-logical-block (stream nil) - (princ "static " stream) - (pprint-c-type type stream name) - (format stream "~:@_~A~:@_~:@_" body))) - -;;;-------------------------------------------------------------------------- -;;; Code generator objects. - -(defclass basic-codegen () - ((vars :initarg :vars :initform nil :type list :accessor codegen-vars) - (insts :initarg :insts :initform nil :type list :accessor codegen-insts) - (temp-index :initarg :temp-index :initform 0 - :type fixnum :accessor codegen-temp-index)) - (:documentation - "Base class for code generator state. - - This contains the bare essentials for supporting the EMIT-INST and - ENSURE-VAR protocols; see the documentation for those generic functions - for more details. - - This class isn't abstract. A full CODEGEN object uses instances of this - to keep track of pending functions which haven't been completed yet. - - Just in case that wasn't clear enough: this is nothing to do with the - BASIC language.")) - -(defgeneric emit-inst (codegen inst) +(export 'codegen-functions) +(defgeneric codegen-functions (codegen) (:documentation - "Add INST to the end of CODEGEN's list of instructions.") - (:method ((codegen basic-codegen) inst) - (push inst (codegen-insts codegen)))) - -(defgeneric emit-insts (codegen insts) - (:documentation - "Add a list of INSTS to the end of CODEGEN's list of instructions.") - (:method ((codegen basic-codegen) insts) - (setf (codegen-insts codegen) - (revappend insts (codegen-insts codegen))))) + "Return the list of FUNCTION-INSTs of completed functions.")) +(export 'ensure-var) (defgeneric ensure-var (codegen name type &optional init) (:documentation "Add a variable to CODEGEN's list. @@ -293,67 +234,52 @@ The variable is called NAME (which should be comparable using EQUAL and print to an identifier) and has the given TYPE. If INIT is present and non-nil it is an expression INST used to provide the variable with an - initial value.") - (:method ((codegen basic-codegen) name type &optional init) - (let* ((vars (codegen-vars codegen)) - (var (find name vars :key #'inst-name :test #'equal))) - (cond ((not var) - (setf (codegen-vars codegen) - (cons (make-var-inst name type init) vars))) - ((not (c-type-equal-p type (inst-type var))) - (error "(Internal) Redefining type for variable ~A." name))) - name))) - -(defclass codegen (basic-codegen) - ((functions :initform nil :type list :accessor codegen-functions) - (stack :initform nil :type list :accessor codegen-stack)) - (:documentation - "A full-fat code generator which can generate and track functions. + initial value.")) - This is the real deal. Subclasses may which to attach additional state - for convenience's sake, but this class is self-contained. It supports the - CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols.")) +(export '(emit-inst emit-insts)) +(defgeneric emit-inst (codegen inst) + (:documentation + "Add INST to the end of CODEGEN's list of instructions.")) +(defgeneric emit-insts (codegen insts) + (:documentation + "Add a list of INSTS to the end of CODEGEN's list of instructions.") + (:method (codegen insts) + (dolist (inst insts) (emit-inst codegen inst)))) +(export 'codegen-push) (defgeneric codegen-push (codegen) (:documentation "Pushes the current code generation state onto a stack. - The state consists of the accumulated variables and instructions, i.e., - what is representable by a BASIC-CODEGEN.") - (:method ((codegen codegen)) - (with-slots (vars insts temp-index stack) codegen - (push (make-instance 'basic-codegen - :vars vars - :insts insts - :temp-index temp-index) - stack) - (setf vars nil insts nil temp-index 0)))) + The state consists of the accumulated variables and instructions.")) +(export 'codegen-pop) (defgeneric codegen-pop (codegen) (:documentation "Pops a saved state off of the CODEGEN's stack. Returns the newly accumulated variables and instructions as lists, as - separate values.") - (:method ((codegen codegen)) - (with-slots (vars insts temp-index stack) codegen - (multiple-value-prog1 - (values (nreverse vars) (nreverse insts)) - (let ((sub (pop stack))) - (setf vars (codegen-vars sub) - insts (codegen-insts sub) - temp-index (codegen-temp-index sub))))))) + separate values.")) +(export 'codegen-add-function) (defgeneric codegen-add-function (codegen function) (:documentation "Adds a function to CODEGEN's list. Actually, we're not picky: FUNCTION can be any kind of object that you're - willing to find in the list returned by CODEGEN-FUNCTIONS.") - (:method ((codegen codegen) function) - (with-slots (functions) codegen - (setf functions (nconc functions (list function)))))) + willing to find in the list returned by CODEGEN-FUNCTIONS.")) + +(export 'temporary-var) +(defgeneric temporary-var (codegen type) + (:documentation + "Return the name of a temporary variable. + + The temporary variable will have the given TYPE, and will be marked + in-use. You should clear the in-use flag explicitly when you've finished + with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup + automatically.")) +(export 'codegen-build-function) (defun codegen-build-function (codegen name type vars insts) "Build a function and add it to CODEGEN's list. @@ -363,37 +289,26 @@ (make-block-inst vars insts))) name) +(export 'codegen-pop-block) +(defgeneric codegen-pop-block (codegen) + (:documentation + "Makes a block (BLOCK-INST) out of the completed code in CODEGEN.") + (:method (codegen) + (multiple-value-bind (vars insts) (codegen-pop codegen) + (make-block-inst vars insts)))) + +(export 'codegen-pop-function) (defgeneric codegen-pop-function (codegen name type) (:documentation "Makes a function out of the completed code in CODEGEN. The NAME can be any object you like. The TYPE should be a function type object which includes argument names. The return value is the NAME.") - (:method ((codegen codegen) name type) + (:method (codegen name type) (multiple-value-bind (vars insts) (codegen-pop codegen) (codegen-build-function codegen name type vars insts)))) -(defgeneric temporary-var (codegen type) - (:documentation - "Return the name of a temporary variable. - - The temporary variable will have the given TYPE, and will be marked - in-use. You should clear the in-use flag explicitly when you've finished - with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup - automatically.")) - -(defmethod temporary-var ((codegen basic-codegen) type) - (with-slots (vars temp-index) codegen - (or (find-if (lambda (var) - (and (not (var-in-use-p (inst-name var))) - (c-type-equal-p type (inst-type var)))) - vars) - (let* ((name (make-instance 'temporary-variable - :tag (prog1 temp-index - (incf temp-index))))) - (push (make-var-inst name type nil) vars) - name)))) - +(export 'with-temporary-var) (defmacro with-temporary-var ((codegen var type) &body body) "Evaluate BODY with VAR bound to a temporary variable name. @@ -407,6 +322,7 @@ ;;;-------------------------------------------------------------------------- ;;; Code generation idioms. +(export 'deliver-expr) (defun deliver-expr (codegen target expr) "Emit code to deliver the value of EXPR to the TARGET. @@ -436,6 +352,7 @@ (emit-inst codegen (make-return-inst nil))) (t (emit-inst codegen (make-set-inst target expr))))) +(export 'convert-stmts) (defun convert-stmts (codegen target type func) "Invoke FUNC to deliver a value to a non-:RETURN target. diff --git a/src/proto-lexer.lisp b/src/proto-lexer.lisp new file mode 100644 index 0000000..9c78a9b --- /dev/null +++ b/src/proto-lexer.lisp @@ -0,0 +1,216 @@ +;;; -*-lisp-*- +;;; +;;; Protocol for lexical analysis +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Accessors. + +(export 'lexer-char) +(defgeneric lexer-char (lexer) + (:documentation + "Return the current lookahead character from the LEXER. + + When the lexer is first created, there is no lookahead character: you must + `prime the pump' by calling NEXT-CHAR. The lexer represents encountering + the end of its input stream by setting the lookahead character to nil. At + this point it is still possible to push back characters.")) + +(export '(token-type token-value)) +(defgeneric token-type (lexer) + (:documentation + "Return the type of the LEXER's current lookahead token + + When the lexer is first created, there is no lookahead token: you must + `prime the pump' by calling NEXT-TOKEN.")) +(defgeneric token-value (lexer) + (:documentation + "Return the value of the LEXER's current lookahead token + + When the lexer is first created, there is no lookahead token: you must + `prime the pump' by calling NEXT-TOKEN.")) + +;;;-------------------------------------------------------------------------- +;;; Formatting tokens. + +(defgeneric format-token (token-type &optional token-value) + (:documentation + "Return a string describing a token with the specified type and value.") + (:method ((token-type (eql :eof)) &optional token-value) + (declare (ignore token-value)) + "") + (:method ((token-type (eql :string)) &optional token-value) + (declare (ignore token-value)) + "") + (:method ((token-type (eql :char)) &optional token-value) + (declare (ignore token-value)) + "") + (:method ((token-type (eql :id)) &optional token-value) + (format nil "" token-value)) + (:method ((token-type symbol) &optional token-value) + (declare (ignore token-value)) + (check-type token-type keyword) + (format nil "`~(~A~)'" token-type)) + (:method ((token-type character) &optional token-value) + (declare (ignore token-value)) + (format nil "~:[<~:C>~;`~C'~]" + (and (graphic-char-p token-type) + (char/= token-type #\space)) + token-type))) + +;;;-------------------------------------------------------------------------- +;;; Reading and pushing back characters. + +(export 'next-char) +(defgeneric next-char (lexer) + (:documentation + "Fetch the next character from the LEXER's input stream. + + Read a character from the input stream, and store it in the LEXER's CHAR + slot. The character stored is returned. If characters have been pushed + back then pushed-back characters are used instead of the input stream. If + there are no more characters to be read then the lookahead character is + nil. Returns the new lookahead character. + + (This function is primarily intended for the use of lexer subclasses.)")) + +(export 'pushback-char) +(defgeneric pushback-char (lexer char) + (:documentation + "Push the CHAR back into the lexer. + + Make CHAR be the current lookahead character (stored in the LEXER's CHAR + slot). The previous lookahead character is pushed down, and will be made + available again once this character is consumed by NEXT-CHAR. + + (This function is primarily intended for the use of lexer subclasses.)")) + +(defgeneric fixup-stream* (lexer thunk) + (:documentation + "Helper function for WITH-LEXER-STREAM. + + This function does the main work for WITH-LEXER-STREAM. The THUNK is + invoked on a single argument, the LEXER's underlying STREAM.")) + +(export 'with-lexer-stream) +(defmacro with-lexer-stream ((streamvar lexer) &body body) + "Evaluate BODY with STREAMVAR bound to the LEXER's input stream. + + The STREAM is fixed up so that the next character read (e.g., using + READ-CHAR) will be the lexer's current lookahead character. Once the BODY + completes, the next character in the stream is read and set as the + lookahead character. It is an error if the lexer has pushed-back + characters (since these can't be pushed back into the input stream + properly)." + + `(fixup-stream* ,lexer (lambda (,streamvar) ,@body))) + +;;;-------------------------------------------------------------------------- +;;; Reading and pushing back tokens. + +(export 'scan-token) +(defgeneric scan-token (lexer) + (:documentation + "Internal protocol for scanning tokens from an input stream. + + Implementing a method on this function is the main responsibility of LEXER + subclasses; it is called by the user-facing NEXT-TOKEN function. + + The method should consume characters (using NEXT-CHAR) as necessary, and + return two values: a token type and token value. These will be stored in + the corresponding slots in the lexer object in order to provide the user + with one-token lookahead.")) + +(export 'next-token) +(defgeneric next-token (lexer) + (:documentation + "Scan a token from an input stream. + + This function scans a token from an input stream. Two values are + returned: a `token type' and a `token value'. These are opaque to the + LEXER base class, but the intent is that the token type be significant to + determining the syntax of the input, while the token value carries any + additional information about the token's semantic content. The token type + and token value are also made available for lookahead via accessors + TOKEN-TYPE and TOKEN-VALUE on the LEXER object. + + The new lookahead token type and value are returned as two separate + values. + + If tokens have been pushed back (see PUSHBACK-TOKEN) then they are + returned one by one instead of scanning the stream.")) + +(export 'pushback-token) +(defgeneric pushback-token (lexer token-type &optional token-value location) + (:documentation + "Push a token back into the lexer. + + Make the given TOKEN-TYPE and TOKEN-VALUE be the current lookahead token. + The previous lookahead token is pushed down, and will be made available + agan once this new token is consumed by NEXT-TOKEN. If LOCATION is + non-nil then FILE-LOCATION is saved and replaced by LOCATION. The + TOKEN-TYPE and TOKEN-VALUE can be anything at all: for instance, they need + not be values which can actually be returned by NEXT-TOKEN.")) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(export 'skip-spaces) +(defgeneric skip-spaces (lexer) + (:documentation + "Skip over whitespace characters in the LEXER. + + There must be a lookahead character; when the function returns, the + lookahead character will be a non-whitespace character or nil if there + were no non-whitespace characters remaining. Returns the new lookahead + character.")) + +(export 'require-token) +(defun require-token + (lexer wanted-token-type &key (errorp t) (consumep t) default) + "Require a particular token to appear. + + If the LEXER's current lookahead token has type WANTED-TOKEN-TYPE then + consume it (using NEXT-TOKEN) and return its value. Otherwise, if the + token doesn't have the requested type then signal a continuable error + describing the situation and return DEFAULT (which defaults to nil). + + If ERRORP is false then no error is signalled; this is useful for + consuming or checking for optional punctuation. If CONSUMEP is false then + a matching token is not consumed; non-matching tokens are never consumed." + + (with-slots (token-type token-value) lexer + (cond ((eql token-type wanted-token-type) + (prog1 token-value + (when consumep (next-token lexer)))) + (errorp + (cerror* "Expected ~A but found ~A" + (format-token wanted-token-type) + (format-token token-type token-value)) + default) + (t + default)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-method.lisp b/src/proto-method.lisp new file mode 100644 index 0000000..c9d19ea --- /dev/null +++ b/src/proto-method.lisp @@ -0,0 +1,399 @@ +;;; -*-lisp-*- +;;; +;;; Method combination protocol +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Effective methods and entries. + +(export '(effective-method effective-method-message effective-method-class)) +(defclass effective-method () + ((message :initarg :message :type sod-message + :reader effective-method-message) + (class :initarg :class :type sod-class :reader effective-method-class)) + (:documentation + "The behaviour invoked by sending a message to an instance of a class. + + This class describes the behaviour when an instance of CLASS is sent + MESSAGE. + + This is not a useful class by itself. Message classes are expected to + define their own effective-method classes. + + An effective method classce must accept a `:direct-methods' initarg, which + will be a list of applicable methods sorted in most-to-least specific + order. (Either that or you have to add an overriding method to + `compute-sod-effective-method'.")) + +(export 'message-effective-method-class) +(defgeneric message-effective-method-class (message) + (:documentation + "Return the effective method class for the given MESSAGE. + + This function is invoked by `compute-sod-effective-method'.")) + +(export 'primary-method-class) +(defgeneric primary-method-class (message) + (:documentation + "Return the name of the primary direct method class for MESSAGE. + + This protocol is used by `simple-message' subclasses.")) + +(export 'compute-sod-effective-method) +(defgeneric compute-sod-effective-method (message class) + (:documentation + "Return the effective method when a CLASS instance receives MESSAGE. + + The default method constructs an instance of the message's chosen + `message-effective-method-class', passing the MESSAGE, the CLASS and the + list of applicable methods as initargs to `make-instance'.")) + +(export 'compute-effective-methods) +(defgeneric compute-effective-methods (class) + (:documentation + "Return a list of all of the effective methods needed for CLASS. + + The list needn't be in any particular order.")) + +(export '(method-entry method-entry-effective-method + method-entry-chain-head method-entry-chain-tail)) +(defclass method-entry () + ((method :initarg :method :type effective-method + :reader method-entry-effective-method) + (chain-head :initarg :chain-head :type sod-class + :reader method-entry-chain-head) + (chain-tail :initarg :chain-tail :type sod-class + :reader method-entry-chain-tail)) + (:documentation + "An entry point into an effective method. + + Specifically, this is the entry point to the effective method METHOD + invoked via the vtable for the chain headed by CHAIN-HEAD. The CHAIN-TAIL + is the most specific class on this chain; this is useful because we can + reuse the types of method entries from superclasses on non-primary chains. + + Each effective method may have several different method entries, because + an effective method can be called via vtables attached to different + chains, and such calls will pass instance pointers which point to + different `ichain' structures within the overall instance layout; it's the + job of the method entry to adjust the instance pointers correctly for the + rest of the effective method. + + The boundaries between a method entry and the effective method + is (intentionally) somewhat fuzzy. In extreme cases, the effective method + may not exist at all as a distinct entity in the output because its + content is duplicated in all of the method entry functions. This is left + up to the effective method protocol.")) + +(export 'make-method-entry) +(defgeneric make-method-entry (effective-method chain-head chain-tail) + (:documentation + "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. + + There is no default method for this function. (Maybe when the + effective-method/method-entry output protocol has settled down I'll know + what a sensible default action would be.)")) + +;;;-------------------------------------------------------------------------- +;;; Protocol for messages and direct-methods. + +(export 'sod-message-argument-tail) +(defgeneric sod-message-argument-tail (message) + (:documentation + "Return the argument tail for the message, with invented argument names. + + No `me' argument is prepended; any `:ellipsis' is left as it is.")) + +(export 'sod-message-no-varargs-tail) +(defgeneric sod-message-no-varargs-tail (message) + (:documentation + "Return the argument tail for the message with `:ellipsis' substituted. + + As with SOD-MESSAGE-ARGUMENT-TAIL, no `me' argument is prepended. + However, an :ELLIPSIS is replaced by an argument of type `va_list', named + `sod__ap'.")) + +(export 'sod-method-function-type) +(defgeneric sod-method-function-type (method) + (:documentation + "Return the C function type for the direct method. + + This is called during initialization of a direct method object, and the + result is cached. + + A default method is provided (by `basic-direct-method') which simply + prepends an appropriate `me' argument to the user-provided argument list. + Fancy method classes may need to override this behaviour.")) + +(export 'sod-method-next-method-type) +(defgeneric sod-method-next-method-type (method) + (:documentation + "Return the C function type for the next-method trampoline. + + This is called during initialization of a direct method object, and the + result is cached. It should return a function type, not a pointer type. + + A default method is provided (by `delegating-direct-method') which should + do the right job. Very fancy subclasses might need to do something + different.")) + +(export 'sod-method-function-name) +(defgeneric sod-method-function-name (method) + (:documentation + "Return the C function name for the direct method.")) + +(export 'varargs-message-p) +(defun varargs-message-p (message) + "Answer whether the MESSAGE accepts a variable-length argument list. + + We need to jump through some extra hoops in order to cope with varargs + messages, so this is useful to know." + (member :ellipsis (sod-message-argument-tail message))) + +;;;-------------------------------------------------------------------------- +;;; Protocol for effective methods and method entries. + +(export 'method-entry-function-type) +(defgeneric method-entry-function-type (entry) + (:documentation + "Return the C function type for a method entry.")) + +(export 'effective-method-basic-argument-names) +(defgeneric effective-method-basic-argument-names (method) + (:documentation + "Return a list of argument names to be passed to direct methods. + + The argument names are constructed from the message's arguments returned + by `sod-message-no-varargs-tail'. The basic arguments are the ones + immediately derived from the programmer's explicitly stated arguments; the + `me' argument is not included, and neither are more exotic arguments added + as part of the method delegation protocol.")) + +;;;-------------------------------------------------------------------------- +;;; Code generation. + +;;; Enhanced code-generator class. + +(export '(method-codegen codegen-message codegen-class + codegen-method codegen-target)) +(defclass method-codegen (codegen) + ((message :initarg :message :type sod-message :reader codegen-message) + (class :initarg :class :type sod-class :reader codegen-class) + (method :initarg :method :type effective-method :reader codegen-method) + (target :initarg :target :reader codegen-target)) + (:documentation + "Augments CODEGEN with additional state regarding an effective method. + + We store the effective method, and also its target class and owning + message, so that these values are readily available to the code-generating + functions.")) + +;;; Protocol. + +(export 'compute-effective-method-body) +(defgeneric compute-effective-method-body (method codegen target) + (:documentation + "Generates the body of an effective method. + + Writes the function body to the code generator. It can (obviously) + generate auxiliary functions if it needs to. + + The arguments are as specified by the `sod-message-no-varargs-tail', with + an additional argument `sod__obj' of type pointer-to-ilayout. The code + should deliver the result (if any) to the TARGET.")) + +(export 'simple-method-body) +(defgeneric simple-method-body (method codegen target) + (:documentation + "Generate the body of a simple effective method. + + The function is invoked on an effective METHOD, with a CODEGEN to which it + should emit code delivering the method's value to TARGET.")) + +;;; Additional instructions. + +(export 'convert-to-ilayout) +(definst convert-to-ilayout (stream) (class chain-head expr) + (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" + class (sod-class-nickname chain-head) expr)) + +;;; Utilities. + +(export 'invoke-method) +(defun invoke-method (codegen target arguments-tail direct-method) + "Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL. + + The code is generated in the context of CODEGEN, which can be any instance + of the `codegen' class -- it needn't be an instance of `method-codegen'. + The DIRECT-METHOD is called with the given ARGUMENTS-TAIL (a list of + argument expressions), preceded by a `me' argument of type pointer-to- + CLASS where CLASS is the class on which the method was defined. + + If the message accepts a variable-length argument list then a copy of the + prevailing master argument pointer is provided in place of the + `:ellipsis'." + + (let* ((message (sod-method-message direct-method)) + (class (sod-method-class direct-method)) + (function (sod-method-function-name direct-method)) + (arguments (cons (format nil "&sod__obj.~A.~A" + (sod-class-nickname + (sod-class-chain-head class)) + (sod-class-nickname class)) + arguments-tail))) + (if (varargs-message-p message) + (convert-stmts codegen target + (c-type-subtype (sod-method-type direct-method)) + (lambda (var) + (ensure-var codegen *sod-ap* (c-type va-list)) + (emit-inst codegen + (make-va-copy-inst *sod-ap* + *sod-master-ap*)) + (deliver-expr codegen var + (make-call-inst function arguments)) + (emit-inst codegen + (make-va-end-inst *sod-ap*)))) + (deliver-expr codegen target (make-call-inst function arguments))))) + +(export 'ensure-ilayout-var) +(defun ensure-ilayout-var (codegen super) + "Define a variable `sod__obj' pointing to the class's ilayout structure. + + CODEGEN is a `method-codegen'. The class in question is CODEGEN's class, + i.e., the target class for the effective method. SUPER is one of the + class's superclasses; it is assumed that `me' is a pointer to a SUPER + (i.e., to SUPER's ichain within the ilayout)." + + (let* ((class (codegen-class codegen)) + (super-head (sod-class-chain-head super))) + (ensure-var codegen "sod__obj" + (c-type (* (struct (ilayout-struct-tag class)))) + (make-convert-to-ilayout-inst class super-head "me")))) + +(export 'make-trampoline) +(defun make-trampoline (codegen super body) + "Construct a trampoline function and return its name. + + CODEGEN is a `method-codegen'. SUPER is a superclass of the CODEGEN + class. We construct a new trampoline function (with an unimaginative + name) suitable for being passed to a direct method defined on SUPER as its + `next_method'. In particular, it will have a `me' argument whose type is + pointer-to-SUPER. + + The code of the function is generated by BODY, which will be invoked with + a single argument which is the TARGET to which it should deliver its + result. + + The return value is the name of the generated function." + + (let* ((message (codegen-message codegen)) + (message-type (sod-message-type message)) + (return-type (c-type-subtype message-type)) + (arguments (mapcar (lambda (arg) + (if (eq (argument-name arg) *sod-ap*) + (make-argument *sod-master-ap* + (c-type va-list)) + arg)) + (sod-message-no-varargs-tail message)))) + (codegen-push codegen) + (ensure-ilayout-var codegen super) + (funcall body (codegen-target codegen)) + (codegen-pop-function codegen (temporary-function) + (c-type (fun (lisp return-type) + ("me" (* (class super))) + . arguments))))) + +;;;-------------------------------------------------------------------------- +;;; Method entry protocol. + +(export 'effective-method-function-name) +(defgeneric effective-method-function-name (method) + (:documentation + "Returns the function name of an effective method.")) + +(export 'method-entry-function-name) +(defgeneric method-entry-function-name (method chain-head) + (:documentation + "Returns the function name of a method entry. + + The method entry is given as an effective method/chain-head pair, rather + than as a method entry object because we want the function name before + we've made the entry object.")) + +(export 'compute-method-entry-functions) +(defgeneric compute-method-entry-functions (method) + (:documentation + "Construct method entry functions. + + Builds the effective method function (if there is one) and the necessary + method entries. Returns a list of functions (i.e., `function-inst' + objects) which need to be defined in the generated source code.")) + +;;;-------------------------------------------------------------------------- +;;; Invoking direct methods. + +(export 'invoke-delegation-chain) +(defun invoke-delegation-chain (codegen target basic-tail chain kernel) + "Invoke a chain of delegating methods. + + CODEGEN is a `method-codegen'. BASIC-TAIL is a list of argument + expressions to provide to the methods. The result of the delegation chain + will be delivered to TARGET. + + The CHAIN is a list of method objects (it's intended to be used with + `delegating-direct-method' objects). The behaviour is as follows. The + first method in the chain is invoked with the necessary arguments (see + below) including a `next_method' pointer. If KERNEL is nil and there are + no more methods in the chain then the `next_method' pointer will be null; + otherwise it will point to a `trampoline' function, whose behaviour is to + call the remaining methods on the chain as a delegation chain. The method + may choose to call this function with its arguments. It will finally + return a value, which will be delivered to the TARGET. + + If the chain is empty, then the code generated by KERNEL (given a TARGET + argument) will be invoked. It is an error if both CHAIN and KERNEL are + nil." + + (let* ((message (codegen-message codegen)) + (argument-tail (if (varargs-message-p message) + (cons *sod-master-ap* basic-tail) + basic-tail))) + (labels ((next-trampoline (method chain) + (if (or kernel chain) + (make-trampoline codegen (sod-method-class method) + (lambda (target) + (invoke chain target))) + 0)) + (invoke (chain target) + (if (null chain) + (funcall kernel target) + (let* ((trampoline (next-trampoline (car chain) + (cdr chain)))) + (invoke-method codegen target + (cons trampoline argument-tail) + (car chain)))))) + (invoke chain target)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-module.lisp b/src/proto-module.lisp new file mode 100644 index 0000000..aa167e4 --- /dev/null +++ b/src/proto-module.lisp @@ -0,0 +1,202 @@ +;;; -*-lisp-*- +;;; +;;; Module protocol definition +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Module environment. + +(defvar *module-bindings-alist* nil + "An alist of (SYMBOL . THUNK) pairs. + + During module construction, each SYMBOL is special-bound to the value + returned by the corresponding THUNK.") + +(export 'add-module-binding) +(defun add-module-binding (symbol thunk) + "Add a new module variable binding. + + During module construction, SYMBOL will be special-bound to the value + returned by THUNK. If you can, use `define-module-var' instead." + (aif (assoc symbol *module-bindings-alist*) + (setf (cdr it) thunk) + (asetf *module-bindings-alist* (acons symbol thunk it)))) + +(export 'define-module-var) +(defmacro define-module-var (name value-form &optional documentation) + "Add a new module variable binding. + + During module construction, NAME will be special-bound to the value of + VALUE-FORM. The NAME is proclaimed special, but is initially left + unbound." + `(progn + (defvar ,name) + ,@(and documentation + `((setf (documentation ',name 'variable) ,documentation))) + (add-module-binding ',name (lambda () ,value-form)))) + +(export 'call-with-module-environment) +(defun call-with-module-environment (thunk) + "Invoke THUNK with a new collection of bindings for the module variables." + (progv + (mapcar #'car *module-bindings-alist*) + (mapcar (compose #'cdr #'funcall) *module-bindings-alist*) + (funcall thunk))) + +;;;-------------------------------------------------------------------------- +;;; The reset switch. + +(defvar *clear-the-decks-alist* nil + "List tracking functions to be called by `clear-the-decks'.") + +(export 'add-clear-the-decks-function) +(defun add-clear-the-decks-function (symbol thunk) + "Add a function to the `clear-the-decks' list. + + If a function tagged by SYMBOL already exists on the list, then that + function is replaced; otherwise a new function is added." + (aif (assoc symbol *clear-the-decks-alist*) + (setf (cdr it) thunk) + (asetf *clear-the-decks-alist* (acons symbol thunk it)))) + +(export 'define-clear-the-decks) +(defmacro define-clear-the-decks (name &body body) + "Add behaviour to `clear-the-decks'. + + When `clear-the-decks' is called, the BODY will be evaluated as a progn. + The relative order of `clear-the-decks' operations is unspecified." + `(add-clear-the-decks-function ',name (lambda () ,@body))) + +(export 'clear-the-decks) +(defun clear-the-decks () + "Invoke a sequence of functions to reset the world." + (dolist (item *clear-the-decks-alist*) + (funcall (cdr item)))) + +;;;-------------------------------------------------------------------------- +;;; Module construction protocol. + +(export '*module*) +(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.") + +(export 'module-import) +(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 + `*module-type-map*' is a good plan.") + (:method (object) nil)) + +(export 'add-to-module) +(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.")) + +(export 'finalize-module) +(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' taking care of + looking at interesting properties, just to make sure they're ticked + off.)")) + +;;;-------------------------------------------------------------------------- +;;; Module objects. + +(export '(module module-name module-pset module-items module-dependencies)) +(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 items which the module contains. + + * A list of other modules that this one depends on. + + Modules are usually constructed by the `read-module' function, though + there's nothing to stop fancy extensions building modules + programmatically.")) + +(export 'define-module) +(defmacro define-module + ((name &key (truename nil truenamep) (location nil locationp)) + &body body) + "Define a new module. + + The module will be called NAME; it will be included in the *module-map* + only if it has a TRUENAME (which defaults to the truename of NAME, or nil + if there is no file with that name). The module is populated by + evaluating the BODY in a dynamic environment where *module* is bound to + the module under construction, and any other module variables are bound to + appropriate initial values -- see `*module-bindings-alist*' and + `define-module-var'. + + Evaluation order irregularity: the TRUENAME and LOCATION arguments are + always evaluated in that order, regardless of their order in the macro + call site." + + `(build-module ,name + (lambda () ,@body) + ,@(and truenamep `(:truename ,truename)) + ,@(and locationp `(:location ,location)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-output.lisp b/src/proto-output.lisp new file mode 100644 index 0000000..2d62e51 --- /dev/null +++ b/src/proto-output.lisp @@ -0,0 +1,171 @@ +;;; -*-lisp-*- +;;; +;;; Output scheduling protocol +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Sequencing machinery. + +(export '(sequencer-item make-sequencer-item sequencer-item-p + sequencer-item-name sequencer-item-functions)) +(defstruct (sequencer-item + (:constructor make-sequencer-item (name &optional functions))) + "Represents a distinct item to be sequenced by a `sequencer'. + + A `sequencer-item' maintains a list of FUNCTIONS which are invoked when + the sequencer is invoked." + (name nil :read-only t) + (functions nil :type list)) + +(export '(sequencer sequencer-constraints sequencer-table)) +(defclass sequencer () + ((constraints :initarg :constraints :initform nil + :type list :accessor sequencer-constraints) + (table :initform (make-hash-table :test #'equal) + :reader sequencer-table)) + (:documentation + "A sequencer tracks items and invokes them in the proper order. + + The job of a SEQUENCER object is threefold. Firstly, it collects + sequencer items and stores them in its table indexed by name. Secondly, + it gathers CONSTRAINTS, which impose an ordering on the items. Thirdly, + it can be instructed to invoke the items in an order compatible with the + established constraints. + + Sequencer item names may may any kind of object which can be compared with + EQUAL. In particular, symbols, integers and strings are reasonable + choices for atomic names, and lists work well for compound names -- so + it's possible to construct a hierarchy.")) + +(export 'ensure-sequencer-item) +(defgeneric ensure-sequencer-item (sequencer name) + (:documentation + "Arrange that SEQUENCER has a sequencer-item called NAME. + + Returns the corresponding SEQUENCER-ITEM object.")) + +(export 'add-sequencer-constraint) +(defgeneric add-sequencer-constraint (sequencer constraint) + (:documentation + "Attach the given CONSTRAINT to an SEQUENCER. + + The CONSTRAINT should be a list of sequencer-item names; see + ENSURE-SEQUENCER-ITEM for what they look like. Note that the names + needn't have been declared in advance; indeed, they needn't be mentioned + anywhere else at all.")) + +(export 'add-sequencer-item-function) +(defgeneric add-sequencer-item-function (sequencer name function) + (:documentation + "Arranges to call FUNCTION when the item called NAME is traversed. + + More than one function can be associated with a given sequencer item. + They are called in the same order in which they were added. + + Note that an item must be mentioned in at least one constraint in order to + be traversed by INVOKE-SEQUENCER-ITEMS. If there are no special ordering + requirments for a particular item, then the trivial constraint (NAME) will + suffice.")) + +(export 'invoke-sequencer-items) +(defgeneric invoke-sequencer-items (sequencer &rest arguments) + (:documentation + "Invoke functions attached to the SEQUENCER's items in the right order. + + Each function is invoked in turn with the list of ARGUMENTS. The return + values of the functions are discarded.")) + +;;;-------------------------------------------------------------------------- +;;; Output preparation. + +(defgeneric hook-output (object reason sequencer) + (:documentation + "Announces the intention to write SEQUENCER, with a particular REASON. + + The SEQUENCER is an SEQUENCER instance; the REASON will be a symbol which + can be matched using an EQL-specializer. In response, OBJECT should add + any constrains and item functions that it wishes, and pass the + announcement to its sub-objects. It is not uncommon for an object to pass + a reason to its sub-objects that is different from the REASON with which + it was itself invoked.") + + (:method-combination progn) + (:method progn (object reason sequencer))) + +;;;-------------------------------------------------------------------------- +;;; Useful syntax. + +(defmacro sequence-output + ((streamvar sequencer) &body clauses) + "Register output behaviour in a convenient manner. + + The full syntax isn't quite as described: + + sequence-output (STREAMVAR SEQUENCER) + { :constrant CONSTRAINT }* + CLAUSE* + + STREAMVAR ::= a symbol + SEQUENCER ::= a sequencer object, evaluated + CONSTRAINT ::= ( ITEM-NAME* ) + CLAUSE ::= (ITEM-NAME FORM*) + ITEM-NAME ::= an atom or a list of expressions + + An ITEM-NAME may be a self-evaluating atom (in which case it stands for + itself, clearly), a symbol (in which case the corresponding variable value + is used) or a list of forms (in which case the name used is the list of + the corresponding values). + + The behaviour is as follows. The CONSTRAINTS, if any, are added to the + sequencer. Then, for each CLAUSE, a function is attached to the named + sequencer item whose behaviour is to bind STREAMVAR to the output stream + and evaluate the FORMs as a progn." + + (let ((seqvar (gensym "SEQ"))) + (labels ((convert-item-name (name) + (if (listp name) + (cons 'list name) + name)) + (convert-constraint (constraint) + (cons 'list (mapcar #'convert-item-name constraint))) + (process-body (clauses) + (if (eq (car clauses) :constraint) + (cons `(add-sequencer-constraint + ,seqvar + ,(convert-constraint (cadr clauses))) + (process-body (cddr clauses))) + (mapcar (lambda (clause) + (let ((name (car clause)) + (body (cdr clause))) + `(add-sequencer-item-function + ,seqvar + ,(convert-item-name name) + (lambda (,streamvar) + ,@body)))) + clauses)))) + `(let ((,seqvar ,sequencer)) + ,@(process-body clauses))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/proto-pset.lisp b/src/proto-pset.lisp new file mode 100644 index 0000000..d4dc614 --- /dev/null +++ b/src/proto-pset.lisp @@ -0,0 +1,320 @@ +;;; -*-lisp-*- +;;; +;;; Protocol for property sets +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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) + +;;;-------------------------------------------------------------------------- +;;; Property representation. + +(export 'property-key) +(defun property-key (name) + "Convert NAME into a keyword. + + If NAME isn't a symbol already, then flip its case (using + `frob-identifier'), and intern into the `keyword' package." + (etypecase name + (symbol name) + (string (intern (frob-identifier name) :keyword)))) + +(export 'property-type) +(defgeneric property-type (value) + (:documentation "Guess a sensible property type to use for VALUE.") + (:method ((value symbol)) :symbol) + (:method ((value integer)) :integer) + (:method ((value string)) :string) + (:method ((value character)) :char) + (:method (value) :other)) + +(export '(property propertyp make-property + p-name p-value p-type p-key p-seenp)) +(defstruct (property + (:predicate propertyp) + (:conc-name p-) + (:constructor make-property + (name value + &key (type (property-type value)) + ((:location %loc)) + seenp + &aux (key (property-key name)) + (location (file-location %loc))))) + "A simple structure for holding a property in a property set. + + The main useful feature is the ability to tick off properties which have + been used, so that we can complain about unrecognized properties. + + An explicit type tag is necessary because we need to be able to talk + distinctly about identifiers, strings and symbols, and we've only got two + obvious Lisp types to play with. Sad, but true." + + (name nil :type (or string symbol)) + (value nil :type t) + (type nil :type symbol) + (location (file-location nil) :type file-location) + (key nil :type symbol) + (seenp nil :type boolean)) + +(defun string-to-symbol + (string &key (package *package*) (swap-case t) (swap-hyphen t)) + "Convert STRING to a symbol in PACKAGE. + + Parse off a `PACKAGE:' prefix from STRING if necessary, to identify the + package; PACKAGE is used if there isn't a prefix. A doubled colon allows + access to internal symbols, and will intern if necessary. Note that + escape characters are /not/ processed; don't put colons in package names + if you want to use them from SOD property sets. + + The portions of the string are modified by `frob-identifier'; the + arguments SWAP-CASE and SWAP-HYPHEN are passed to `frob-identifier' to + control this process." + + (let* ((length (length string)) + (colon (position #\: string))) + (multiple-value-bind (start internalp) + (cond ((not colon) (values 0 t)) + ((and (< (1+ colon) length) + (char= (char string (1+ colon)) #\:)) + (values (+ colon 2) t)) + (t + (values (1+ colon) nil))) + (when colon + (let* ((package-name (if (zerop colon) "KEYWORD" + (frob-identifier (subseq string 0 colon) + :swap-case swap-case + :swap-hyphen swap-hyphen))) + (found (find-package package-name))) + (unless found + (error "Unknown package `~A'" package-name)) + (setf package found))) + (let ((name (frob-identifier (subseq string start) + :swap-case swap-case + :swap-hyphen swap-hyphen))) + (multiple-value-bind (symbol status) + (funcall (if internalp #'intern #'find-symbol) name package) + (cond ((or internalp (eq status :external)) + symbol) + ((not status) + (error "Symbol `~A' not found in package `~A'" + name (package-name package))) + (t + (error "Symbol `~A' not external in package `~A'" + name (package-name package))))))))) + +(export 'coerce-property-value) +(defgeneric coerce-property-value (value type wanted) + (:documentation + "Convert VALUE, a property of type TYPE, to be of type WANTED. + + It's sensible to add additional methods to this function, but there are + all the ones we need.") + + ;; If TYPE matches WANTED, we'll assume that VALUE already has the right + ;; form. Otherwise, if nothing else matched, then I guess we'll have to + ;; say it didn't work. + (:method (value type wanted) + (if (eql type wanted) value + (error "Incorrect type: expected ~A but found ~A" wanted type))) + + ;; If the caller asks for type T then give him the raw thing. + (:method (value type (wanted (eql t))) + value)) + +;;;-------------------------------------------------------------------------- +;;; Property set representation. + +(export '(pset psetp)) +(defstruct (pset (:predicate psetp) + (:constructor %make-pset) + (:conc-name %pset-)) + "A property set. + + Wrapped up in a structure so that we can define a print function." + (hash (make-hash-table) :type hash-table)) + +(export '(make-pset pset-get pset-store pset-map)) +(declaim (inline make-pset pset-get pset-store pset-map)) + +(defun make-pset () + "Constructor for property sets." + (%make-pset)) + +(defun pset-get (pset key) + "Look KEY up in PSET and return what we find. + + If there's no property by that name, return NIL." + (values (gethash key (%pset-hash pset)))) + +(defun pset-store (pset prop) + "Store property PROP in PSET. + + Overwrite or replace any previous property with the same name. Mutates + the property set." + (setf (gethash (p-key prop) (%pset-hash pset)) prop)) + +(defun pset-map (func pset) + "Call FUNC for each property in PSET." + (maphash (lambda (key value) (declare (ignore key)) (funcall func value)) + (%pset-hash pset))) + +(export 'with-pset-iterator) +(defmacro with-pset-iterator ((name pset) &body body) + "Evaluate BODY with NAME bound to a macro returning properties from PSET. + + Evaluating (NAME) returns a property object or nil if all properties have + been read." + (with-gensyms (next win key value) + `(with-hash-table-iterator (,next (%pset-hash ,pset)) + (macrolet ((,name () + (multiple-value-bind (,win ,key ,value) (,next) + (declare (ignore ,key)) + (and ,win ,value)))) + ,@body)))) + +;;;-------------------------------------------------------------------------- +;;; `Cooked' property set operations. + +(export 'store-property) +(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))) + +(export 'get-property) +(defun get-property (pset name type &optional default) + "Fetch a property from a property set. + + If a property NAME is not found in PSET, or if a property is found, but + its type doesn't match TYPE, then return DEFAULT and nil; otherwise return + the value and its file location. In the latter case, mark the property as + having been used. + + The value returned depends on the TYPE argument provided. If you pass NIL + then you get back the entire PROPERTY object. If you pass `t', then you + get whatever was left in the property set, uninterpreted. Otherwise the + value is coerced to the right kind of thing (where possible) and returned. + + If PSET is nil, then return DEFAULT." + + (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)) + ((not type) + (setf (p-seenp prop) t) + (values prop (p-location prop))) + (t + (setf (p-seenp prop) t) + (values (coerce-property-value (p-value prop) + (p-type prop) + type) + (p-location prop))))))) + +(export 'add-property) +(defun add-property + (pset name value &key (type (property-type value)) location) + "Add a property to PSET. + + If a property with the same NAME already exists, report an error." + + (with-default-error-location (location) + (let ((existing (get-property pset name nil))) + (when existing + (error "Property ~S already defined~@[ at ~A~]" + name (p-location existing))) + (store-property pset name value :type type :location location)))) + +(export 'make-property-set) +(defun make-property-set (&rest plist) + "Make a new property set, with given properties. + + This isn't the way to make properties when parsing, but it works well for + programmatic generation. The arguments should form a property list + (alternating keywords and values is good). + + An attempt is made to guess property types from the Lisp types of the + values. This isn't always successful but it's not too bad. The + alternative is manufacturing a PROPERTY-VALUE object by hand and stuffing + into the set." + + (property-set plist)) + +(export 'property-set) +(defgeneric property-set (thing) + (:documentation + "Convert THING into a property set.") + (:method ((pset pset)) pset) + (:method ((list list)) + "Convert a list into a property set. This works for alists and plists." + (multiple-value-bind (next name value) + (if (and list (consp (car list))) + (values #'cdr #'caar #'cdar) + (values #'cddr #'car #'cadr)) + (do ((pset (make-pset)) + (list list (funcall next list))) + ((endp list) pset) + (add-property pset (funcall name list) (funcall value list)))))) + +(export 'check--unused-properties) +(defun check-unused-properties (pset) + "Issue errors about unused properties in PSET." + (when pset + (pset-map (lambda (prop) + (unless (p-seenp prop) + (cerror*-with-location (p-location prop) + "Unknown property `~A'" + (p-name prop)) + (setf (p-seenp prop) t))) + pset))) + +;;;-------------------------------------------------------------------------- +;;; Utility macros. + +(defmacro default-slot-from-property + ((instance slot slot-names) + (pset property type + &optional (pvar (gensym "PROP-")) + &rest convert-forms) + &body default-forms) + "Initialize a slot from a property. + + We initialize SLOT in INSTANCE. In full: if PSET contains a property + called NAME, then convert it to TYPE, bind the value to PVAR and evaluate + CONVERT-FORMS -- these default to just using the property value. If + there's no property, and the slot is named in SLOT-NAMES and currently + unbound, then evaluate DEFAULT-FORMS and use their value to compute the + slot value." + + (once-only (instance slot slot-names pset property type) + (with-gensyms (floc) + `(multiple-value-bind (,pvar ,floc) + (get-property ,pset ,property ,type) + (if ,floc + (setf (slot-value ,instance ,slot) + (with-default-error-location (,floc) + ,@(or convert-forms `(,pvar)))) + (default-slot (,instance ,slot ,slot-names) + ,@default-forms)))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/scratch.lisp b/src/scratch.lisp new file mode 100644 index 0000000..8862ac2 --- /dev/null +++ b/src/scratch.lisp @@ -0,0 +1,16 @@ +(in-package #:sod) + +(defun try-parse* (parser string) + (call-with-module-environment + (lambda () + (let* ((char-scanner (make-string-scanner string)) + (scanner (make-instance 'sod-token-scanner + :char-scanner char-scanner))) + (funcall parser scanner))))) + +(defmacro try-parse ((scanner string) &body parser) + `(try-parse* (lambda (,scanner) + (with-parser-context + (token-scanner-context :scanner ,scanner) + ,@parser)) + ,string)) diff --git a/src/sod-test.asd b/src/sod-test.asd new file mode 100644 index 0000000..17d6d40 --- /dev/null +++ b/src/sod-test.asd @@ -0,0 +1,76 @@ +;;; -*-lisp-*- +;;; +;;; Tests for the Simple Object Design translator +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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:defpackage #:sod-test-sysdef + (:use #:common-lisp #:asdf)) + +(cl:in-package #:sod-test-sysdef) + +;;;-------------------------------------------------------------------------- +;;; Definition. + +(defsystem sod-test + + ;; Boring copyright stuff. + :version "1.0.0" + :author "Mark Wooding" + :license "GNU General Public License, version 2 or later" + + ;; Documentation. + :description "Tests for the Sensible Object Design translator." + + :long-description + "This system provides unit tests for the Sod translator." + + :depends-on ("sod" "xlunit") + + :components + ((:file "test-base") + + ;; Test the parser edifice. + (:module "parser" :depends-on ("test-base") :components + ((:file "test-parser") + (:file "test-scanner-charbuf"))) + + ;; The actual tests. + (:file "test-c-types" :depends-on ("test-base")) + (:file "test-codegen" :depends-on ("test-base")))) + +;;;-------------------------------------------------------------------------- +;;; Testing. + +(defmethod perform ((op test-op) (system (eql (find-system "sod-test")))) + (operate 'load-op system) + (funcall (find-symbol "RUN-TESTS" "SOD-TEST"))) + +;;;-------------------------------------------------------------------------- +;;; Hacks. + +(defmethod perform :around + ((op compile-op) (component (eql (find-system "sod-test")))) + (let ((*compile-file-failure-behaviour* :warn)) + (call-next-method))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/sod.asd b/src/sod.asd new file mode 100644 index 0000000..64f331b --- /dev/null +++ b/src/sod.asd @@ -0,0 +1,162 @@ +;;; -*-lisp-*- +;;; +;;; System definition for the Simple Object Design translator +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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:defpackage #:sod-sysdef + (:use #:common-lisp #:asdf)) + +(cl:in-package #:sod-sysdef) + +;;;-------------------------------------------------------------------------- +;;; Definition. + +(defsystem sod + + ;; Boring copyright stuff. + :version "1.0.0" + :author "Mark Wooding" + :license "GNU General Public License, version 2 or later" + + ;; Documentation. + :description "A Sensible Object Design for C." + + :long-description + "This system implements a fairly simple, yet powerful object system for + plain old C. Its main features are as follows. + + * Multiple inheritance, done properly (unlike C++, say), with a + superclass linearlization algorithm, and exactly one copy of any + superclass's slots. + + * Method combinations, and multiple flavours of methods, to make mixin + classes more useful. + + * The default method combination doesn't depend on the programmer + statically predicting which superclass's method to delegate to. + Multiple inheritance makes this approach (taken by C++) fail: the + right next method might be an unknown sibling, and two siblings might + be in either order depending on descendents. + + * Minimal runtime support requirements, so that it's suitable for use + wherever C is -- e.g., interfacing to other languages." + + :components + ((:file "utilities") + + ;; Parser equipment. This is way more elaborate than it needs to be, but + ;; it was interesting, and it may well get split off into a separate + ;; library. + (:module "parser" :depends-on ("utilities") :components + ((:file "package") + + ;; File location protocol (including error reporting). + (:file "proto-floc" :depends-on ("package")) + (:file "impl-floc" :depends-on ("proto-floc")) + + ;; Position-aware streams. + (:file "proto-streams" :depends-on ("package")) + (:file "impl-streams" :depends-on ("proto-streams" "proto-floc")) + + ;; Scanner protocol, and various scanner implementations. + (:file "proto-scanner" :depends-on ("package")) + (:file "impl-scanner" :depends-on ("proto-scanner")) + (:file "impl-scanner-charbuf" :depends-on + ("proto-scanner" "proto-floc" "proto-streams")) + (:file "impl-scanner-token" :depends-on ("proto-scanner")) + + ;; Parser notation macro support. + (:file "proto-parser" :depends-on ("package")) + (:file "impl-parser" :depends-on ("proto-parser")) + + ;; Expression parser support. + (:file "proto-parser-expr" :depends-on ("proto-parser")) + (:file "impl-parser-expr" :depends-on ("proto-parser-expr")) + + ;; Stitching parsers to scanners. + (:file "impl-scanner-context" :depends-on + ("proto-parser" "proto-scanner")))) + + (:file "package" :depends-on ("parser")) + + ;; C type representation protocol. + (:file "proto-c-types" :depends-on ("package")) + (:file "impl-c-types" :depends-on ("proto-c-types")) + + ;; Property set protocol. + (:file "proto-pset" :depends-on ("package")) + (:file "impl-pset" :depends-on ("proto-pset")) + + ;; Lexical analysis. + ;;(:file "proto-lexer" :depends-on ("parser")) + ;;(:file "impl-lexer" :depends-on ("proto-lexer")) + + ;; Code generation protocol. + (:file "proto-codegen" :depends-on ("package")) + (:file "impl-codegen" :depends-on ("proto-codegen")) + + ;; Modules. + (:file "proto-module" :depends-on ("package")) + (:file "impl-module" :depends-on + ("proto-module" "proto-pset" "impl-c-types-class" "builtin")) + (:file "builtin" :depends-on ("proto-module" "proto-pset" "classes" + "impl-c-types" "impl-c-types-class")) + + ;; Output. + (:file "proto-output" :depends-on ("package")) + (:file "impl-output" :depends-on ("proto-output")) + + ;; Class representation. + (:file "classes" :depends-on ("package" "proto-c-types")) + (:file "impl-c-types-class" :depends-on ("classes" "proto-module")) + (:file "class-utilities" :depends-on + ("classes" "impl-codegen" "impl-pset" + "impl-c-types" "impl-c-types-class")) + + ;; Class construction. + (:file "proto-class-make" :depends-on ("class-utilities")) + (:file "impl-class-make" :depends-on ("proto-class-make")) + + ;; Class layout. + (:file "proto-class-layout" :depends-on ("class-utilities")) + (:file "impl-class-layout" :depends-on + ("proto-class-layout" "proto-method")) + + ;; Class finalization. + (:file "proto-class-finalize" :depends-on ("class-utilities")) + (:file "impl-class-finalize" :depends-on ("proto-class-finalize")) + + ;; Method generation. + (:file "proto-method" :depends-on ("class-utilities")) + (:file "impl-method" :depends-on ("proto-method")) + + ;; Class output. + (:file "output-class" :depends-on ("proto-output" "classes")))) + +;;;-------------------------------------------------------------------------- +;;; Testing. + +(defmethod perform ((op test-op) (component (eql (find-system "sod")))) + (operate 'test-op "sod-test" :force t)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/test-base.lisp b/src/test-base.lisp new file mode 100644 index 0000000..6e020cb --- /dev/null +++ b/src/test-base.lisp @@ -0,0 +1,58 @@ +;;; -*-lisp-*- +;;; +;;; Package definition and other basic stuff for SOD tests +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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:defpackage #:sod-test + (:use #:common-lisp + + #+sbcl #:sb-mop + #+(or cmu clisp) #:mop + #+ecl #:mop + + #:xlunit + + #:sod-utilities #:sod-parser #:sod) + + ;; Some internal symbols which are useful. This is somewhat bletcherous. + (:import-from #:sod-parser #:charbuf-size)) + +(cl:in-package #:sod-test) + +(defvar *sod-test-suite* + (make-instance 'test-suite + :name "Sod master test suite" + :description "Top-level test for the Sod translator.")) + +(defun assert-princ (object string) + (let ((*print-right-margin* 77) + (print (princ-to-string object))) + (assert-equal print string + (format nil "Assert princ: ~S ~_prints as `~A' ~_~ + rather than `~A'." + object print string)))) + +(defun run-tests () + (textui-test-run *sod-test-suite*)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/test-c-types.lisp b/src/test-c-types.lisp new file mode 100644 index 0000000..0c6a8b7 --- /dev/null +++ b/src/test-c-types.lisp @@ -0,0 +1,235 @@ +;;; -*-lisp-*- +;;; +;;; Test handling of C types +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-test) + +;;;-------------------------------------------------------------------------- +;;; Here we go. + +(defclass c-types-test (test-case) ()) +(add-test *sod-test-suite* (get-suite c-types-test)) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(defun assert-cteqp (a b) + (unless (c-type-equal-p a b) + (failure "Assert equal C types: ~A ~_and ~A" a b))) + +(defun assert-not-cteqp (a b) + (when (c-type-equal-p a b) + (failure "Assert unequal C types: ~A ~_and ~A" a b))) + +(defun assert-pp-ctype (type kernel string) + (let* ((*print-right-margin* 77) + (print (with-output-to-string (out) + (pprint-c-type type out kernel)))) + (assert-equal print string + (format nil "Type ~S with kernel ~S ~_prints as `~A' ~_~ + rather than `~A'." + type kernel print string)))) + +;;;-------------------------------------------------------------------------- +;;; Simple types. + +(def-test-method intern-trivial-simple-type ((test c-types-test) :run nil) + (assert-eql (c-type "foo") (make-simple-type "foo"))) + +(def-test-method intern-qualified-simple-type ((test c-types-test) :run nil) + (assert-eql (c-type ("foo" :const :volatile)) + (make-simple-type "foo" '(:volatile :const :volatile)))) + +(def-test-method mismatch-simple-type ((test c-types-test) :run nil) + (assert-not-cteqp (c-type ("foo" :const)) (make-simple-type "foo"))) + +(def-test-method print-simple-type ((test c-types-test) :run nil) + (assert-pp-ctype (c-type "foo") "f" "foo f")) + +(def-test-method print-simple-type-abs ((test c-types-test) :run nil) + (assert-pp-ctype (c-type "foo") nil "foo")) + +;;;-------------------------------------------------------------------------- +;;; Tagged types. + +(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil) + (assert-eql (c-type (struct "foo")) (make-struct-type "foo"))) + +(def-test-method intern-trivial-tagged-type ((test c-types-test) :run nil) + (assert-eql (c-type (enum "foo" :const :volatile)) + (make-enum-type "foo" '(:volatile :const :volatile)))) + +(def-test-method mismatch-tagged-type ((test c-types-test) :run nil) + (assert-not-cteqp (c-type (enum "foo" :restrict)) + (make-union-type "foo" '(:restrict)))) + +(def-test-method print-struct-type ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (struct "foo")) "f" "struct foo f")) + +(def-test-method print-union-type-abs ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (union "foo")) nil "union foo")) + +;;;-------------------------------------------------------------------------- +;;; Pointer types. + +(def-test-method intern-trivial-pointer ((test c-types-test) :run nil) + (assert-eql (c-type (* "foo")) + (make-pointer-type (make-simple-type "foo")))) + +(def-test-method intern-qualified-pointer ((test c-types-test) :run nil) + (assert-eql (c-type (* "foo" :const :volatile)) + (make-pointer-type (make-simple-type "foo") + '(:volatile :const)))) + +(def-test-method intern-double-indirection ((test c-types-test) :run nil) + (assert-eql (c-type (* (* "foo"))) + (make-pointer-type + (make-pointer-type (make-simple-type "foo"))))) + +(def-test-method non-intern-complex-pointer ((test c-types-test) :run nil) + ;; The protocol doesn't specify what we do here; but we want to avoid + ;; interning pointers to non-interned types in order to prevent the intern + ;; table filling up with cruft. So test anyway. + (let ((a (c-type (* ([] "foo" 16)))) + (b (make-pointer-type + (make-array-type (make-simple-type "foo") '(16))))) + (assert-not-eql a b) + (assert-cteqp a b))) + +(def-test-method print-pointer ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (* char)) "p" "char *p")) + +(def-test-method print-qualified-pointer ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (* char :restrict)) "p" "char *restrict p")) + +(def-test-method print-pointer-abs ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (* char)) nil "char *")) + +(def-test-method print-qualified-pointer-abs ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (* char :const)) nil "char *const")) + +;;;-------------------------------------------------------------------------- +;;; Array types. + +(def-test-method compare-simple-arrays ((test c-types-test) :run nil) + (assert-cteqp (c-type ([] int 10)) + (make-array-type (make-simple-type "int") (list 10)))) + +(def-test-method compare-multiarray-to-v-of-v ((test c-types-test) :run nil) + (assert-cteqp (c-type ([] int 10 4)) + (c-type ([] ([] int 4) 10)))) + +(def-test-method compare-multiarrays ((test c-types-test) :run nil) + (assert-cteqp (c-type ([] ([] int 7 6) 10 9 8)) + (c-type ([] ([] ([] int 6) 9 8 7) 10)))) + +(def-test-method bad-compare-multiarrays ((test c-types-test) :run nil) + (assert-not-cteqp (c-type ([] ([] int 7 6) 10 9 8)) + (c-type ([] ([] ([] int 6) 9 8 5) 10)))) + +(def-test-method compare-misshaped ((test c-types-test) :run nil) + (assert-not-cteqp (c-type ([] ([] int 7) 10 9 8)) + (c-type ([] ([] ([] int 6) 9 8 7) 10)))) + +(def-test-method print-array ((test c-types-test) :run nil) + (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) "foo" + "int foo[10][9][8][7][6]")) + +(def-test-method print-array-abs ((test c-types-test) :run nil) + (assert-pp-ctype (c-type ([] ([] int 7 6) 10 9 8)) nil + "int[10][9][8][7][6]")) + +(def-test-method print-array-of-pointers ((test c-types-test) :run nil) + (assert-pp-ctype (c-type ([] (* char))) nil "char *[]")) + +(def-test-method print-pointer-to-array ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (* ([] char))) nil "char (*)[]")) + +;;;-------------------------------------------------------------------------- +;;; Function types. + +(def-test-method compare-simple-functions ((test c-types-test) :run nil) + ;; Argument names don't matter. + (assert-cteqp (c-type (fun int ("a" int) ("b" double))) + (make-function-type (make-simple-type "int") + (list + (make-argument "foo" + (make-simple-type "int")) + (make-argument "bar" + (c-type double)))))) + +(def-test-method build-argument-tail ((test c-types-test) :run nil) + (assert-cteqp (c-type (fun int ("a" int) ("b" double))) + (c-type (fun int ("foo" int) + . (list (make-argument "bar" + (c-type double))))))) + +(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil) + (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis)) + (c-type (fun int ("y" int) ("z" double))))) + +(def-test-method bad-compare-ellipsis ((test c-types-test) :run nil) + (assert-not-cteqp (c-type (fun int ("x" int) :ellipsis)) + (c-type (fun int ("y" int) ("z" double))))) + +(def-test-method print-signal ((test c-types-test) :run nil) + (assert-pp-ctype (c-type (fun (* (fun int (nil int))) + ("signo" int) + ("handler" (* (fun int (nil int)))))) + "signal" + "int (*signal(int signo, int (*handler)(int)))(int)")) + +(def-test-method print-commentify ((test c-types-test) :run nil) + (assert-pp-ctype (commentify-function-type + (c-type (fun int + ("n" size-t) + (nil string) + ("format" const-string) + :ellipsis))) + "snprintf" + (concatenate 'string + "int snprintf(size_t /*n*/, char *, " + "const char */*format*/, " + "...)"))) + +(def-test-method commentify-non-recursive ((test c-types-test) :run nil) + ;; Also checks pretty-printing. + (assert-pp-ctype (commentify-function-type + (c-type (fun int + ("dirpath" const-string) + ("fn" (* (fun int + ("fpath" const-string) + ("sb" (* (struct "stat" + :const))) + ("typeflag" int)))) + ("nopenfd" int)))) + "ftw" + (format nil "~ +int ftw(const char */*dirpath*/, + int (*/*fn*/)(const char *fpath, + const struct stat *sb, + int typeflag), + int /*nopenfd*/)"))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/test-codegen.lisp b/src/test-codegen.lisp new file mode 100644 index 0000000..4f9aa05 --- /dev/null +++ b/src/test-codegen.lisp @@ -0,0 +1,121 @@ +;;; -*-lisp-*- +;;; +;;; Tests for code generator +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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-test) + +;;;-------------------------------------------------------------------------- + +(defclass gcd-codegen-test (test-case) + (codegen)) +(add-test *sod-test-suite* (get-suite gcd-codegen-test)) + +(defun make-gcd (codegen) + + (codegen-push codegen) + (loop for (name init) in '(("aa" 1) ("bb" 0)) + do (ensure-var codegen name (c-type int) init)) + (codegen-push codegen) + (with-temporary-var (codegen r (c-type int)) + (emit-inst codegen(make-set-inst r "u%v")) + (with-temporary-var (codegen q (c-type int)) + (emit-inst codegen (make-set-inst q "u/v")) + (with-temporary-var (codegen a (c-type int)) + (emit-insts codegen + (list (make-set-inst a "aa") + (make-set-inst "aa" "bb") + (make-set-inst "bb" + (format nil "~A - ~A*bb" a q)))))) + (emit-insts codegen (list (make-set-inst "u" "v") + (make-set-inst "v" r)))) + (emit-inst codegen (make-while-inst "v" (codegen-pop-block codegen))) + (emit-inst codegen (make-if-inst "a" (make-set-inst "*a" "aa") nil)) + (deliver-expr codegen :return "u") + (codegen-pop-function codegen "gcd" + (c-type (fun int + ("u" int) + ("v" int) + ("a" (* int))))) + + (codegen-push codegen) + (loop for (name init) in '(("u" "atoi(argv[1])") + ("v" "atoi(argv[2])") + ("a")) + do (ensure-var codegen name (c-type int) init)) + (ensure-var codegen "g" (c-type int) + (make-call-inst "gcd" (list "u" "v" "&a"))) + (emit-inst codegen (make-expr-inst + (make-call-inst "printf" + (list "\"%d*%d == %d (mod %d)\\n\"" + "a" "u" "g" "v")))) + (deliver-expr codegen :return 0) + (codegen-pop-function codegen "main" + (c-type (fun int + ("argc" int) + ("argv" ([] string)))))) + +(defmethod set-up ((test gcd-codegen-test)) + (with-slots (codegen) test + (setf codegen (make-instance 'codegen)) + (make-gcd codegen))) + +(def-test-method check-output ((test gcd-codegen-test) :run nil) + (assert-princ (codegen-functions (slot-value test 'codegen)) + "(static int gcd(int u, int v, int *a) + { + int aa = 1; + int bb = 0; + + while (v) { + int sod__v0; + int sod__v1; + int sod__v2; + + sod__v0 = u%v; + sod__v1 = u/v; + sod__v2 = aa; + aa = bb; + bb = sod__v2 - sod__v1*bb; + u = v; + v = sod__v0; + } + if (a) *a = aa; + return (u); + } + + + static int main(int argc, char *argv[]) + { + int u = atoi(argv[1]); + int v = atoi(argv[2]); + int a; + int g = gcd(u, v, &a); + + printf(\"%d*%d == %d (mod %d)\\n\", a, u, g, v); + return (0); + } + + )")) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/utilities.lisp b/src/utilities.lisp new file mode 100644 index 0000000..15f9091 --- /dev/null +++ b/src/utilities.lisp @@ -0,0 +1,690 @@ +;;; -*-lisp-*- +;;; +;;; Various handy utilities +;;; +;;; (c) 2009 Straylight/Edgeware +;;; + +;;;----- Licensing notice --------------------------------------------------- +;;; +;;; This file is part of the Sensble 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 +;;; 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:defpackage #:sod-utilities + (:use #:common-lisp + + ;; MOP from somewhere. + #+sbcl #:sb-mop + #+(or cmu clisp) #:mop + #+ecl #:clos)) + +(cl:in-package #:sod-utilities) + +;;;-------------------------------------------------------------------------- +;;; Macro hacks. + +(export 'with-gensyms) +(defmacro with-gensyms ((&rest binds) &body body) + "Evaluate BODY with variables bound to fresh symbols. + + The BINDS are a list of entries (VAR [NAME]), and a singleton list can be + replaced by just a symbol; each VAR is bound to a fresh symbol generated + by (gensym NAME), where NAME defaults to the symbol-name of VAR." + `(let (,@(mapcar (lambda (bind) + (multiple-value-bind (var name) + (if (atom bind) + (values bind (concatenate 'string + (symbol-name bind) "-")) + (destructuring-bind + (var &optional + (name (concatenate 'string + (symbol-name var) "-"))) + bind + (values var name))) + `(,var (gensym ,name)))) + binds)) + ,@body)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun strip-quote (form) + "If FORM looks like (quote FOO) for self-evaluating FOO, return FOO. + + If FORM is a symbol whose constant value is `nil' then return `nil'. + Otherwise return FORM unchanged. This makes it easier to inspect constant + things. This is a utility for `once-only'." + + (cond ((and (consp form) + (eq (car form) 'quote) + (cdr form) + (null (cddr form))) + (let ((body (cadr form))) + (if (or (not (or (consp body) (symbolp body))) + (member body '(t nil)) + (keywordp body)) + body + form))) + ((and (symbolp form) (boundp form) (null (symbol-value form))) + nil) + (t + form)))) + +(export 'once-only) +(defmacro once-only (binds &body body) + "Macro helper for preventing repeated evaluation. + + The syntax is actually hairier than shown: + + once-only ( [[ :environment ENV ]] { VAR | (VAR [VALUE-FORM]) }* ) + { FORM }* + + So, the BINDS are a list of entries (VAR [VALUE-FORM]); a singleton list + can be replaced by just a symbol VAR, and the VALUE-FORM defaults to VAR. + But before them you can have keyword arguments. Only one is defined so + far. See below for the crazy things that does. + + The result of evaluating a ONCE-ONLY form is a form with the structure + + (let ((#:GS1 VALUE-FORM1) + ... + (#:GSn VALUE-FORMn)) + STUFF) + + where STUFF is the value of the BODY forms, as an implicit progn, in an + environment with the VARs bound to the corresponding gensyms. + + As additional magic, if any of the VALUE-FORMs is actually constant (as + determined by inspection, and aided by `constantp' if an :environment is + supplied, then no gensym is constructed for it, and the VAR is bound + directly to the constant form. Moreover, if the constant form looks like + (quote FOO) for a self-evaluating FOO then the outer layer of quoting is + stripped away." + + ;; We need an extra layer of gensyms in our expansion: we'll want the + ;; expansion to examine the various VALUE-FORMs to find out whether they're + ;; constant without evaluating them repeatedly. This also helps with + ;; another problem: we explicitly encourage the rebinding of a VAR + ;; (probably a macro argument) to a gensym which will be bound to the value + ;; of the form previously held in VAR itself -- so the gensym and value + ;; form must exist at the same time and we need two distinct variables. + + (with-gensyms ((envvar "ENV-") lets sym (bodyfunc "BODY-")) + (let ((env nil)) + + ;; First things first: let's pick up the keywords. + (loop + (unless (and binds (keywordp (car binds))) + (return)) + (ecase (pop binds) + (:environment (setf env (pop binds))))) + + ;; Now we'll investigate the bindings. Turn each one into a list (VAR + ;; VALUE-FORM TEMP) where TEMP is an appropriate gensym -- see the note + ;; above. + (let ((canon (mapcar (lambda (bind) + (multiple-value-bind (var form) + (if (atom bind) + (values bind bind) + (destructuring-bind + (var &optional (form var)) bind + (values var form))) + (list var form + (gensym (format nil "T-~A-" + (symbol-name var)))))) + binds))) + + `(let* (,@(and env `((,envvar ,env))) + (,lets nil) + ,@(mapcar (lambda (bind) + (destructuring-bind (var form temp) bind + (declare (ignore var)) + `(,temp ,form))) + canon) + ,@(mapcar (lambda (bind) + (destructuring-bind (var form temp) bind + (declare (ignore form)) + `(,var + (cond ((constantp ,temp + ,@(and env `(,envvar))) + (strip-quote ,temp)) + ((symbolp ,temp) + ,temp) + (t + (let ((,sym (gensym + ,(concatenate 'string + (symbol-name var) + "-")))) + (push (list ,sym ,temp) ,lets) + ,sym)))))) + canon)) + (flet ((,bodyfunc () ,@body)) + (if ,lets + `(let (,@(nreverse ,lets)) ,(,bodyfunc)) + (,bodyfunc)))))))) + +(export 'parse-body) +(defun parse-body (body) + "Parse the BODY into a docstring, declarations and the body forms. + + These are returned as three lists, so that they can be spliced into a + macro expansion easily. The declarations are consolidated into a single + `declare' form." + (let ((decls nil) + (doc nil)) + (loop + (cond ((null body) (return)) + ((and (consp (car body)) (eq (caar body) 'declare)) + (setf decls (append decls (cdr (pop body))))) + ((and (stringp (car body)) (not doc) (cdr body)) + (setf doc (pop body))) + (t (return)))) + (values (and doc (list doc)) + (and decls (list (cons 'declare decls))) + body))) + +;;;-------------------------------------------------------------------------- +;;; Anaphorics. + +(export 'it) + +(export 'aif) +(defmacro aif (cond cons &optional (alt nil altp)) + "If COND is not nil, evaluate CONS with `it' bound to the value of COND. + + Otherwise, if given, evaluate ALT; `it' isn't bound in ALT." + (once-only (cond) + `(if ,cond (let ((it ,cond)) ,cons) ,@(and altp `(,alt))))) + +(export 'awhen) +(defmacro awhen (cond &body body) + "If COND, evaluate BODY as a progn with `it' bound to the value of COND." + `(let ((it ,cond)) (when it ,@body))) + +(export 'acond) +(defmacro acond (&rest clauses &environment env) + "Like COND, but with `it' bound to the value of the condition. + + Each of the CLAUSES has the form (CONDITION FORM*); if a CONDITION is + non-nil then evaluate the FORMs with `it' bound to the non-nil value, and + return the value of the last FORM; if there are no FORMs, then return `it' + itself. If the CONDITION is nil then continue with the next clause; if + all clauses evaluate to nil then the result is nil." + (labels ((walk (clauses) + (if (null clauses) + `nil + (once-only (:environment env (cond (caar clauses))) + (if (and (constantp cond) + (if (and (consp cond) (eq (car cond) 'quote)) + (cadr cond) cond)) + (if (cdar clauses) + `(let ((it ,cond)) + (declare (ignorable it)) + ,@(cdar clauses)) + cond) + `(if ,cond + ,(if (cdar clauses) + `(let ((it ,cond)) + (declare (ignorable it)) + ,@(cdar clauses)) + cond) + ,(walk (cdr clauses)))))))) + (walk clauses))) + +(export '(acase aecase atypecase aetypecase)) +(defmacro acase (value &body clauses) + `(let ((it ,value)) (case it ,@clauses))) +(defmacro aecase (value &body clauses) + `(let ((it ,value)) (ecase it ,@clauses))) +(defmacro atypecase (value &body clauses) + `(let ((it ,value)) (typecase it ,@clauses))) +(defmacro aetypecase (value &body clauses) + `(let ((it ,value)) (etypecase it ,@clauses))) + +(export 'asetf) +(defmacro asetf (&rest places-and-values &environment env) + "Anaphoric update of places. + + The PLACES-AND-VALUES are alternating PLACEs and VALUEs. Each VALUE is + evaluated with IT bound to the current value stored in the corresponding + PLACE." + `(progn ,@(loop for (place value) on places-and-values by #'cddr + collect (multiple-value-bind + (temps inits newtemps setform getform) + (get-setf-expansion place env) + `(let* (,@(mapcar #'list temps inits) + (it ,getform)) + (multiple-value-bind ,newtemps ,value + ,setform)))))) + +;;;-------------------------------------------------------------------------- +;;; MOP hacks (not terribly demanding). + +(export '(copy-instance copy-instance-using-class)) +(defgeneric copy-instance-using-class (class instance &rest initargs) + (:documentation + "Metaobject protocol hook for `copy-instance'.") + (:method ((class standard-class) instance &rest initargs) + (let ((copy (allocate-instance class))) + (dolist (slot (class-slots class)) + (let ((name (slot-definition-name slot))) + (when (slot-boundp instance name) + (setf (slot-value copy name) (slot-value instance name))))) + (apply #'shared-initialize copy nil initargs)))) +(defun copy-instance (object &rest initargs) + "Construct and return a copy of OBJECT. + + The new object has the same class as OBJECT, and the same slot values + except where overridden by INITARGS." + (apply #'copy-instance-using-class (class-of object) object initargs)) + +;;;-------------------------------------------------------------------------- +;;; List utilities. + +(export 'make-list-builder) +(defun make-list-builder (&optional initial) + "Return a simple list builder." + + ;; The `builder' is just a cons cell whose cdr will be the list that's + ;; wanted. Effectively, then, we have a list that's one item longer than + ;; we actually want. The car of this extra initial cons cell is always the + ;; last cons in the list -- which is now well defined because there's + ;; always at least one. + + (let ((builder (cons nil initial))) + (setf (car builder) (last builder)) + builder)) + +(export 'lbuild-add) +(defun lbuild-add (builder item) + "Add an ITEM to the end of a list BUILDER." + (let ((new (cons item nil))) + (setf (cdar builder) new + (car builder) new)) + builder) + +(export 'lbuild-add-list) +(defun lbuild-add-list (builder list) + "Add a LIST to the end of a list BUILDER. The LIST will be clobbered." + (when list + (setf (cdar builder) list + (car builder) (last list))) + builder) + +(export 'lbuild-list) +(defun lbuild-list (builder) + "Return the constructed list." + (cdr builder)) + +(export 'mappend) +(defun mappend (function list &rest more-lists) + "Like a nondestructive MAPCAN. + + Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, + and return the result of appending all of the resulting lists." + (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) + +(export '(inconsistent-merge-error merge-error-candidates)) +(define-condition inconsistent-merge-error (error) + ((candidates :initarg :candidates + :reader merge-error-candidates)) + (:documentation + "Reports an inconsistency in the arguments passed to MERGE-LISTS.") + (:report (lambda (condition stream) + (format stream "Merge inconsistency: failed to decide among ~A." + (merge-error-candidates condition))))) + +(export 'merge-lists) +(defun merge-lists (lists &key pick (test #'eql)) + "Return a merge of the given LISTS. + + The resulting LIST contains the items of the given lists, with duplicates + removed. The order of the resulting list is consistent with the orders of + the input LISTS in the sense that if A precedes B in some input list then + A will also precede B in the output list. If the lists aren't consistent + (e.g., some list contains A followed by B, and another contains B followed + by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled. + + Item equality is determined by TEST. + + If there is an ambiguity at any point -- i.e., a choice between two or + more possible next items to emit -- then PICK is called to arbitrate. + PICK is called with two arguments: the list of candidate next items, and + the current output list. It should return one of the candidate items. If + PICK is omitted then an arbitrary choice is made. + + The primary use of this function is in computing class precedence lists. + By building the input lists and selecting the PICK function appropriately, + a variety of different CPL algorithms can be implemented." + + (do* ((lb (make-list-builder))) + ((null lists) (lbuild-list lb)) + + ;; The candidate items are the ones at the front of the input lists. + ;; Gather them up, removing duplicates. If a candidate is somewhere in + ;; one of the other lists other than at the front then we reject it. If + ;; we've just rejected everything, then we can make no more progress and + ;; the input lists were inconsistent. + (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test)) + (leasts (remove-if (lambda (item) + (some (lambda (list) + (member item (cdr list) :test test)) + lists)) + candidates)) + (winner (cond ((null leasts) + (error 'inconsistent-merge-error + :candidates candidates)) + ((null (cdr leasts)) + (car leasts)) + (pick + (funcall pick leasts (lbuild-list lb))) + (t (car leasts))))) + + ;; Check that the PICK function isn't conning us. + (assert (member winner leasts :test test)) + + ;; Update the output list and remove the winning item from the input + ;; lists. We know that it must be at the front of each input list + ;; containing it. At this point, we discard input lists entirely when + ;; they run out of entries. The loop ends when there are no more input + ;; lists left, i.e., when we've munched all of the input items. + (lbuild-add lb winner) + (setf lists (delete nil (mapcar (lambda (list) + (if (funcall test winner (car list)) + (cdr list) + list)) + lists)))))) + +(export 'categorize) +(defmacro categorize ((itemvar items &key bind) categories &body body) + "Categorize ITEMS into lists and invoke BODY. + + The ITEMVAR is a symbol; as the macro iterates over the ITEMS, ITEMVAR + will contain the current item. The BIND argument is a list of LET*-like + clauses. The CATEGORIES are a list of clauses of the form (SYMBOL + PREDICATE). + + The behaviour of the macro is as follows. ITEMVAR is assigned (not + bound), in turn, each item in the list ITEMS. The PREDICATEs in the + CATEGORIES list are evaluated in turn, in an environment containing + ITEMVAR and the BINDings, until one of them evaluates to a non-nil value. + At this point, the item is assigned to the category named by the + corresponding SYMBOL. If none of the PREDICATEs returns non-nil then an + error is signalled; a PREDICATE consisting only of T will (of course) + match anything; it is detected specially so as to avoid compiler warnings. + + Once all of the ITEMS have been categorized in this fashion, the BODY is + evaluated as an implicit PROGN. For each SYMBOL naming a category, a + variable named after that symbol will be bound in the BODY's environment + to a list of the items in that category, in the same order in which they + were found in the list ITEMS. The final values of the macro are the final + values of the BODY." + + (let* ((cat-names (mapcar #'car categories)) + (cat-match-forms (mapcar #'cadr categories)) + (cat-vars (mapcar (lambda (name) (gensym (concatenate 'string + (symbol-name name) "-"))) + cat-names)) + (items-var (gensym "ITEMS-"))) + `(let ((,items-var ,items) + ,@(mapcar (lambda (cat-var) (list cat-var nil)) cat-vars)) + (dolist (,itemvar ,items-var) + (let* ,bind + (cond ,@(mapcar (lambda (cat-match-form cat-var) + `(,cat-match-form + (push ,itemvar ,cat-var))) + cat-match-forms cat-vars) + ,@(and (not (member t cat-match-forms)) + `((t (error "Failed to categorize ~A" ,itemvar))))))) + (let ,(mapcar (lambda (name var) + `(,name (nreverse ,var))) + cat-names cat-vars) + ,@body)))) + +;;;-------------------------------------------------------------------------- +;;; Strings and characters. + +(export 'frob-identifier) +(defun frob-identifier (string &key (swap-case t) (swap-hyphen t)) + "Twiddles the case of STRING. + + If all the letters in STRING are uppercase, and SWAP-CASE is true, then + switch them to lowercase; if they're all lowercase then switch them to + uppercase. If there's a mix then leave them all alone. At the same time, + if there are underscores but no hyphens, and SWAP-HYPHEN is true, then + switch them to hyphens, if there are hyphens and no underscores, switch + them underscores, and if there are both then leave them alone. + + This is an invertible transformation, which turns vaguely plausible Lisp + names into vaguely plausible C names and vice versa. Lisp names with + `funny characters' like stars and percent signs won't be any use, of + course." + + ;; Work out what kind of a job we've got to do. Gather flags: bit 0 means + ;; there are upper-case letters; bit 1 means there are lower-case letters; + ;; bit 2 means there are hyphens; bit 3 means there are underscores. + ;; + ;; Consequently, (logxor flags (ash flags 1)) is interesting: bit 1 is set + ;; if we have to frob case; bit 3 is set if we have to swap hyphens and + ;; underscores. So use this to select functions which do bits of the + ;; mapping, and then compose them together. + (let* ((flags (reduce (lambda (state ch) + (logior state + (cond ((upper-case-p ch) 1) + ((lower-case-p ch) 2) + ((char= ch #\-) 4) + ((char= ch #\_) 8) + (t 0)))) + string + :initial-value 0)) + (mask (logxor flags (ash flags 1))) + (letter (cond ((or (not swap-case) (not (logbitp 1 mask))) + (constantly nil)) + ((logbitp 0 flags) + (lambda (ch) + (and (alpha-char-p ch) (char-downcase ch)))) + (t + (lambda (ch) + (and (alpha-char-p ch) (char-upcase ch)))))) + (uscore-hyphen (cond ((or (not (logbitp 3 mask)) (not swap-hyphen)) + (constantly nil)) + ((logbitp 2 flags) + (lambda (ch) (and (char= ch #\-) #\_))) + (t + (lambda (ch) (and (char= ch #\_) #\-)))))) + + (if (logbitp 3 (logior mask (ash mask 2))) + (map 'string (lambda (ch) + (or (funcall letter ch) + (funcall uscore-hyphen ch) + ch)) + string) + string))) + +(export 'whitespace-char-p) +(declaim (inline whitespace-char-p)) +(defun whitespace-char-p (char) + "Returns whether CHAR is a whitespace character. + + Whitespaceness is determined relative to the compile-time readtable, which + is probably good enough for most purposes." + (case char + (#.(loop for i below char-code-limit + for ch = (code-char i) + unless (with-input-from-string (in (string ch)) + (peek-char t in nil)) + collect ch) t) + (t nil))) + +(export 'update-position) +(declaim (inline update-position)) +(defun update-position (char line column) + "Updates LINE and COLUMN appropriately for having read the character CHAR. + + Returns the new LINE and COLUMN numbers." + (case char + ((#\newline #\vt #\page) + (values (1+ line) 0)) + ((#\tab) + (values line (logandc2 (+ column 8) 7))) + (t + (values line (1+ column))))) + +(export 'backtrack-position) +(declaim (inline backtrack-position)) +(defun backtrack-position (char line column) + "Updates LINE and COLUMN appropriately for having unread CHAR. + + Well, actually an approximation for it; it will likely be wrong if the + last character was a tab. But when the character is read again, it will + be correct." + + ;; This isn't perfect: if the character doesn't actually match what was + ;; really read then it might not actually be possible: for example, if we + ;; push back a newline while in the middle of a line, or a tab while not at + ;; a tab stop. In that case, we'll just lose, but hopefully not too badly. + (case char + + ;; In the absence of better ideas, I'll set the column number to zero. + ;; This is almost certainly wrong, but with a little luck nobody will ask + ;; and it'll be all right soon. + ((#\newline #\vt #\page) (values (1- line) 0)) + + ;; Winding back a single space is sufficient. If the position is + ;; currently on a tab stop then it'll advance back here next time. If + ;; not, we're going to lose anyway because the previous character + ;; certainly couldn't have been a tab. + (#\tab (values line (1- column))) + + ;; Anything else: just decrement the column and cross fingers. + (t (values line (1- column))))) + +;;;-------------------------------------------------------------------------- +;;; Functions. + +(export 'compose) +(defun compose (function &rest more-functions) + "Composition of functions. Functions are applied left-to-right. + + This is the reverse order of the usual mathematical notation, but I find + it easier to read. It's also slightly easier to work with in programs." + (labels ((compose1 (func-a func-b) + (lambda (&rest args) + (multiple-value-call func-b (apply func-a args))))) + (reduce #'compose1 more-functions :initial-value function))) + +;;;-------------------------------------------------------------------------- +;;; Symbols. + +(export 'symbolicate) +(defun symbolicate (&rest symbols) + "Return a symbol named after the concatenation of the names of the SYMBOLS. + + The symbol is interned in the current *PACKAGE*. Trad." + (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) + +;;;-------------------------------------------------------------------------- +;;; Object printing. + +(export 'maybe-print-unreadable-object) +(defmacro maybe-print-unreadable-object + ((object stream &rest args) &body body) + "Print helper for usually-unreadable objects. + + If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY. + Otherwise just print using BODY." + (with-gensyms (print) + `(flet ((,print () ,@body)) + (if *print-escape* + (print-unreadable-object (,object ,stream ,@args) + (,print)) + (,print))))) + +;;;-------------------------------------------------------------------------- +;;; Iteration macros. + +(export 'dosequence) +(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) + &body body + &environment env) + "Macro for iterating over general sequences. + + Iterates over a (sub)sequence SEQ, delimited by START and END (which are + evaluated). For each item of SEQ, BODY is invoked with VAR bound to the + item, and INDEXVAR (if requested) bound to the item's index. (Note that + this is different from most iteration constructs in Common Lisp, which + work by mutating the variable.) + + The loop is surrounded by an anonymous BLOCK and the loop body forms an + implicit TAGBODY, as is usual. There is no result-form, however." + + (once-only (:environment env seq start end) + (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-")) + + (flet ((loopguts (indexp listp endvar) + ;; Build a DO-loop to do what we want. + (let* ((do-vars nil) + (end-condition (if endvar + `(>= ,ivar ,endvar) + `(endp ,seq))) + (item (if listp + `(car ,seq) + `(aref ,seq ,ivar))) + (body-call `(,bodyfunc ,item))) + (when listp + (push `(,seq (nthcdr ,start ,seq) (cdr ,seq)) + do-vars)) + (when indexp + (push `(,ivar ,start (1+ ,ivar)) do-vars)) + (when indexvar + (setf body-call (append body-call (list ivar)))) + `(do ,do-vars (,end-condition) ,body-call)))) + + `(block nil + (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) + (tagbody ,@body))) + (etypecase ,seq + (vector + (let ((,endvar (or ,end (length ,seq)))) + ,(loopguts t nil endvar))) + (list + (if ,end + ,(loopguts t t end) + ,(loopguts indexvar t nil)))))))))) + +;;;-------------------------------------------------------------------------- +;;; CLOS hacking. + +(export 'default-slot) +(defmacro default-slot ((instance slot &optional (slot-names t)) + &body value + &environment env) + "If INSTANCE's slot named SLOT is unbound, set it to VALUE. + + Only set SLOT if it's listed in SLOT-NAMES, or SLOT-NAMES is `t' (i.e., we + obey the `shared-initialize' protocol). SLOT-NAMES defaults to `t', so + you can use it in `initialize-instance' or similar without ill effects. + Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only + evaluated if it's needed." + + (once-only (:environment env instance slot slot-names) + `(when ,(if (eq slot-names t) + `(not (slot-boundp ,instance ,slot)) + `(and (not (slot-boundp ,instance ,slot)) + (or (eq ,slot-names t) + (member ,slot ,slot-names)))) + (setf (slot-value ,instance ,slot) + (progn ,@value))))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/chimaera.sod b/test/chimaera.sod similarity index 80% rename from chimaera.sod rename to test/chimaera.sod index d5507f8..cc56236 100644 --- a/chimaera.sod +++ b/test/chimaera.sod @@ -12,8 +12,6 @@ code h : includes { #include "sod.h" } -lisp (write-line "Hello, world!") ; - [nick = nml, link = SodObject] class Animal : SodObject { int tickles = 0; @@ -26,12 +24,12 @@ class Animal : SodObject { class Lion : Animal { void bite(void) { puts("Munch!"); } - void nml.tickle(void) { me->_vt.bite(me); } + void nml.tickle(void) { me->_vt.lion.bite(me); } } class Goat : Animal { void butt(void) { puts("Bonk!"); } - void nml.tickle(void) { me->_vt.butt(me); } + void nml.tickle(void) { me->_vt.goat.butt(me); } } class Serpent : Animal { @@ -39,9 +37,9 @@ class Serpent : Animal { void bite(void) { puts("Nom!"); } void nml.tickle(void) { if (SERPENT__CONV_NML(me)->nml.tickles > 2) - me->_vt.bite(); + me->_vt.serpent.bite(); else - me->_vt.hiss(); + me->_vt.serpent.hiss(); } } diff --git a/utilities.lisp b/utilities.lisp deleted file mode 100644 index 7e9e092..0000000 --- a/utilities.lisp +++ /dev/null @@ -1,411 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Various handy utilities -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; List utilities. - -(defun mappend (function list &rest more-lists) - "Like a nondestructive MAPCAN. - - Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS, - and return the result of appending all of the resulting lists." - (reduce #'append (apply #'mapcar function list more-lists) :from-end t)) - -(define-condition inconsistent-merge-error (error) - ((candidates :initarg :candidates - :reader merge-error-candidates)) - (:documentation - "Reports an inconsistency in the arguments passed to MERGE-LISTS.") - (:report (lambda (condition stream) - (format stream "Merge inconsistency: failed to decide among ~A." - (merge-error-candidates condition))))) - -(defun merge-lists (lists &key pick (test #'eql)) - "Return a merge of the given LISTS. - - The resulting LIST contains the items of the given lists, with duplicates - removed. The order of the resulting list is consistent with the orders of - the input LISTS in the sense that if A precedes B in some input list then - A will also precede B in the output list. If the lists aren't consistent - (e.g., some list contains A followed by B, and another contains B followed - by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled. - - Item equality is determined by TEST. - - If there is an ambiguity at any point -- i.e., a choice between two or - more possible next items to emit -- then PICK is called to arbitrate. - PICK is called with two arguments: the list of candidate next items, and - the current output list. It should return one of the candidate items. If - PICK is omitted then an arbitrary choice is made. - - The primary use of this function is in computing class precedence lists. - By building the input lists and selecting the PICK function appropriately, - a variety of different CPL algorithms can be implemented." - - ;; In this loop, TAIL points to the last cons cell in the list. This way - ;; we can build the list up forwards, so as not to make the PICK function - ;; interface be weird. HEAD is a dummy cons cell inserted before the list, - ;; which gives TAIL something to point to initially. (If we had locatives, - ;; I'd have TAIL point to the thing holding the final NIL, but we haven't; - ;; instead, it points to the cons cell whose cdr holds the final NIL -- - ;; which means that we need to invent a cons cell if the list is empty.) - (do* ((head (cons nil nil)) - (tail head)) - ((null lists) (cdr head)) - - ;; The candidate items are the ones at the front of the input lists. - ;; Gather them up, removing duplicates. If a candidate is somewhere in - ;; one of the other lists other than at the front then we reject it. If - ;; we've just rejected everything, then we can make no more progress and - ;; the input lists were inconsistent. - (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test)) - (leasts (remove-if (lambda (item) - (some (lambda (list) - (member item (cdr list) :test test)) - lists)) - candidates)) - (winner (cond ((null leasts) - (error 'inconsistent-merge-error - :candidates candidates)) - ((null (cdr leasts)) - (car leasts)) - (pick - (funcall pick leasts (cdr head))) - (t (car leasts)))) - (new (cons winner nil))) - - ;; Check that the PICK function isn't conning us. - (assert (member winner leasts :test test)) - - ;; Update the output list and remove the winning item from the input - ;; lists. We know that it must be at the front of each input list - ;; containing it. At this point, we discard input lists entirely when - ;; they run out of entries. The loop ends when there are no more input - ;; lists left, i.e., when we've munched all of the input items. - (setf (cdr tail) new - tail new - lists (delete nil (mapcar (lambda (list) - (if (funcall test winner (car list)) - (cdr list) - list)) - lists)))))) - -;;;-------------------------------------------------------------------------- -;;; Strings and characters. - -(defun frob-case (string) - "Twiddles the case of STRING. - - If all the letters in STRING are uppercase, switch them to lowercase; if - they're all lowercase then switch them to uppercase. If there's a mix - then leave them all alone. This is an invertible transformation." - - ;; Given that this operation is performed by the reader anyway, it's - ;; surprising that there isn't a Common Lisp function to do this built - ;; in. - (let ((flags (reduce (lambda (state ch) - (logior state - (cond ((upper-case-p ch) 1) - ((lower-case-p ch) 2) - (t 0)))) - string - :initial-value 0))) - - ;; Now FLAGS has bit 0 set if there are any upper-case characters, and - ;; bit 1 if there are lower-case. So if it's zero there were no letters - ;; at all, and if it's three then there were both kinds; either way, we - ;; leave the string unchanged. Otherwise we know how to flip the case. - (case flags - (1 (string-downcase string)) - (2 (string-upcase string)) - (t string)))) - -(declaim (inline whitespace-char-p)) -(defun whitespace-char-p (char) - "Returns whether CHAR is a whitespace character. - - Whitespaceness is determined relative to the compile-time readtable, which - is probably good enough for most purposes." - (case char - (#.(loop for i below char-code-limit - for ch = (code-char i) - unless (with-input-from-string (in (string ch)) - (peek-char t in nil)) - collect ch) t) - (t nil))) - -;;;-------------------------------------------------------------------------- -;;; Symbols. - -(defun symbolicate (&rest symbols) - "Return a symbol named after the concatenation of the names of the SYMBOLS. - - The symbol is interned in the current *PACKAGE*. Trad." - (intern (apply #'concatenate 'string (mapcar #'symbol-name symbols)))) - -;;;-------------------------------------------------------------------------- -;;; Object printing. - -(defmacro maybe-print-unreadable-object - ((object stream &rest args) &body body) - "Print helper for usually-unreadable objects. - - If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY. - Otherwise just print using BODY." - (let ((func (gensym "PRINT"))) - `(flet ((,func () ,@body)) - (if *print-escape* - (print-unreadable-object (,object ,stream ,@args) - (,func)) - (,func))))) - -;;;-------------------------------------------------------------------------- -;;; Keyword arguments and lambda lists. - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defun transform-otherkeys-lambda-list (bvl) - "Process a simple lambda-list BVL which might contain &OTHER-KEYS. - - &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments - (which must also be present); &ALLOW-OTHER-KEYS must not be present. - - The behaviour is that - - * the presence of non-listed keyword arguments is permitted, as if - &ALLOW-OTHER-KEYS had been provided, and - - * a list of the keyword arguments other than the ones explicitly listed - is stored in the VAR. - - The return value is a replacement BVL which binds the &OTHER-KEYS variable - as an &AUX parameter if necessary. - - At least for now, fancy things like destructuring lambda-lists aren't - supported. I suspect you'll get away with a specializing lambda-list." - - (prog ((new-bvl nil) - (rest-var nil) - (keywords nil) - (other-keys-var nil) - (tail bvl)) - - find-rest - ;; Scan forwards until we find &REST or &KEY. If we find the former, - ;; then remember the variable name. If we find the latter first then - ;; there can't be a &REST argument, so we should invent one. If we - ;; find neither then there's nothing to do. - (when (endp tail) - (go ignore)) - (let ((item (pop tail))) - (push item new-bvl) - (case item - (&rest (when (endp tail) - (error "Missing &REST argument name")) - (setf rest-var (pop tail)) - (push rest-var new-bvl)) - (&aux (go ignore)) - (&key (unless rest-var - (setf rest-var (gensym "REST")) - (setf new-bvl (nconc (list '&key rest-var '&rest) - (cdr new-bvl)))) - (go scan-keywords))) - (go find-rest)) - - scan-keywords - ;; Read keyword argument specs one-by-one. For each one, stash it on - ;; the NEW-BVL list, and also parse it to extract the keyword, which - ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's - ;; nothing for us to do. - (when (endp tail) - (go ignore)) - (let ((item (pop tail))) - (push item new-bvl) - (case item - ((&aux &allow-other-keys) (go ignore)) - (&other-keys (go fix-tail))) - (let ((keyword (if (symbolp item) - (intern (symbol-name item) :keyword) - (let ((var (car item))) - (if (symbolp var) - (intern (symbol-name var) :keyword) - (car var)))))) - (push keyword keywords)) - (go scan-keywords)) - - fix-tail - ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var. - (pop new-bvl) - (when (endp tail) - (error "Missing &OTHER-KEYS argument name")) - (setf other-keys-var (pop tail)) - (push '&allow-other-keys new-bvl) - - ;; There should be an &AUX next. If there isn't, assume there isn't - ;; one and provide our own. (This is safe as long as nobody else is - ;; expecting to plumb in lambda keywords too.) - (when (and (not (endp tail)) (eq (car tail) '&aux)) - (pop tail)) - (push '&aux new-bvl) - - ;; Add our shiny new &AUX argument. - (let ((keys-var (gensym "KEYS")) - (list-var (gensym "LIST"))) - (push `(,other-keys-var (do ((,list-var nil) - (,keys-var ,rest-var (cddr ,keys-var))) - ((endp ,keys-var) (nreverse ,list-var)) - (unless (member (car ,keys-var) - ',keywords) - (setf ,list-var - (cons (cadr ,keys-var) - (cons (car ,keys-var) - ,list-var)))))) - new-bvl)) - - ;; Done. - (return (nreconc new-bvl tail)) - - ignore - ;; Nothing to do. Return the unmolested lambda-list. - (return bvl)))) - -(defmacro lambda-otherkeys (bvl &body body) - "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword." - `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body)) - -(defmacro defun-otherkeys (name bvl &body body) - "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword." - `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body)) - -(defmacro defmethod-otherkeys (name &rest stuff) - "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword." - (do ((quals nil) - (stuff stuff (cdr stuff))) - ((listp (car stuff)) - `(defmethod ,name ,@(nreverse quals) - ,(transform-otherkeys-lambda-list (car stuff)) - ,@(cdr stuff))) - (push (car stuff) quals))) - -;;;-------------------------------------------------------------------------- -;;; Iteration macros. - -(defmacro dosequence ((var seq &key (start 0) (end nil) indexvar) &body body) - "Macro for iterating over general sequences. - - Iterates over a (sub)sequence SEQ, delimited by START and END (which are - evaluated). For each item of SEQ, BODY is invoked with VAR bound to the - item, and INDEXVAR (if requested) bound to the item's index. (Note that - this is different from most iteration constructs in Common Lisp, which - work by mutating the variable.) - - The loop is surrounded by an anonymous BLOCK and the loop body forms an - implicit TAGBODY, as is usual. There is no result-form, however." - - (let ((seqvar (gensym "SEQ")) - (startvar (gensym "START")) - (endvar (gensym "END")) - (ivar (gensym "INDEX")) - (bodyfunc (gensym "BODY"))) - - (flet ((loopguts (indexp listp use-endp) - ;; Build a DO-loop to do what we want. - (let* ((do-vars nil) - (end-condition (if use-endp - `(endp ,seqvar) - `(>= ,ivar ,endvar))) - (item (if listp - `(car ,seqvar) - `(aref ,seqvar ,ivar))) - (body-call `(,bodyfunc ,item))) - (when listp - (push `(,seqvar (nthcdr ,startvar ,seqvar) (cdr ,seqvar)) - do-vars)) - (when indexp - (push `(,ivar ,startvar (1+ ,ivar)) do-vars)) - (when indexvar - (setf body-call (append body-call (list ivar)))) - `(do ,do-vars (,end-condition) ,body-call)))) - - `(block nil - (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar))) - (tagbody ,@body))) - (let* ((,seqvar ,seq) - (,startvar ,start)) - (etypecase ,seqvar - (vector - (let ((,endvar (or ,end (length ,seqvar)))) - ,(loopguts t nil nil))) - (list - (let ((,endvar ,end)) - (if ,endvar - ,(loopguts t t nil) - ,(loopguts indexvar t t))))))))))) - -;;;-------------------------------------------------------------------------- -;;; Meta-object hacking. - -(defgeneric copy-instance-using-class (class object &rest initargs) - (:documentation - "Return a copy of OBJECT. - - OBJECT is assumed to be an instance of CLASS. The copy returned is a - fresh instance whose slots have the same values as OBJECT except where - overridden by INITARGS.") - - (:method ((class standard-class) object &rest initargs) - (let ((copy (apply #'allocate-instance class initargs))) - (dolist (slot (class-slots class)) - (if (slot-boundp-using-class class object slot) - (setf (slot-value-using-class class copy slot) - (slot-value-using-class class object slot)) - (slot-makunbound-using-class class copy slot))) - (apply #'shared-initialize copy nil initargs) - copy))) - -(defun copy-instance (object &rest initargs) - "Return a copy of OBJECT. - - The copy returned is a fresh instance whose slots have the same values as - OBJECT except where overridden by INITARGS." - (apply #'copy-instance-using-class (class-of object) object initargs)) - -(defmacro default-slot ((instance slot) &body value &environment env) - "If INSTANCE's SLOT is unbound, set it to VALUE. - - Both INSTANCE and SLOT are evaluated; VALUE is an implicit progn and only - evaluated if it's needed." - - (let* ((quotep (constantp slot env)) - (instancevar (gensym "INSTANCE")) - (slotvar (if quotep slot (gensym "SLOT")))) - `(let ((,instancevar ,instance) - ,@(and (not quotep) `((,slotvar ,slot)))) - (unless (slot-boundp ,instancevar ,slotvar) - (setf (slot-value ,instancevar ,slotvar) - (progn ,@value)))))) - -;;;----- That's all, folks -------------------------------------------------- -- 2.11.0