From: Mark Wooding Date: Mon, 14 Sep 2015 21:34:48 +0000 (+0100) Subject: Merge branch 'master' into doc X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/3dca7758421664a838c54b273bd9221f02072045?hp=fca95fc163b7bc6448aa37e1fec96f1d9d2c68cf Merge branch 'master' into doc * master: (93 commits) Eliminate the separately maintained Lisp system version number. src/{builtin,final,frontent}.lisp: `clear-the-decks' makes builtin module. src/class-{finalize,layout}-impl.lisp: Error checking on layout slots. src/class-finalize-impl.lisp: Remove FIXME which was fixed ages ago. src/: Introduce a macro for defining on-demand slots. Major effort to plug slot-name leaks. doc/list-exports.lisp: Report on generic function methods. doc/list-exports.lisp: Strip duplicate exports. doc/list-exports.lisp: Better pretty formatting for keywords. doc/list-exports.lisp: Mark the start of the class tree dump. src/codegen-proto.lisp, doc/list-exports.lisp: Export `inst' readers. src/: More missing exports. doc/list-exports.lisp: Sort sibling classes by name in the tree. doc/list-exports.lisp: Search for exports inside `eval-when' blocks. doc/list-exports.lisp: Don't get confused and thing `nil' isn't interned. doc/list-exports.lisp: Check for anomalies when preparing reports. doc/list-exports.lisp: Some sketchy code to report on exported symbols. src/: Fix up some wrong exports. src/final.lisp, src/frontend.lisp: Compile methods before dumping. src/frontend.lisp: Prepare the builtin module at load time. ... --- diff --git a/.gitignore b/.gitignore index 1abd9a1..0bf9e54 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ Makefile.in /autom4te.cache/ /config/ /configure +/doc/SYMBOLS diff --git a/.links b/.links index c7a181f..1df072c 100644 --- a/.links +++ b/.links @@ -1,3 +1,4 @@ COPYING COPYING.LIB config/auto-version +config/confsubst diff --git a/Makefile.am b/Makefile.am index 515031e..d1a016d 100644 --- a/Makefile.am +++ b/Makefile.am @@ -28,6 +28,17 @@ include $(top_srcdir)/vars.am SUBDIRS = ###-------------------------------------------------------------------------- +### Package-configuration file. + +pkgconfigdir = $(libdir)/pkgconfig +pkgconfig_DATA = sod.pc +CLEANFILES += sod.pc +EXTRA_DIST += sod.pc.in + +sod.pc: sod.pc.in Makefile + $(SUBST) $(srcdir)/sod.pc.in >$@.new $(SUBSTITUTIONS) && mv $@.new $@ + +###-------------------------------------------------------------------------- ### Subdirectories to build ## The SOD translator. @@ -39,4 +50,34 @@ SUBDIRS += lib ## The tests and examples. SUBDIRS += test +###-------------------------------------------------------------------------- +### Distribution. + +## Release number. +dist-hook: + echo $(VERSION) >$(distdir)/RELEASE + +## Additional build tools. +EXTRA_DIST += config/auto-version +EXTRA_DIST += config/confsubst + +###-------------------------------------------------------------------------- +### Debian. + +EXTRA_DIST += debian/rules debian/copyright +EXTRA_DIST += debian/control debian/changelog +EXTRA_DIST += debian/compat + +## libsod +EXTRA_DIST += debian/libsod.install + +## libsod-dev +EXTRA_DIST += debian/libsod-dev.install + +## sod +EXTRA_DIST += debian/sod.install + +## sod-dev +EXTRA_DIST += debian/sod-dev.install + ###----- That's all, folks -------------------------------------------------- diff --git a/configure.ac b/configure.ac index cb1c5a6..c1fed50 100644 --- a/configure.ac +++ b/configure.ac @@ -39,6 +39,32 @@ AX_CFLAGS_WARN_ALL mdw_LIBTOOL_VERSION_INFO dnl-------------------------------------------------------------------------- +dnl Convert the version number for ASDF. + +## This is surprisingly awful. The convention for official version numbers +## is that they look like MAJOR.MINOR.PATCH[.BPB][-N-gHEX[+]]. ASDF +## insists on simple numeric things separated by dots. If there's no Git +## thing on the end, then the main version number will do fine. If there +## is, then we insert /two/ `0's in, followed by N and the HEX converted to +## decimal. Why two? Because if there's no brown-paper-bag number, we +## want to make sure that the first BPB release is higher than any of the +## preceding Git revisions. +ver=AC_PACKAGE_VERSION +case $ver in + *-*-g*) + base=${ver%%-*} tail=${ver#*-} + n=${tail%%-*} tail=${tail#*-g} + case $tail in *+) grubby=.1 tail=${tail%+} ;; *) grubby= ;; esac + rev=$(( 0x$tail )) + ASDF_VERSION=$base.0.0.$n.$rev$grubby + ;; + *) + ASDF_VERSION=$ver + ;; +esac +AC_SUBST([ASDF_VERSION]) + +dnl-------------------------------------------------------------------------- dnl Common Lisp things. AC_ARG_WITH([lisp-system], diff --git a/debian/changelog b/debian/changelog new file mode 100644 index 0000000..f89bea0 --- /dev/null +++ b/debian/changelog @@ -0,0 +1,5 @@ +sod (0.2.0) experimental; urgency=low + + * Initial Debian packaging. + + -- Mark Wooding Sun, 06 Sep 2015 22:38:24 +0100 diff --git a/debian/compat b/debian/compat new file mode 100644 index 0000000..ec63514 --- /dev/null +++ b/debian/compat @@ -0,0 +1 @@ +9 diff --git a/debian/control b/debian/control new file mode 100644 index 0000000..4fda78f --- /dev/null +++ b/debian/control @@ -0,0 +1,60 @@ +Source: sod +Section: devel +Priority: extra +Maintainer: Mark Wooding +Build-Depends: debhelper (>= 8), cl-launch, sbcl | clisp, cl-asdf, cl-xlunit +Standards-Version: 3.1.1 + +Package: libsod +Architecture: any +Multi-Arch: same +Pre-Depends: ${misc:Pre-Depends} +Depends: ${shlibs:Depends}, ${misc:Depends} +Description: An object system for C, runtime library + Sod is a `sensible object design' for C, supporting a number of fancy + features, including multiple inheritance, method combinations with daemon + methods, and a compile-time metaprotocol. The only downside is that the + translator is written in Common Lisp. + . + This package contains a dynamically linkable version of the runtime support + library for Sod programs, which is deliberately very small. + +Package: libsod-dev +Architecture: any +Depends: libsod (= ${Source-Version}), libc6-dev, ${misc:Depends} +Suggests: sod +Description: An object system for C, runtime library + Sod is a `sensible object design' for C, supporting a number of fancy + features, including multiple inheritance, method combinations with daemon + methods, and a compile-time metaprotocol. The only downside is that the + translator is written in Common Lisp. + . + This package contains the development files for the runtime support library, + which are useful for clients of other libraries which are themselves built + on Sod. + +Package: sod +Architecture: any +Depends: ${shlibs:Depends} +Recommends: libsod-dev (= ${Source-Version}) +Description: An object system for C, translator + Sod is a `sensible object design' for C, supporting a number of fancy + features, including multiple inheritance, method combinations with daemon + methods, and a compile-time metaprotocol. The only downside is that the + translator is written in Common Lisp. + . + This package contains the Sod translator, which reads object definitions and + produces compilable C code. + +Package: sod-dev +Architecture: any +Recommends: sbcl | clisp, cl-asdf, cl-xlunit +Description: An object system for C, Lisp source + Sod is a `sensible object design' for C, supporting a number of fancy + features, including multiple inheritance, method combinations with daemon + methods, and a compile-time metaprotocol. The only downside is that the + translator is written in Common Lisp. + . + This package contains the source and ASDF system definition for the Sod + translator which, while may be useful for developing extensions or doing + interesting things with the translator. diff --git a/debian/copyright b/debian/copyright new file mode 100644 index 0000000..1da80a3 --- /dev/null +++ b/debian/copyright @@ -0,0 +1,21 @@ +Sod is copyright (c) 2015 Straylight/Edgeware + + +The Sod runtime library is free software; you can redistribute it and/or +modify it under the terms of the GNU Library 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 Library General Public +License for more details. + +You should have a copy of the GNU Library General Public License in +/usr/share/common-licenses/LGPL-2; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, +USA. + +You should have a copy of the GNU General Public License in +/usr/share/common-licenses/GPL; if not, write to the Free Software +Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. diff --git a/debian/libsod-dev.install b/debian/libsod-dev.install new file mode 100644 index 0000000..3b5a2b8 --- /dev/null +++ b/debian/libsod-dev.install @@ -0,0 +1,5 @@ +/usr/include/sod +/usr/lib/*/libsod.a +/usr/lib/*/libsod.la +/usr/lib/*/libsod.so +/usr/lib/*/pkgconfig diff --git a/debian/libsod.install b/debian/libsod.install new file mode 100644 index 0000000..7297331 --- /dev/null +++ b/debian/libsod.install @@ -0,0 +1 @@ +/usr/lib/*/libsod.so.* diff --git a/debian/rules b/debian/rules new file mode 100755 index 0000000..cec98bb --- /dev/null +++ b/debian/rules @@ -0,0 +1,2 @@ +#! /usr/bin/make -f +%:; dh $@ --parallel -Bdebian/build diff --git a/debian/sod-dev.install b/debian/sod-dev.install new file mode 100644 index 0000000..af1ca9c --- /dev/null +++ b/debian/sod-dev.install @@ -0,0 +1 @@ +/usr/share/common-lisp diff --git a/debian/sod.install b/debian/sod.install new file mode 100644 index 0000000..da67451 --- /dev/null +++ b/debian/sod.install @@ -0,0 +1 @@ +/usr/bin/sod diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp new file mode 100644 index 0000000..abbf94a --- /dev/null +++ b/doc/list-exports.lisp @@ -0,0 +1,346 @@ +(defun symbolicate (&rest things) + (intern (apply #'concatenate 'string (mapcar #'string things)))) + +(defun incomprehensible-form (head tail) + (format *error-output* ";; incomprehensible: ~S~%" (cons head tail))) + +(defgeneric form-list-exports (head tail) + (:method (head tail) + (declare (ignore head tail)) + nil)) + +(defmethod form-list-exports ((head (eql 'export)) tail) + (let ((symbols (car tail))) + (if (and (consp symbols) + (eq (car symbols) 'quote)) + (let ((thing (cadr symbols))) + (if (atom thing) (list thing) thing)) + (incomprehensible-form head tail)))) + +(defmethod form-list-exports ((head (eql 'definst)) tail) + (destructuring-bind (code (streamvar &key export) args &body body) tail + (declare (ignore streamvar body)) + (and export + (list* (symbolicate code '-inst) + (symbolicate 'make- code '-inst) + (mapcar (lambda (arg) + (symbolicate 'inst- arg)) + args))))) + +(defmethod form-list-exports ((head (eql 'define-tagged-type)) tail) + (destructuring-bind (kind what) tail + (declare (ignore what)) + (list kind + (symbolicate 'c- kind '-type) + (symbolicate 'make- kind '-type)))) + +(defmethod form-list-exports ((head (eql 'macrolet)) tail) + (mapcan #'form-exports (cdr tail))) + +(defmethod form-list-exports ((head (eql 'eval-when)) tail) + (mapcan #'form-exports (cdr tail))) + +(defmethod form-list-exports ((head (eql 'progn)) tail) + (mapcan #'form-exports tail)) + +(defgeneric form-exports (form) + (:method (form) nil) + (:method ((form cons)) (form-list-exports (car form) (cdr form)))) + +(defgeneric list-exports (thing)) + +(defmethod list-exports ((stream stream)) + (loop with eof = '#:eof + for form = (read stream nil eof) + until (eq form eof) + when (consp form) nconc (form-exports form))) + +(defmethod list-exports ((path pathname)) + (mapcar (lambda (each) + (cons each (with-open-file (stream each) (list-exports stream)))) + (directory (merge-pathnames path #p"*.lisp")))) + +(defmethod list-exports ((path string)) + (list-exports (pathname path))) + +(defun list-exported-symbols (package) + (sort (loop for s being the external-symbols of package collect s) + #'string< :key #'symbol-name)) + +(defun find-symbol-homes (paths package) + (let* ((symbols (list-exported-symbols package)) + (exports-alist (mapcan #'list-exports paths)) + (homes (make-hash-table :test #'equal))) + (dolist (assoc exports-alist) + (let ((home (car assoc))) + (dolist (symbol (cdr assoc)) + (let ((name (symbol-name symbol))) + (unless (nth-value 1 (find-symbol name package)) + (format *error-output* ";; unexported: ~S~%" symbol)) + (setf (gethash name homes) home))))) + (dolist (symbol symbols) + (unless (gethash (symbol-name symbol) homes) + (format *error-output* ";; mysterious: ~S~%" symbol))) + exports-alist)) + +(defun boring-setf-expansion-p (symbol) + (multiple-value-bind (temps args stores store fetch) + (ignore-errors (get-setf-expansion (list symbol))) + (declare (ignore temps args stores fetch)) + (and (consp store) + (eq (car store) 'funcall) + (consp (cdr store)) (consp (cadr store)) + (eq (caadr store) 'function) + (let ((func (cadadr store))) + (and (consp func) (consp (cdr func)) + (eq (car func) 'setf)))))) + +(defun specialized-on-p (func arg what) + (some (lambda (method) + (let ((spec (nth arg (sb-mop:method-specializers method)))) + (and (typep spec 'sb-mop:eql-specializer) + (eql (sb-mop:eql-specializer-object spec) what)))) + (sb-mop:generic-function-methods func))) + +(defun categorize (symbol) + (let ((things nil)) + (when (boundp symbol) + (push (if (constantp symbol) :constant :variable) things)) + (when (fboundp symbol) + (push (cond ((macro-function symbol) :macro) + ((typep (fdefinition symbol) 'generic-function) + :generic) + (t :function)) + things) + (when (or ;;(not (boring-setf-expansion-p symbol)) + (ignore-errors (fdefinition (list 'setf symbol)))) + (push :setf things))) + (when (find-class symbol nil) + (push :class things)) + (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol) + (specialized-on-p #'sod:expand-c-type-form 0 symbol)) + (push :c-type things)) + (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol) + (specialized-on-p #'sod-parser:expand-parser-form 1 symbol)) + (push :parser things)) + (nreverse things))) + +(defun categorize-symbols (paths package) + (mapcar (lambda (assoc) + (let ((home (car assoc)) + (symbols (delete-duplicates + (sort (mapcan (lambda (sym) + (multiple-value-bind + (symbol foundp) + (find-symbol + (symbol-name sym) + package) + (and foundp (list symbol)))) + (cdr assoc)) + #'string< :key #'symbol-name)))) + (cons home (mapcar (lambda (symbol) + (cons symbol (categorize symbol))) + symbols)))) + + (find-symbol-homes paths package))) + +(defun best-package-name (package) + (car (sort (cons (package-name package) + (copy-list (package-nicknames package))) + #'< :key #'length))) + +(defvar charbuf-size 0) + +(defun pretty-symbol-name (symbol package) + (let* ((pkg (symbol-package symbol)) + (exportp (member symbol (list-exported-symbols pkg)))) + (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)" + (and exportp (eq pkg package)) + (if (keywordp symbol) "" (best-package-name pkg)) + exportp (symbol-name symbol)))) + +(defun analyse-classes (package) + (setf package (find-package package)) + (let ((classes (mapcan (lambda (symbol) + (let ((class (find-class symbol nil))) + (and class + (typep class '(or standard-class + structure-class)) + (list class)))) + (list-exported-symbols package))) + (subs (make-hash-table))) + (let ((done (make-hash-table))) + (labels ((walk-up (class) + (unless (gethash class done) + (dolist (super (sb-mop:class-direct-superclasses class)) + (push class (gethash super subs)) + (walk-up super)) + (setf (gethash class done) t)))) + (dolist (class classes) + (walk-up class)))) + (labels ((walk-down (this super depth) + (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%" + (* 2 depth) + (pretty-symbol-name (class-name this) package) + (mapcar (lambda (class) + (pretty-symbol-name (class-name class) + package)) + (remove super + (sb-mop:class-direct-superclasses this)))) + (dolist (sub (sort (copy-list (gethash this subs)) + #'string< :key #'class-name)) + (walk-down sub this (1+ depth))))) + (walk-down (find-class t) nil 0)))) + +(defun analyse-generic-functions (package) + (setf package (find-package package)) + (flet ((function-name-core (name) + (etypecase name + (symbol name) + ((cons (eql setf) t) (cadr name))))) + (let ((methods (make-hash-table)) + (functions (make-hash-table)) + (externs (make-hash-table))) + (dolist (symbol (list-exported-symbols package)) + (setf (gethash symbol externs) t)) + (dolist (symbol (list-exported-symbols package)) + (flet ((dofunc (func) + (when (typep func 'generic-function) + (setf (gethash func functions) t) + (dolist (method (sb-mop:generic-function-methods func)) + (setf (gethash method methods) t))))) + (dofunc (and (fboundp symbol) (fdefinition symbol))) + (dofunc (ignore-errors (fdefinition (list 'setf symbol))))) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (when class + (dolist + (func (sb-mop:specializer-direct-generic-functions class)) + (let ((name (function-name-core + (sb-mop:generic-function-name func)))) + (when (or (not (eq (symbol-package name) package)) + (gethash name externs)) + (setf (gethash func functions) t) + (dolist (method (sb-mop:specializer-direct-methods class)) + (setf (gethash method methods) t))))))))) + (let ((funclist nil)) + (maphash (lambda (func value) + (declare (ignore value)) + (push func funclist)) + functions) + (setf funclist (sort funclist + (lambda (a b) + (let ((core-a (function-name-core a)) + (core-b (function-name-core b))) + (if (eq core-a core-b) + (and (atom a) (consp b)) + (string< core-a core-b)))) + :key #'sb-mop:generic-function-name)) + (dolist (function funclist) + (let ((name (sb-mop:generic-function-name function))) + (etypecase name + (symbol + (format t "~A~%" (pretty-symbol-name name package))) + ((cons (eql setf) t) + (format t "(setf ~A)~%" + (pretty-symbol-name (cadr name) package))))) + (dolist (method (sb-mop:generic-function-methods function)) + (when (gethash method methods) + (format t "~2T~{~A~^ ~}~%" + (mapcar + (lambda (spec) + (etypecase spec + (class + (let ((name (class-name spec))) + (if (eq name t) "t" + (pretty-symbol-name name package)))) + (sb-mop:eql-specializer + (let ((obj (sb-mop:eql-specializer-object spec))) + (format nil "(eql ~A)" + (if (symbolp obj) + (pretty-symbol-name obj package) + obj)))))) + (sb-mop:method-specializers method)))))))))) + +(defun check-slot-names (package) + (setf package (find-package package)) + (let* ((symbols (list-exported-symbols package)) + (classes (mapcan (lambda (symbol) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (and class (list class))))) + symbols)) + (offenders (mapcan + (lambda (class) + (let* ((slot-names + (mapcar #'sb-mop:slot-definition-name + (sb-mop:class-direct-slots class))) + (exported (remove-if-not + (lambda (sym) + (or (and (symbol-package sym) + (not (eq (symbol-package + sym) + package))) + (member sym symbols))) + slot-names))) + (and exported + (list (cons (class-name class) + exported))))) + classes)) + (bad-words (remove-duplicates (mapcan (lambda (list) + (copy-list (cdr list))) + offenders)))) + (values offenders bad-words))) + +(defun report-symbols (paths package) + (setf package (find-package package)) + (format t "~A~%Package `~(~A~)'~2%" + (make-string 77 :initial-element #\-) + (package-name package)) + (dolist (assoc (categorize-symbols paths package)) + (when (cdr assoc) + (format t "~A~%" (file-namestring (car assoc))) + (dolist (def (cdr assoc)) + (let ((sym (car def))) + (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%" + (pretty-symbol-name sym package) + (cdr def)))) + (terpri))) + (multiple-value-bind (alist names) (check-slot-names package) + (when names + (format t "Leaked slot names: ~{~A~^, ~}~%" + (mapcar (lambda (name) (pretty-symbol-name name package)) + names)) + (dolist (assoc alist) + (format t "~2T~A: ~{~A~^, ~}~%" + (pretty-symbol-name (car assoc) package) + (mapcar (lambda (name) (pretty-symbol-name name package)) + (cdr assoc)))) + (terpri))) + (format t "Classes:~%") + (analyse-classes package) + (terpri) + (format t "Methods:~%") + (analyse-generic-functions package) + (terpri)) + +(defun report-project-symbols () + (labels ((components (comp) + (slot-value comp 'asdf::components)) + (files (comp) + (sort (remove-if-not (lambda (comp) + (typep comp 'asdf:cl-source-file)) + (components comp)) + #'string< :key #'asdf:component-name)) + (by-name (comp name) + (find name (components comp) + :test #'string= :key #'asdf:component-name)) + (file-name (file) + (slot-value file 'asdf::absolute-pathname))) + (let* ((sod (asdf:find-system "sod")) + (parser-files (files (by-name sod "parser"))) + (utilities (by-name sod "utilities")) + (sod-files (remove utilities (files sod)))) + (report-symbols (mapcar #'file-name sod-files) "SOD") + (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER") + (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES")))) diff --git a/lib/Makefile.am b/lib/Makefile.am index 0e4c4fc..50473a9 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -50,7 +50,12 @@ nodist_pkginclude_HEADERS+= sod-base.h BUILT_SOURCES += $(nodist_libsod_la_SOURCES) \ $(nodist_pkginclude_HEADERS) -sod-base.c: $(SOD); $(SOD) -tc --builtin -sod-base.h: $(SOD); $(SOD) -th --builtin +sod-base.c: $(SOD); $(V_SOD_c)$(SOD) -tc --builtin +sod-base.h: $(SOD); $(V_SOD_h)$(SOD) -th --builtin + +###-------------------------------------------------------------------------- +### Manual pages. + +dist_man_MANS += sod.3 sod-structs.3 ###----- That's all, folks -------------------------------------------------- diff --git a/lib/sod-structs.3 b/lib/sod-structs.3 new file mode 100644 index 0000000..6aefc9d --- /dev/null +++ b/lib/sod-structs.3 @@ -0,0 +1,1026 @@ +.\" -*-nroff-*- +.\" +.\" Description of the main Sod data structures +.\" +.\" (c) 2015 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. +. +.\"\X'tty: sgr 1' +.\" String definitions and font selection. +.ie t \{\ +. ds o \(bu +. if \n(.g .fam P +.\} +.el \{\ +. ds o o +.\} +. +.\" .hP TEXT -- start an indented paragraph with TEXT hanging off to the left +.de hP +.IP +\h'-\w'\fB\\$1\ \fP'u'\fB\\$1\ \fP\c +.. +. +.\"-------------------------------------------------------------------------- +.TH sod-structs 3 "8 September 2015" "Straylight/Edgeware" "Sensible Object Design" +. +.SH NAME +sod-structs \- main Sod data structures +. +.\"-------------------------------------------------------------------------- +.SH SYNOPSIS +.nf +.ft B +#include + +typedef struct SodObject__ichain_obj SodObject; +typedef struct SodClass__ichain_obj SodClass; + +struct sod_instance { +\h'2n'const struct sod_vtable *_vt; +}; + +struct sod_vtable { +\h'2n'const SodClass *_class; +\h'2n'size_t _base; +}; + +struct SodObject__vt_obj { +\h'2n'const SodClass *_class; +\h'2n'size_t _base; +}; + +struct SodObject__ilayout { +\h'2n'union { +\h'4n'struct SodObject__ichain_obj { +\h'6n'const struct SodObject__vt_obj *_vt; +\h'4n'}; +\h'2n'} obj; +}; + +extern const struct SodClass__ilayout SodObject__classobj; +#define SodObject__class (&SodObject__classobj.obj.cls) + +struct SodClass__vt_obj { +\h'2n'const SodClass *_class; +\h'2n'size_t _base; +}; + +struct SodObject__ilayout { +\h'2n'union { +\h'4n'struct SodClass__ichain_obj { +\h'6n'const struct SodClass__vt_obj *_vt; +\h'6n'struct SodClass__islots { +\h'8n'const char *name; +\h'8n'const char *nick; +\h'8n'size_t initsz; +\h'8n'void *(*imprint)(void *\fIp\fB); +\h'8n'void *(*init)(void *\fIp\fB); +\h'8n'size_t n_supers; +\h'8n'const SodClass *const *supers; +\h'8n'size_t n_cpl; +\h'8n'const SodClass *const *cpl; +\h'8n'const SodClass *link; +\h'8n'const SodClass *head; +\h'8n'size_t level; +\h'8n'size_t n_chains; +\h'8n'const struct sod_chain *chains; +\h'8n'size_t off_islots; +\h'8n'size_t islotsz; +\h'6n'} cls; +\h'4n'}; +\h'4n'SodObject obj; +\h'2n'} obj; +}; + +struct sod_chain { +\h'2n'size_t n_classes; +\h'2n'const SodClass *const *classes; +\h'2n'size_t off_ichain; +\h'2n'const struct sod_vtable *vt; +\h'2n'size_t ichainsz; +}; + +extern const struct SodClass__ilayout SodClass__classobj; +#define SodClass__class (&SodClass__classobj.obj.cls) +.fi +.ft P +. +.\"-------------------------------------------------------------------------- +.SH DESCRIPTION +. +This page describes the structure and layout +of standard Sod objects, classes and associated metadata. +Note that Sod's object system is very flexible +and it's possible for an extension +to define a new root class +which works very differently from the standard +.B SodObject +described here. +. +.\"-------------------------------------------------------------------------- +.SH COMMON INSTANCE STRUCTURE +. +As described below, +a pointer to an instance actually points to an +.I "instance chain" +structure within the instances overall layout structure. +.PP +Instance chains contain slots and vtable pointers, +as described below. +All instances have the basic structure of a +.BR "struct sod_instance" , +which has the following members. +.TP +.B "const struct sod_vtable *_vt" +A pointer to a +.IR vtable , +which has the basic structure of a +.BR "struct sod_vtable" , +described below. +.PP +A vtable contains static metadata needed +for efficient conversions and +message dispatch, +and pointers to the instance's class. +Each chain points to a different vtable +All vtables have the basic structure of a +.BR "struct sod_vtable" , +which has the following members. +.TP +.B "const SodClass *_class" +A pointer to the instance's class object. +.TP +.B "size_t _base;" +The offset of this chain structure +above the start of the overall instance layout, in bytes. +Subtracting +.B _base +from the instance chain pointer +finds the layout base address. +. +.\"-------------------------------------------------------------------------- +.SH BUILT-IN ROOT OBJECTS +. +This section describes the built-in classes +.B SodObject +and +.BR SodClass , +which are the standard roots of the inheritance and metaclass graphs +respectively. +Specifically, +.B SodObject +has no direct superclasses, +and +.B SodClass +is its own metaclass. +It is not possible to define root classes because of circularities: +.B SodObject +has +.B SodClass +as its metaclass, and +.B SodClass +is a subclass of +.BR SodObject . +Extensions can define additional root classes, +but this is tricky, +and not really to be recommended. +. +.SS The SodObject class +The +.B SodObject +class defines no slots or messages. +Because +.B SodObject +has no direct superclasses, +there is only one chain, +and no inherited slots or messages, +so the single chain contains only a vtable pointer. +.PP +Since there are no messages, +and +.B SodClass +also has only one chain, +the vtable contains only the standard class pointer and offset-to-base +members. +In an actual instance of +.B SodObject +(why would you want one?) +the class pointer contains the address of +.B SodObject__class +and the offset is zero. +. +.SS The SodClass class +The +.B SodClass +class defines no messages, +but there are a number of slots. +Its only direct superclass is +.B SodObject +and so (like its superclass) its vtable is trivial. +.PP +The slots defined are as follows. +.TP +.B const char *name; +A pointer to the class's name. +.TP +.B const char *nick; +A pointer to the class's nickname. +.TP +.B size_t initsz; +The size in bytes required to store an instance of the class. +.TP +.BI "void *(*imprint)(void *" p ); +A pointer to a function: +given a pointer +.I p +to at least +.I initsz +bytes of appropriately aligned memory, +`imprint' this memory it so that it becomes a minimally functional +instance of the class: +all of the vtable and class pointers are properly initialized, +but the slots are left untouched. +The function returns its argument +.IR p . +.TP +.BI "void *(*init)(void *" p ); +A pointer to a function: +given a pointer +.I p +to at least +.I initsz +bytes of appropriately aligned memory, +initialize an instance of the class in it: +all of the vtable and class pointers are initialized, +as are slots for which initializers are defined. +Other slots are left untouched. +The function returns its argument +.IR p . +.TP +.B size_t n_supers; +The number of direct superclasses. +(This is zero exactly in the case of +.BR SodObject .) +.TP +.B const SodClass *const *supers; +A pointer to an array of +.I n_supers +pointers to class objects +listing the class's direct superclasses, +in the order in which they were listed in the class definition. +If +.I n_supers +is zero, +then this pointer is null. +.TP +.B size_t n_cpl; +The number of superclasses in the class's class precedence list. +.TP +.B const SodClass *const *cpl; +A pointer to an array of pointers to class objects +listing all of the class's superclasses, +from most- to least-specific, +starting with the class itself, +so +.IB c ->cls.cpl[0] += +.I c +for all class objects +.IR c . +.TP +.B const SodClass *link; +If the class is a chain head, then this is a null pointer; +otherwise it points to the class's distinguished link superclass +(which might or might not be a direct superclass). +.TP +.B const SodClass *head; +A pointer to the least-specific class in this class's chain; +so +.IB c ->cls.head->cls.link +is always null, +and either +.IB c ->cls.link +is null +(in which case +.IB c ->cls.head += +.IR c ) +or +.IB c ->cls.head += +.IB c ->cls.link->cls.head \fR. +.TP +.B size_t level; +The number of less specific superclasses in this class's chain. +If +.IB c ->cls.link +is null then +.IB c ->cls.level +is zero; +otherwise +.IB c ->cls.level += +.IB c ->cls.link->cls.level ++ 1. +.TP +.B size_t n_chains; +The number of chains formed by the class's superclasses. +.TP +.B const struct sod_chain *chains; +A pointer to an array of +.B struct sod_chain +structures (see below) describing the class's superclass chains, +in decreasing order of specificity of their most specific classes. +It is always the case that +.IB c ->cls.chains[0].classes[ c ->cls.level] += +.IR c . +.TP +.B size_t off_islots; +The offset of the class's +.B islots +structure relative to its containing +.B ichain +structure. +The class doesn't define any slots if and only if this is zero. +(The offset can't be zero because the vtable pointer is at offset zero.) +.TP +.B size_t islotsz; +The size required to store the class's direct slots, +i.e., the size of its +.B islots +structure. +The class doesn't define any slots if and only if this is zero. +.PP +The +.B struct sod_chain +structure describes an individual chain of superclasses. +It has the following members. +.TP +.B size_t n_classes; +The number of classes in the chain. +This is always at least one. +.TP +.B const SodClass *const *classes; +A pointer to an array of class pointers +listing the classes in the chain from least- to most-specific. +So +.IB classes [ i ]->cls.head += +.IB classes [0] +for all +0 \(<= +.I i +< +.IR n_classes , +.IB classes [0]->cls.link +is always null, +and +.IB classes [ i ]->cls.link += +.IB classes [ "i\fR \- 1" ] +if +1 \(<= +.I i +< +.IR n_classes . +.TP +.B size_t off_ichain; +The size of the +.B ichain +structure for this chain. +.TP +.B const struct sod_vtable *vt; +The vtable for this chain. +(It is possible, therefore, to duplicate the behaviour of the +.I imprint +function by walking the chain structure. +The +.I imprint +function is much faster, though.) +.TP +.B size_t ichainsz; +The size of the +.B ichain +structure for this chain. +. +.\"-------------------------------------------------------------------------- +.SH CLASS AND VTABLE LAYOUT +. +The layout algorithms for Sod instances and vtables are nontrivial. +They are defined here in full detail, +since they're effectively fixed by Sod's ABI compatibility guarantees, +so they might as well be documented for the sake of interoperating +programs. +.PP +Unfortunately, the descriptions are rather complicated, +and, for the most part not necessary to a working understanding of Sod. +The skeleton structure definitions shown should be more than enough +for readers attempting to make sense of the generated headers and tables. +.PP +In the description that follows, +uppercase letters vary over class names, +while the corresponding lowercase letters indicate the class nicknames. +Throughout, we consider a class +.I C +(therefore with nickname +.IR c ). +. +.SS Generic instance structure +The entire state of an instance of +.I C +is contained in a single structure of type +.B struct +.IB C __ilayout \fR. +.IP +.nf +.ft B +struct \fIC\fB__ilayout { +\h'2n'union \fIC\fB__ichainu_\fIh\fB { +\h'4n'struct \fIC\fB__ichain_\fIh\fB { +\h'6n'const struct \fIC\fB__vt_\fIh\fB *_vt; +\h'6n'struct \fIH\fB__islots \fIh\fB; +\h'6n'\fR...\fB +\h'6n'struct \fIC\fB__islots { +\h'8n'\fItype\fB \fIslota\fB; +\h'8n'\fR...\fB +\h'6n'} \fIc\fB; +\h'4n'} \fIc\fB; +\h'4n'\fR...\fB +\h'4n'struct \fIH\fB__ichain_\fIh\fB \fIh\fB; +\h'2n'} \fIh\fB; +\h'2n'union \fIB\fB__ichainu_\fIi\fB \fIi\fB; +\h'2n'\fR...\fB +}; + +typedef struct \fIC\fB__ichain_\fIh\fB \fIC\fB; +.ft P +.fi +.PP +The set of superclasses of +.IR C , +including itself, +can be partitioned into chains +by following their distinguished superclass links. +(Formally, the chains are the equivalence classes determined by +the reflexive, symmetric, transitive closure of +the `links to' relation.) +Chains are identified by naming their least specific classes; +the least specific class in a chain is called the +.IR "chain head" . +Suppose that the chain head of the chain containing +.I C +itself is named +.I H +(though keep in mind that it's possible that +.I H +is in fact +.I C +itself.) +.PP +The +.B ilayout +structure contains one member for each of +.IR C 's +superclass chains. +The first such member is +.IP +.B +.B union +.IB C __ichainu_ h +.IB h ; +.PP +described below; +this is followed by members +.IP +.B union +.IB B __ichainu_ i +.IB i ; +.PP +for each other chain, +where +.I I +is the head +and +.I B +the tail (most-specific) class of the chain. +The members are in decreasing order +of the specificity of the chains' most-specific classes. +(Note that all but the first of these unions +has already been defined as part of +the definition of the corresponding +.IR B .) +.PP +The +.B ichainu +union contains a member for each class in the chain. +The first is +.IP +.B struct +.IB C __ichain_ h +.IB c ; +.PP +and this is followed by corresponding members +.IP +.B struct +.IB A __ichain_ h +.IB a ; +.PP +for each of +.IR C 's superclasses +.IR A +in the same chain in some (unimportant) order. +A `pointer to +.IR C ' +is always assumed +(and, indeed, defined in C's type system) +to be a pointer to the +.B struct +.IB C __ichain_ h \fR. +.PP +The +.B ichain +structure contains (in order), a pointer +.IP +.B const +.B struct +.IB C __vt_ h +.B *_vt; +.PP +followed by a structure +.IP +.B struct +.IB A __islots +.IB a ; +.PP +for each superclass +.I A +of +.IR C +in the same chain which defines slots, +from least- to most-specific; +if +.I C +defines any slots, +then the last member is +.IP +.B struct +.IB C __islots +.IB c ; +.PP +Finally, the +.B islots +structure simply contains one member for each slot defined by +.I C +in the order they appear in the class definition. +. +.SS Generic vtable structure +As described above, +each +.B ichain +structure of an instance's storage +has a vtable pointer +.IP +.B const +.B struct +.IB C __vt_ h +.B *_vt; +.PP +In general, +the vtables for the different chains +will have +.I different +structures. +.PP +The instance layout split neatly into disjoint chains. +This is necessary because +each +.B ichain +must have as a prefix the +.B ichain +for each superclass in the same chain, and +each slot must be stored in exactly one place. +The layout of vtables doesn't have this second requirement: +it doesn't matter that there are +multiple method entry pointers +for the same effective method +as long as they all work correctly. +.PP +A vtable for a class +.I C +with chain head +.I H +has the following general structure. +.IP +.nf +.ft B +union \fIC\fB__vtu_\fIh\fB { +\h'2n'struct \fIC\fB__vt_\fIh\fB { +\h'4n'const \fIP\fB *_class; +\h'4n'size_t _base; +\h'4n'\fR...\fB +\h'4n'const \fIQ\fB *_cls_\fIj\fB; +\h'4n'\fR...\fB +\h'4n'ptrdiff_t _off_\fIi\fB; +\h'4n'\fR...\fB +\h'4n'struct \fIC\fB__vtmsgs_\fIa\fB { +\h'6n'\fItype\fB (*\fImsg\fB)(\fIC\fB *, \fR...\fB); +\h'6n'\fR...\fB +\h'4n'} \fIa\fB; +\h'4n'\fR...\fB +\h'2n'} \fIc\fB; +}; + +extern const union \fIC\fB__vtu_\fIh\fB \fIC\fB__vtable_\fIh\fB; +.ft P +.fi +.PP +The outer layer is a +.IP +.B union +.IB C __vtu_ h +.PP +containing a member +.IP +.B struct +.IB A __vt_ h +.IB a ; +.PP +for each of +.IR C 's +superclasses +.I A +in the same chain, +with +.I C +itself listed first. +This is mostly an irrelevant detail, +whose purpose is to defend against malicious compilers: +pointers are always to one of the inner +.B vt +structures. +It's important only because it's the outer +.B vtu +union which is exported by name. +Specifically, for each chain of +.IR C 's +superclasses +there is an external object +.IP +.B const union +.IB A __vtu_ i +.IB C __vtable_ i ; +.PP +where +.I A +and +.I I +are respectively the most and least specific classes in the chain. +.PP +The first member in the +.B vt +structure is the +.I root class pointer +.IP +.B const +.IR P +.B *_class; +.PP +Among the superclasses of +.I C +there must be exactly one class +.I O +which itself has no direct superclasses; +this is the +.I root superclass +of +.IR C . +(This is a rule enforced by the Sod translator.) +The metaclass +.I R +of +.IR O . +is then the +.I root metaclass +of +.IR C . +The +.B _class +member points to the +.B ichain +structure of most specific superclass +.I P +of +.I M +in the same chain as +.IR R . +.PP +This is followed by the +.I base offset +.IP +.B size_t +.B _base; +.PP +which is simply the offset of the +.B ichain +structure from the instance base. +.PP +The rest of the vtable structure is populated +by walking the superclass chain containing +.I C +as follows. +For each such superclass +.IR B , +in increasing order of specificity, +walk the class precedence list of +.IR B , +again starting with its least-specific superclass. +(This complex procedure guarantees that +the vtable structure for a class is a prefix of +the vtable structure for any of its subclasses in the same chain.) +.PP +So, let +.I A +be some superclass of +.I C +which has been encountered during this traversal. +.hP \*o +Let +.I N +be the metaclass of +.IR A . +Examine the superclass chains of +.I N +in order of decreasing specificity of their most-specific classes. +Let +.I J +be the chain head of such a chain, +and let +.I Q +be the most specific superclass of +.I M +in the same chain as +.IR J . +Then, if there is currently no class pointer of type +.I Q +then add a member +.RS +.IP +.B const +.I Q +.BI *_cls_ j ; +.PP +to the vtable +pointing to the appropriate +.B islots +structure within +.IR M 's +class object. +.RE +.hP \*o +Examine the superclass chains of +.I A +in order of decreasing specificity of their most-specific classes. +Let +.I I +be the chain head of such a chain. +If there is currently no member +.BI _off_ i +then add a member +.RS +.IP +.B ptrdiff_t +.BI _off_ i ; +.PP +to the vtable, +containing the (signed) offset from the +.B ichain +structure of the chain headed by +.I h +to that of the chain headed by +.I i +within the instance's layout. +.RE +.hP \*o +If class +.I A +defines any messages, +and there is currently no member +.I a +then add a member +.RS +.IP +.B struct +.IB C __vtmsgs_ a +.IB a ; +.PP +to the vtable. +See below. +.RE +.PP +Finally, the +.B vtmsgs +structures contain pointers to the effective method entry functions +for the messages defined by a superclass. +There may be more than one method entry for a message, +but all of the entry pointers for a message appear together, +and entry pointers for separate messages appear +in the order in which the messages are defined. +If the receiver class has no applicable primary method for a message +then it's usual for the method entry pointer to be null +(though, as with a lot of things in Sod, +extensions may do something different). +.PP +For a standard message which takes a fixed number of arguments, +defined as +.IP +.I tr +.IB m ( \c +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an ); +.PP +there is always a `main' entry point, +.IP +.I tr +.BI (* m )( \c +.I C +.BI * me , +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an ); +.PP +For a standard message which takes a variable number of arguments, +defined as +.IP +.I tr +.IB m ( \c +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an , +.B ...); +.PP +two entry points are defined: +the usual `main' entry point +which accepts a variable number of +arguments, +and a `valist' entry point +which accepts an argument of type +.B va_list +in place of the variable portion of the argument list. +.IP +.I tr +.BI (* m )( \c +.I C +.BI * me , +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an , +.B ...); +.br +.I tr +.BI (* m __v)( \c +.I C +.BI * me , +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an , +.B va_list +.IB sod__ap ); +. +.SS Additional definitions +In addition to the instance and vtable structures described above, +the following definitions are made for each class +.IR C . +.PP +For each message +.I m +directly defined by +.I C +there is a macro definition +.IP +.B #define +.IB C _ m ( me , +.RB ... ) +.IB me ->_vt-> c . m ( me , +.RB ... ) +.PP +which makes sending the message +.I m +to an instance of (any subclass of) +.I C +somewhat less ugly. +If +.I m +takes a variable number of arguments, +the macro is more complicated +and is only available in compilers advertising C99 support, +but the effect is the same. +For each variable-argument message, +there is also an additional macro +for calling the `valist' entry point. +.IP +.B #define +.IB C _ m __v( me , +.RB ..., +.IB sod__ap ) +.if !t \{\ +\e +.br +\h'4m'\c +.\} +.IB me ->_vt-> c . m __v( me , +.RB ..., +.IB sod__ap ) +.PP +For each proper superclass +.I A +of +.IR C , +there is a macro defined +.IP +.I A +.BI * C __CONV_ a ( C +.BI * _obj ); +.PP +(named in +.IR "upper case" ) +which converts a (static-type) pointer to +.I C +to a pointer to the same actual instance, +but statically typed as a pointer to +.IR A . +This is most useful when +.I A +is not in the same chain as +.I C +since in-chain upcasts are both trivial and rarely needed, +but the full set is defined for the sake of completeness. +.PP +Finally, the class object is defined as +.IP +.B extern const struct +.IB R __ilayout +.IB C __classobj; +.br +.B #define +.IB C __class +.BI (& C __classobj. j . r ) +.PP +The exported symbol +.IB C __classobj +contains the entire class instance. +This is usually rather unwieldy. +The macro +.IB C __class +is usable as a pointer of type +.B const +.I R +.BR * , +where +.I R +is the root metaclass of +.IR C , +i.e., the metaclass of the least specific superclass of +.IR C ; +usually this is +.BR "const SodClass *" . +. +.\"-------------------------------------------------------------------------- +.SH SEE ALSO +.BR sod (3). +. +.\"-------------------------------------------------------------------------- +.SH AUTHOR +Mark Wooding, +. +.\"----- That's all, folks -------------------------------------------------- diff --git a/lib/sod.3 b/lib/sod.3 new file mode 100644 index 0000000..83d004b --- /dev/null +++ b/lib/sod.3 @@ -0,0 +1,373 @@ +.\" -*-nroff-*- +.\" +.\" The Sod runtime library +.\" +.\" (c) 2015 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. +. +.\"\X'tty: sgr 1' +.\" String definitions and font selection. +.ie t \{\ +. ds o \(bu +. if \n(.g .fam P +.\} +.el \{\ +. ds o o +.\} +. +.\" .hP TEXT -- start an indented paragraph with TEXT hanging off to the left +.de hP +.IP +\h'-\w'\fB\\$1\ \fP'u'\fB\\$1\ \fP\c +.. +. +.\"-------------------------------------------------------------------------- +.TH sod 3 "8 September 2015" "Straylight/Edgeware" "Sensible Object Design" +. +.SH NAME +sod \- Sensible Object Design runtime library +. +.\"-------------------------------------------------------------------------- +.SH SYNOPSIS +.B #include +.PP +.B void *\c +.B SOD_XCHAIN(\c +.IB chead , +.BI "const " cls " *" obj ); +.br +.B ptrdiff_t +.B SOD_OFFSETDIFF(\c +.IB type , +.IB mema , +.IB memb ); +.br +.IB cls "__ilayout *" \c +.B SOD_ILAYOUT(\c +.IB cls , +.IB chead , +.BI "const void *" obj ); +.br +.B SOD_CAR(\c +.IB arg , +.RB ... ); +.PP +.B const void *\c +.B SOD_CLASSOF(\c +.BI "const " cls " *" obj ); +.br +.B void *\c +.B SOD_INSTBASE(\c +.BI "const " cls " *" obj ); +.br +.IB cls " *" \c +.B SOD_CONVERT(\c +.IB cls , +.BI "const void *" obj ); +.br +.B SOD_DECL(\c +.IB cls , +.IB var ); +.PP +.B int +.B sod_subclassp(\c +.BI "const SodClass *" sub , +.BI "const SodClass *" super ); +.br +.B int +.B sod_convert(\c +.BI "const SodClass *" cls , +.BI "const void *" obj ); +. +.\"-------------------------------------------------------------------------- +.SH DESCRIPTION +. +The functions and macros defined here generally expect that +instances and classes inherit from the standard +.B SodObject +root object. +While the translator can (at some effort) support alternative roots, +they will require different run-time support machinery. +. +.SS Infrastructure macros +These macros are mostly intended for use in code +generated by the Sod translator. +Others may find them useful for special effects, +but they can be tricky to understand and use correctly +and can't really be recommended for general use. +.PP +The +.B SOD_XCHAIN +macro performs a `cross-chain upcast'. +Given a pointer +.I cls +.BI * obj +to an instance of a class of type +.I cls +and the nickname +.I chead +of the least specific class in one of +.IR cls 's +superclass chains which does not contain +.I cls +itself, +.B SOD_XCHAIN(\c +.IB chead , +.IB obj ) +returns the address of that chain's storage +within the instance layout as a raw +.B void * +pointer. +(Note that +.I cls +is not mentioned explicitly.) +This macro is used by the generated +.IB CLASS __CONV_ CLS +conversion macros, +which you are encouraged to use instead where possible. +.PP +The +.B SOD_OFFSETDIFF +macro returns the signed offset between +two members of a structure or union type. +Given a structure or union type +.IR type , +and two member names +.I mema +and +.IR memb , +then +.B SOD_OFFSETDIFF(\c +.IB type , +.IB mema , +.IB memb ) +gives the difference, in bytes, +between the objects +.IB x . mema +and +.IB x . memb +for any object +.I x +of type +.IR type . +This macro is used internally when generating vtables +and is not expected to be very useful elsewhere. +.PP +The +.B SOD_ILAYOUT +macro recovers the instance layout base address +from a pointer to one of its instance chains. +Specifically, given a class name +.IR cls , +the nickname +.I chead +of the least specific class in one of +.IR cls 's +superclass chains, +and a pointer +.I obj +to the instance storage for the chain containing +.I chead +within an exact instance of +.I cls +(i.e., not an instance of any proper subclass), +.B SOD_ILAYOUT(\c +.IB cls , +.IB chead , +.IB obj ) +returns the a pointer to the layout structure containing +.IB obj . +This macro is used internally in effective method bodies +and is not expected to be very useful elsewhere +since it's unusual to have such specific knowledge +about the dynamic type of an instance. +The +.B SOD_INSTBASE +macro (described below) is more suited to general use. +.PP +The +.B SOD_CAR +macro accepts one or more arguments +and expands to just its first argument, +discarding the others. +It is only defined if the C implementation +advertises support for C99. +It is used in the definitions of message convenience macros +for messages which accept a variable number of arguments +but no required arguments, +and is exported because the author has found such a thing useful in +other contexts. +. +.SS Utility macros +The following macros are expected to be useful +in Sod method definitions and client code. +.PP +The +.B SOD_CLASSOF +macro returns the class object describing an instance's dynamic class. +Given a pointer +.BI "const " cls " *" obj +to an instance, +.BI SOD_CLASSOF( obj ) +returns a pointer to +.IR obj 's +dynamic class, +which +(assuming +.I obj +is typed correctly in the first place) +will be a subclass of +.IR cls . +(If you wanted the class object for +.I cls +itself, +it's called +.IB cls __class \fR.) +.PP +The +.B SOD_INSTBASE +macro finds the base address of an instance's layout. +Given a pointer +.BI "const " cls " *" obj +to an instance, +.BI SOD_INSTBASE( obj ) +returns the base address of the storage allocated to +.IR obj . +This is useful if you want to free a dynamically allocated instance, +for example. +This macro needs to look up an offset in +.IR obj 's +vtable to do its work. +Compare +.B SOD_ILAYOUT +above, +which is faster but requires +precise knowledge of the instance's dynamic class. +.PP +The +.B SOD_CONVERT +macro performs general conversions +(up-, down-, and cross-casts) on instance pointers. +Given a class name +.I cls +and a pointer +.BI "const void *" obj +to an instance, +.B SOD_CONVERT(\c +.IB cls , +.IB obj ) +returns an appropriately converted pointer to +.I obj +if +.I obj +is indeed an instance of (some subclass of) +.IR cls ; +otherwise it returns a null pointer. +This macro is a simple wrapper around the +.B sod_convert +function described below, +which is useful in the common case that +the target class is known statically. +.PP +The +.B SOD_DECL +macro declares and initializes an instance +with automatic storage duration. +Given a class name +.I cls +and an identifier +.IR var , +.B SOD_DECL(\c +.IB cls , +.IB var ) +declares +.I var +to be a pointer to an instance of +.IR cls . +The instance is initialized in the sense that +its vtable and class pointers have been set up, +and slots for which initializers are defined +are set to the appropriate initial values. +The instance has automatic storage duration: +pointers to it will become invalid when control +exits the scope of the declaration. +. +.SS Functions +The following functions are provided. +.PP +The +.B sod_subclassp +function answers whether one class +.I sub +is actually a subclass of another class +.IR super . +.B sod_subclassp(\c +.IB sub , +.IB super ) +returns nonzero if and only if +.I sub +is a subclass of +.IR super . +This involves a run-time trawl through the class structures: +while some effort has been made to make it perform well +it's still not very fast. +.PP +The +.B sod_convert +function performs general conversions +(up-, down-, and cross-casts) on instance pointers. +Given a class pointer +.I cls +and an instance pointer +.IR obj , +.B sod_convert(\c +.IB cls , +.IB obj ) +returns an appropriately converted pointer to +.I obj +in the case that +.I obj +is an instance of (some subclass of) +.IR cls ; +otherwise it returns null. +This involves a run-time trawl through the class structures: +while some effort has been made to make it perform well +it's still not very fast. +For upcasts (where +.I cls +is a superclass of the static type of +.IR obj ) +the automatically defined conversion macros should be used instead, +because they're much faster and can't fail. +When the target class is known statically, +it's slightly more convenient to use the +.B SOD_CONVERT +macro instead. +. +.\"-------------------------------------------------------------------------- +.SH SEE ALSO +.BR sod-structs (3). +. +.\"-------------------------------------------------------------------------- +.SH AUTHOR +Mark Wooding, +. +.\"----- That's all, folks -------------------------------------------------- diff --git a/lib/sod.c b/lib/sod.c index 1f6ef2e..7c2336d 100644 --- a/lib/sod.c +++ b/lib/sod.c @@ -9,19 +9,20 @@ * * 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. + * The SOD Runtime Library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library 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, + * The SOD Runtime 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. + * GNU Library 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. + * You should have received a copy of the GNU Library 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. */ /*----- Header files ------------------------------------------------------*/ diff --git a/lib/sod.h b/lib/sod.h index 9b9e611..efac06b 100644 --- a/lib/sod.h +++ b/lib/sod.h @@ -9,19 +9,20 @@ * * 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. + * The SOD Runtime Library is free software; you can redistribute it and/or + * modify it under the terms of the GNU Library 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, + * The SOD Runtime 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. + * GNU Library 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. + * You should have received a copy of the GNU Library 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. */ #ifndef SOD_H @@ -52,7 +53,7 @@ struct sod_vtable { * these. */ struct sod_instance { - struct sod_vtable *_vt; /* Pointer to (chain's) vtable */ + const struct sod_vtable *_vt; /* Pointer to (chain's) vtable */ }; /* Information about a particular chain of superclasses. In each class, @@ -75,14 +76,15 @@ struct sod_chain { * Arguments: @chead@ = nickname of target chain's head * @obj@ = pointer to an instance chain * - * Returns: Pointer to target chain, as a @char *@. + * Returns: Pointer to target chain, as a @void *@. * * Use: Utility for implementing cross-chain upcasts. It's probably * not that clever to use this macro directly; it's used to make * the automatically-generated upcast macros more palatable. */ -#define SOD_XCHAIN(chead, obj) ((char *)(obj) + (obj)->_vt->_off_##chead) +#define SOD_XCHAIN(chead, obj) \ + ((void *)((char *)(obj) + (obj)->_vt->_off_##chead)) /* --- @SOD_OFFSETDIFF@ --- * * @@ -123,6 +125,18 @@ struct sod_chain { ((struct cls##__ilayout *) \ ((char *)(obj) - offsetof(struct cls##__ilayout, chead))) +/* --- @SOD_CAR@ --- * + * + * Arguments: @...@ = a nonempty list of arguments + * + * Returns: The first argument only. + */ + +#if __STDC_VERSION__ >= 199901 +# define SOD_CAR(...) SOD__CARx(__VA_LIST__, _) +# define SOD__CARx(a, ...) a +#endif + /*----- Utility macros ----------------------------------------------------*/ /* --- @SOD_CLASSOF@ --- * @@ -167,6 +181,19 @@ struct sod_chain { #define SOD_CONVERT(cls, obj) ((cls *)sod_convert(cls##__class, (obj))) +/* --- @SOD_DECL@ --- * + * + * Arguments: @cls_@ = a class type name + * @var_@ = a variable name + * + * Use: Declare @var_@ as a pointer to an initialized instance of + * @cls_@ with automatic lifetime. + */ + +#define SOD_DECL(cls_, var_) \ + struct cls_##__ilayout var_##__layout; \ + cls_ *var_ = cls_##__class->cls.init(&var_##__layout) + /*----- Functions provided ------------------------------------------------*/ /* --- @sod_subclassp@ --- * diff --git a/pre-reorg/builtin.lisp b/pre-reorg/builtin.lisp deleted file mode 100644 index ef99571..0000000 --- a/pre-reorg/builtin.lisp +++ /dev/null @@ -1,42 +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) - -;;;-------------------------------------------------------------------------- -;;; 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 deleted file mode 100644 index 4a443cd..0000000 --- a/pre-reorg/c-types.lisp +++ /dev/null @@ -1,79 +0,0 @@ -;;; -*-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 deleted file mode 100644 index 5107ffb..0000000 --- a/pre-reorg/class-builder.lisp +++ /dev/null @@ -1,129 +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.")) - -;;;-------------------------------------------------------------------------- -;;; 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/pre-reorg/class-defs.lisp b/pre-reorg/class-defs.lisp deleted file mode 100644 index 59c8716..0000000 --- a/pre-reorg/class-defs.lisp +++ /dev/null @@ -1,515 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Basic definitions for classes, methods and suchlike -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Classes. - -(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 the generic function 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. - - * 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. - -(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))))) - -(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)))) - -(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.")) - -(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. - -(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))))) - -(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)))) - -;;;-------------------------------------------------------------------------- -;;; Classes as C types. - -(defclass c-class-type (simple-c-type) - ((class :initarg :class :type (or null sod-class) :accessor c-type-class)) - (: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.")) - -(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))) - -(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))) - -(defun find-class-type (name &optional floc) - "Look up NAME and return the corresponding C-CLASS-TYPE. - - Returns two values: TYPE and WINP. - - * 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 at FLOC." - - (with-default-error-location (floc) - (let ((type (gethash name *type-map*))) - (typecase type - (null nil) - (c-class-type type) - (t (error "Type `~A' (~A) is not a class" name type)))))) - -(defun make-class-type (name &optional floc) - "Return a class type for NAME, creating it if necessary. - - FLOC is the location to use in error reports." - (let ((name (etypecase name - (sod-class (sod-class-name name)) - (string name)))) - (or (find-class-type name floc) - (setf (gethash name *type-map*) - (make-instance 'c-class-type :name name :class nil))))) - -(defun find-sod-class (name &optional floc) - "Return the SOD-CLASS object with the given NAME. - - FLOC is the location to use in error reports." - (with-default-error-location (floc) - (let ((type (find-class-type name floc))) - (cond ((not type) (error "Type `~A' not known" name)) - (t (let ((class (c-type-class type))) - (unless class - (error "Class `~A' is incomplete" name)) - class)))))) - -(defun record-sod-class (class &optional (floc class)) - "Record CLASS as being a class definition. - - FLOC is the location to use in error reports." - (with-default-error-location (floc) - (let* ((name (sod-class-name class)) - (type (make-class-type name floc))) - (cond ((null type) nil) - ((c-type-class type) - (cerror* "Class `~A' already defined at ~A" - name (file-location (c-type-class type)))) - (t - (setf (c-type-class type) class)))))) - -(define-c-type-syntax class (name &rest quals) - "Returns a type object for the named class." - (if quals - `(qualify-type (make-class-type ,name) (list ,@quals)) - `(make-class-type ,name))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/class-finalize.lisp b/pre-reorg/class-finalize.lisp deleted file mode 100644 index fc2d967..0000000 --- a/pre-reorg/class-finalize.lisp +++ /dev/null @@ -1,31 +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. - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/class-layout.lisp b/pre-reorg/class-layout.lisp deleted file mode 100644 index 8b6b1eb..0000000 --- a/pre-reorg/class-layout.lisp +++ /dev/null @@ -1,80 +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.)")) - -;;;-------------------------------------------------------------------------- -;;; 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/pre-reorg/class-output.lisp b/pre-reorg/class-output.lisp deleted file mode 100644 index b93a0a0..0000000 --- a/pre-reorg/class-output.lisp +++ /dev/null @@ -1,579 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Output functions for classes -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; 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))))) - -;;;-------------------------------------------------------------------------- -;;; 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)))))) - -;;;-------------------------------------------------------------------------- -;;; Testing. - -#+test -(defun test (name) - (let ((sequencer (make-instance 'sequencer)) - (class (find-sod-class name))) - (hook-output class :h sequencer) - (invoke-sequencer-items sequencer *standard-output*) - sequencer)) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/codegen.lisp b/pre-reorg/codegen.lisp deleted file mode 100644 index c177a6a..0000000 --- a/pre-reorg/codegen.lisp +++ /dev/null @@ -1,89 +0,0 @@ -;;; -*-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 deleted file mode 100644 index 2287fab..0000000 --- a/pre-reorg/combination.lisp +++ /dev/null @@ -1,34 +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. - -;;;-------------------------------------------------------------------------- -;;; Standard method combination. - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/cpl.lisp b/pre-reorg/cpl.lisp deleted file mode 100644 index eb7a3fa..0000000 --- a/pre-reorg/cpl.lisp +++ /dev/null @@ -1,133 +0,0 @@ -;;; -*-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 deleted file mode 100644 index 294e5b6..0000000 --- a/pre-reorg/cutting-room-floor.lisp +++ /dev/null @@ -1,491 +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)))) - -;;;-------------------------------------------------------------------------- -;;; 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/pre-reorg/errors.lisp b/pre-reorg/errors.lisp deleted file mode 100644 index 6ff6747..0000000 --- a/pre-reorg/errors.lisp +++ /dev/null @@ -1,243 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Error types and handling 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) - -;;;-------------------------------------------------------------------------- -;;; Enclosing conditions. - -(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. - -(define-condition condition-with-location (condition) - ((location :initarg :location :reader file-location :type file-location)) - (:documentation - "A condition which has some location information attached.")) - -(define-condition enclosing-condition-with-location - (condition-with-location enclosing-condition) - ()) - -(define-condition error-with-location (condition-with-location error) - ()) - -(define-condition warning-with-location (condition-with-location warning) - ()) - -(define-condition enclosing-error-with-location - (enclosing-condition-with-location error) - ()) - -(define-condition enclosing-warning-with-location - (enclosing-condition-with-location warning) - ()) - -(define-condition simple-condition-with-location - (condition-with-location simple-condition) - ()) - -(define-condition simple-error-with-location - (error-with-location simple-error) - ()) - -(define-condition simple-warning-with-location - (warning-with-location simple-warning) - ()) - -;;;-------------------------------------------------------------------------- -;;; Error reporting functions. - -(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))))) - -(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))) - -(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))) - -(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))) - -(defun cerror* (datum &rest arguments) - (apply #'cerror "Continue" datum arguments)) - -(defun cerror*-with-location (floc datum &rest arguments) - (apply #'cerror-with-location floc "Continue" datum arguments)) - -(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)))) - -(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))) - -(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))) - -(defmacro with-default-error-location ((floc) &body body) - "Evaluate BODY 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 subtype of - ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original - condition, and signalled. 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." - `(with-default-error-location* ,floc (lambda () ,@body))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/examples.lisp b/pre-reorg/examples.lisp deleted file mode 100644 index 82702a6..0000000 --- a/pre-reorg/examples.lisp +++ /dev/null @@ -1,75 +0,0 @@ -(set-dispatch-macro-character #\# #\{ 'c-fragment-reader) - -(defparameter *chimaera-module* - (define-module ("chimaera.sod") - - (define-fragment (:c :includes) #{ - #include "chimaera.h" - }) - - (define-fragment (:h :includes) #{ - #include "sod.h" - }) - - (define-sod-class "Animal" ("SodObject") - :nick 'nml - :link '|SodObject| - (slot "tickles" int) - (instance-initializer "nml" "tickles" :single #{ 0 }) - (message "tickle" (fun void)) - (method "nml" "tickle" (fun void) #{ - me->tickles++; - } - :role :before) - (method "nml" "tickle" (fun void) #{ })) - - (define-sod-class "Lion" ("Animal") - :nick 'lion - :link '|Animal| - (message "bite" (fun void)) - (method "lion" "bite" (fun void) #{ - puts("Munch!"); - }) - (method "nml" "tickle" (fun void) #{ - me->_vt->lion.bite(me); - CALL_NEXT_METHOD; - })) - - (define-sod-class "Goat" ("Animal") - :nick 'goat - (message "butt" (fun void)) - (method "goat" "butt" (fun void) #{ - puts("Whack!"); - }) - (method "nml" "tickle" (fun void) #{ - me->_vt->goat.bite(me); - CALL_NEXT_METHOD; - })) - - (define-sod-class "Serpent" ("Animal") - :nick 'serpent - (message "bite" (fun void)) - (method "serpent" "bite" (fun void) #{ - puts("Nom!"); - }) - (message "hiss" (fun void)) - (method "serpent" "hiss" (fun void) #{ - puts("Ssss!"); - }) - (method "nml" "tickle" (fun void) #{ - if (me->tickles < 3) me->_vt->hiss(me); - else me->_vt->bite(me); - CALL_NEXT_METHOD; - })) - - (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent") - :nick 'sir - :link '|Lion|) - - (defparameter *chimaera* (find-sod-class "Chimaera")) - (defparameter *emeth* (find "tickle" - (sod-class-effective-methods *chimaera*) - :key (lambda (method) - (sod-message-name - (effective-method-message method))) - :test #'string=)))) diff --git a/pre-reorg/foo.lisp b/pre-reorg/foo.lisp deleted file mode 100644 index b5b8509..0000000 --- a/pre-reorg/foo.lisp +++ /dev/null @@ -1,2 +0,0 @@ -;;; -(write-line "stuff's a-goin' on") diff --git a/pre-reorg/lex.lisp b/pre-reorg/lex.lisp deleted file mode 100644 index d7fd2c0..0000000 --- a/pre-reorg/lex.lisp +++ /dev/null @@ -1,604 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Lexical analysis of a vaguely C-like language -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Basic lexical analyser infrastructure. - -;; Class definition. - -(defclass 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) - (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).")) - -;; Lexer protocol. - -(defgeneric scan-token (lexer) - (:documentation - "Internal function 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.")) - -(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-NAME on the LEXER object. - - If tokens have been pushed back (see PUSHBACK-TOKEN) then they are - returned one by one instead of scanning the stream.") - - (:method ((lexer lexer)) - (with-slots (pushback-tokens token-type token-value) lexer - (setf (values token-type token-value) - (if pushback-tokens - (let ((pushback (pop pushback-tokens))) - (values (car pushback) (cdr pushback))) - (scan-token lexer)))))) - -(defgeneric pushback-token (lexer token-type &optional token-value) - (: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. The FILE-LOCATION is - not affected by pushing tokens back. The TOKEN-TYPE and TOKEN-VALUE be - anything at all: for instance, they need not be values which can actually - be returned by NEXT-TOKEN.") - - (:method ((lexer lexer) new-token-type &optional new-token-value) - (with-slots (pushback-tokens token-type token-value) lexer - (push (cons token-type token-value) pushback-tokens) - (setf token-type new-token-type - token-value new-token-value)))) - -(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. - - (This function is primarily intended for the use of lexer subclasses.)") - - (:method ((lexer lexer)) - (with-slots (stream char pushback-chars) lexer - (setf char (if pushback-chars - (pop pushback-chars) - (read-char stream nil)))))) - -(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.)") - - (:method ((lexer lexer) new-char) - (with-slots (char pushback-chars) lexer - (push char pushback-chars) - (setf char new-char)))) - -(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.") - - (:method ((lexer lexer) thunk) - (with-slots (stream char pushback-chars) lexer - (when pushback-chars - (error "Lexer has pushed-back characters.")) - (unread-char char stream) - (unwind-protect - (funcall thunk stream) - (setf char (read-char stream nil)))))) - -(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))) - -(defmethod file-location ((lexer lexer)) - (with-slots (stream) lexer - (file-location stream))) - -(defgeneric skip-spaces (lexer) - (:documentation - "Skip over whitespace characters in the LEXER.")) - -;;;-------------------------------------------------------------------------- -;;; Lexer utilities. - -;;;-------------------------------------------------------------------------- -;;; Our main lexer. - -(defun make-keyword-table (&rest keywords) - "Construct a keyword table for the lexical analyser. - - The KEYWORDS arguments are individual keywords, either as strings or as - (WORD . VALUE) pairs. A string argument is equivalent to a pair listing - the string itself as WORD and the corresponding keyword symbol (forced to - uppercase) as the VALUE." - - (let ((table (make-hash-table :test #'equal))) - (dolist (item keywords) - (multiple-value-bind (word keyword) - (if (consp item) - (values (car item) (cdr item)) - (values item (intern (string-upcase item) :keyword))) - (setf (gethash word table) keyword))) - table)) - -(defparameter *sod-keywords* - (make-keyword-table - - ;; Words with a meaning to C's type system. - "char" "int" "float" "void" - "long" "short" "signed" "unsigned" "double" - "const" "volatile" "restrict" - "struct" "union" "enum")) - -(defclass sod-lexer (lexer) - () - (:documentation - "Lexical analyser for the SOD lanuage. - - See the LEXER class for the gory details about the lexer protocol.")) - -(defun format-token (token-type &optional token-value) - (when (typep token-type 'lexer) - (let ((lexer token-type)) - (setf token-type (token-type lexer) - token-value (token-value lexer)))) - (etypecase token-type - ((eql :eof) "") - ((eql :string) "") - ((eql :char) "") - ((eql :id) (format nil "" token-value)) - (keyword (format nil "`~(~A~)'" token-type)) - (character (format nil "~:[<~:C>~;`~C'~]" - (and (graphic-char-p token-type) - (char/= token-type #\space)) - token-type)))) - -(defmethod scan-token ((lexer sod-lexer)) - (with-slots (stream char keywords) lexer - (prog ((ch char)) - - consider - (cond - - ;; End-of-file brings its own peculiar joy. - ((null ch) (return (values :eof t))) - - ;; Ignore whitespace and continue around for more. - ((whitespace-char-p ch) (go scan)) - - ;; Strings. - ((or (char= ch #\") (char= ch #\')) - (with-default-error-location ((file-location lexer)) - (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") - (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 :ellpisis 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)))) - -;;;-------------------------------------------------------------------------- -;;; C fragments. - -(defun scan-c-fragment (lexer end-chars) - "Snarfs a sequence of C tokens with balanced brackets. - - Reads and consumes characters from the LEXER's stream, and returns them as - a string. The string will contain whole C tokens, up as far as an - occurrence of one of the END-CHARS (a list) which (a) is not within a - string or character literal or comment, and (b) appears at the outer level - of nesting of brackets (whether round, curly or square -- again counting - only brackets which aren't themselves within string/character literals or - comments. The final END-CHAR is not consumed. - - An error is signalled if either the stream ends before an occurrence of - one of the END-CHARS, or if mismatching brackets are encountered. No - other attempt is made to ensure that the characters read are in fact a - valid C fragment. - - Both original /*...*/ and new //... comments are recognized. Trigraphs - and digraphs are currently not recognized." - - (let ((output (make-string-output-stream)) - (ch (lexer-char lexer)) - (start-floc (file-location lexer)) - (delim nil) - (stack nil)) - - ;; Main loop. At the top of this loop, we've already read a - ;; character into CH. This is usually read at the end of processing - ;; the individual character, though sometimes (following `/', for - ;; example) it's read speculatively because we need one-character - ;; lookahead. - (block loop - (labels ((getch () - "Read the next character into CH; complain if we hit EOF." - (unless (setf ch (next-char lexer)) - (cerror*-with-location start-floc - "Unexpected end-of-file in C fragment") - (return-from loop)) - ch) - (putch () - "Write the character to the output buffer." - (write-char ch output)) - (push-delim (d) - "Push a closing delimiter onto the stack." - (push delim stack) - (setf delim d) - (getch))) - - ;; Hack: if the first character is a newline, discard it. Otherwise - ;; (a) the output fragment will look funny, and (b) the location - ;; information will be wrong. - (when (eql ch #\newline) - (getch)) - - ;; And fetch characters. - (loop - - ;; Here we're outside any string or character literal, though we - ;; may be nested within brackets. So, if there's no delimiter, and - ;; we've found the end character, we're done. - (when (and (null delim) (member ch end-chars)) - (return)) - - ;; Otherwise take a copy of the character, and work out what to do - ;; next. - (putch) - (case ch - - ;; Starting a literal. Continue until we find a matching - ;; character not preceded by a `\'. - ((#\" #\') - (let ((quote ch)) - (loop - (getch) - (putch) - (when (eql ch quote) - (return)) - (when (eql ch #\\) - (getch) - (putch))) - (getch))) - - ;; Various kinds of opening bracket. Stash the current - ;; delimiter, and note that we're looking for a new one. - (#\( (push-delim #\))) - (#\[ (push-delim #\])) - (#\{ (push-delim #\})) - - ;; Various kinds of closing bracket. If it matches the current - ;; delimeter then unstack the next one along. Otherwise - ;; something's gone wrong: C syntax doesn't allow unmatched - ;; brackets. - ((#\) #\] #\}) - (if (eql ch delim) - (setf delim (pop stack)) - (cerror* "Unmatched `~C'." ch)) - (getch)) - - ;; A slash. Maybe a comment next. But maybe not... - (#\/ - - ;; Examine the next character to find out how to proceed. - (getch) - (case ch - - ;; A second slash -- eat until the end of the line. - (#\/ - (putch) - (loop - (getch) - (putch) - (when (eql ch #\newline) - (return))) - (getch)) - - ;; A star -- eat until we find a star-slash. Since the star - ;; might be preceded by another star, we use a little state - ;; machine. - (#\* - (putch) - (tagbody - - main - ;; Main state. If we read a star, switch to star state; - ;; otherwise eat the character and try again. - (getch) - (putch) - (case ch - (#\* (go star)) - (t (go main))) - - star - ;; Star state. If we read a slash, we're done; if we read - ;; another star, stay in star state; otherwise go back to - ;; main. - (getch) - (putch) - (case ch - (#\* (go star)) - (#\/ (go done)) - (t (go main))) - - done - (getch))))) - - ;; Something else. Eat it and continue. - (t (getch))))) - - (let* ((string (get-output-stream-string output)) - (end (position-if (lambda (char) - (or (char= char #\newline) - (not (whitespace-char-p char)))) - string - :from-end t)) - (trimmed (if end - (subseq string 0 (1+ end)) - ""))) - - ;; Return the fragment we've collected. - (make-instance 'c-fragment - :location start-floc - :text trimmed))))) - -(defun c-fragment-reader (stream char arg) - "Reader for C-fragment syntax #{ ... stuff ... }." - (declare (ignore char arg)) - (let ((lexer (make-instance 'sod-lexer - :stream stream))) - (next-char lexer) - (scan-c-fragment lexer '(#\})))) - -#+interactive -(set-dispatch-macro-character #\# #\{ 'c-fragment-reader) - -;;;-------------------------------------------------------------------------- -;;; Testing cruft. - -#+test -(with-input-from-string (in " -{ foo } 'x' /?/***/! -123 0432 0b010123 0xc0ffee __burp_32 class - -0xturning 0xfattening -... - -class integer : integral_domain { - something here; -} - -") - (let* ((stream (make-instance 'position-aware-input-stream - :stream in - :file #p"magic")) - (lexer (make-instance 'sod-lexer - :stream stream - :keywords *sod-keywords*)) - (list nil)) - (next-char lexer) - (loop - (multiple-value-bind (tokty tokval) (next-token lexer) - (push (list tokty tokval) list) - (when (eql tokty :eof) - (return)))) - (nreverse list))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/methods.lisp b/pre-reorg/methods.lisp deleted file mode 100644 index 93782be..0000000 --- a/pre-reorg/methods.lisp +++ /dev/null @@ -1,43 +0,0 @@ -;;; -*-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/pre-reorg/module-output.lisp b/pre-reorg/module-output.lisp deleted file mode 100644 index fd690ad..0000000 --- a/pre-reorg/module-output.lisp +++ /dev/null @@ -1,40 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Output handling for modules -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Utilities. - -;;;-------------------------------------------------------------------------- -;;; Main output protocol implementation. - -;;;-------------------------------------------------------------------------- -;;; Header output. - -;;;-------------------------------------------------------------------------- -;;; Source output. - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/module.lisp b/pre-reorg/module.lisp deleted file mode 100644 index 2b339f4..0000000 --- a/pre-reorg/module.lisp +++ /dev/null @@ -1,340 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Modules and module parser -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Module importing. - -(defun read-module (pathname &key (truename (truename pathname)) location) - "Reads a module. - - The module is returned if all went well; nil is returned if an error - occurred. - - The PATHNAME argument is the file to read. TRUENAME should be the file's - truename, if known: often, the file will have been searched for using - `probe-file' or similar, which drops the truename into your lap." - - ;; Deal with a module which is already in the map. If its state is a - ;; FILE-LOCATION then it's in progress and we have a cyclic dependency. - (let ((module (gethash truename *module-map*))) - (cond ((null module)) - ((typep (module-state module) 'file-location) - (error "Module ~A already being imported at ~A" - pathname (module-state module))) - (module - (return-from read-module module)))) - - ;; Make a new module. Be careful to remove the module from the map if we - ;; didn't succeed in constructing it. - (define-module (pathname :location location :truename truename) - (let ((*readtable* (copy-readtable))) - (with-open-file (f-stream pathname :direction :input) - (let* ((pai-stream (make-instance 'position-aware-input-stream - :stream f-stream - :file pathname)) - (lexer (make-instance 'sod-lexer :stream pai-stream))) - (with-default-error-location (lexer) - (next-char lexer) - (next-token lexer) - (parse-module lexer))))))) - -;;;-------------------------------------------------------------------------- -;;; Module parsing protocol. - -(defgeneric parse-module-declaration (tag lexer pset) - (:method (tag lexer pset) - (error "Unexpected module declaration ~(~A~)" tag)) - (:method :before (tag lexer pset) - (next-token lexer))) - -(defun parse-module (lexer) - "Main dispatching for module parser. - - Calls PARSE-MODULE-DECLARATION for the identifiable declarations." - - (loop - (restart-case - (case (token-type lexer) - (:eof (return)) - (#\; (next-token lexer)) - (t (let ((pset (parse-property-set lexer))) - (case (token-type lexer) - (:id (let ((tag (intern (frob-case (token-value lexer)) - :keyword))) - (parse-module-declaration tag lexer pset) - (check-unused-properties pset))) - (t (error "Unexpected token ~A: ignoring" - (format-token lexer))))))) - (continue () - :report "Ignore the error and continue parsing." - nil)))) - -(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset) - "module-decl ::= `typename' id-list `;'" - (loop (let ((name (require-token lexer :id))) - (unless name (return)) - (if (gethash name *type-map*) - (cerror* "Type `~A' already defined" name) - (add-to-module *module* (make-instance 'type-item :name name))) - (unless (require-token lexer #\, :errorp nil) (return)))) - (require-token lexer #\;)) - -;;;-------------------------------------------------------------------------- -;;; Fragments. - -(defmethod parse-module-declaration ((tag (eql :code)) lexer pset) - "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}' - constraint ::= id*" - (labels ((parse-constraint () - (let ((list nil)) - (loop (let ((id (require-token lexer :id - :errorp (null list)))) - (unless id (return)) - (push id list))) - (nreverse list))) - (parse-constraints () - (let ((list nil)) - (when (require-token lexer #\[ :errorp nil) - (loop (let ((constraint (parse-constraint))) - (push constraint list) - (unless (require-token lexer #\, :errorp nil) - (return)))) - (require-token lexer #\])) - (nreverse list))) - (keywordify (id) - (and id (intern (substitute #\- #\_ (frob-case id)) :keyword)))) - (let* ((reason (prog1 (keywordify (require-token lexer :id)) - (require-token lexer #\:))) - (name (keywordify (require-token lexer :id))) - (constraints (parse-constraints))) - (when (require-token lexer #\{ :consumep nil) - (let ((frag (scan-c-fragment lexer '(#\})))) - (next-token lexer) - (require-token lexer #\}) - (add-to-module *module* - (make-instance 'code-fragment-item - :name name - :reason reason - :constraints constraints - :fragment frag))))))) - -;;;-------------------------------------------------------------------------- -;;; File searching. - - -(defmethod parse-module-declaration ((tag (eql :import)) lexer pset) - "module-decl ::= `import' string `;'" - (let ((name (require-token lexer :string))) - (when name - (find-file lexer - (merge-pathnames name - (make-pathname :type "SOD" :case :common)) - "module" - (lambda (path true) - (handler-case - (let ((module (read-module path :truename true))) - (when module - (module-import module) - (pushnew module (module-dependencies *module*)))) - (file-error (error) - (cerror* "Error reading module ~S: ~A" - path error))))) - (require-token lexer #\;)))) - -(defmethod parse-module-declaration ((tag (eql :load)) lexer pset) - "module-decl ::= `load' string `;'" - (let ((name (require-token lexer :string))) - (when name - (find-file lexer - (merge-pathnames name - (make-pathname :type "LISP" :case :common)) - "Lisp file" - (lambda (path true) - (handler-case (load true :verbose nil :print nil) - (error (error) - (cerror* "Error loading Lisp file ~S: ~A" - path error))))) - (require-token lexer #\;)))) - -;;;-------------------------------------------------------------------------- -;;; Lisp escapes. - -(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset) - "module-decl ::= `lisp' s-expression `;'" - (let ((form (with-lexer-stream (stream lexer) (read stream t)))) - (eval form)) - (next-token lexer) - (require-token lexer #\;)) - -;;;-------------------------------------------------------------------------- -;;; Class declarations. - -(defmethod parse-module-declaration ((tag (eql :class)) lexer pset) - "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'" - (let* ((location (file-location lexer)) - (name (let ((name (require-token lexer :id))) - (make-class-type name location) - (when (require-token lexer #\; :errorp nil) - (return-from parse-module-declaration)) - name)) - (supers (when (require-token lexer #\: :errorp nil) - (let ((list nil)) - (loop (let ((id (require-token lexer :id))) - (unless id (return)) - (push id list) - (unless (require-token lexer #\, :errorp nil) - (return)))) - (nreverse list)))) - (class (make-sod-class name (mapcar #'find-sod-class supers) - pset location)) - (nick (sod-class-nickname class))) - (require-token lexer #\{) - - (labels ((parse-item () - "Try to work out what kind of item this is. Messy." - (let* ((pset (parse-property-set lexer)) - (location (file-location lexer))) - (cond ((declaration-specifier-p lexer) - (let ((declspec (parse-c-type lexer))) - (multiple-value-bind (type name) - (parse-c-declarator lexer declspec :dottedp t) - (cond ((null type) - nil) - ((consp name) - (parse-method type (car name) (cdr name) - pset location)) - ((typep type 'c-function-type) - (parse-message type name pset location)) - (t - (parse-slots declspec type name - pset location)))))) - ((not (eq (token-type lexer) :id)) - (cerror* "Expected ; found ~A (skipped)" - (format-token lexer)) - (next-token lexer)) - ((string= (token-value lexer) "class") - (next-token lexer) - (parse-initializers #'make-sod-class-initializer - pset location)) - (t - (parse-initializers #'make-sod-instance-initializer - pset location))))) - - (parse-method (type nick name pset location) - "class-item ::= declspec+ dotted-declarator -!- method-body - - method-body ::= `{' c-fragment `}' | `extern' `;' - - The dotted-declarator must describe a function type." - (let ((body (cond ((eq (token-type lexer) #\{) - (prog1 (scan-c-fragment lexer '(#\})) - (next-token lexer) - (require-token lexer #\}))) - ((and (eq (token-type lexer) :id) - (string= (token-value lexer) - "extern")) - (next-token lexer) - (require-token lexer #\;) - nil) - (t - (cerror* "Expected ; ~ - found ~A" - (format-token lexer)))))) - (make-sod-method class nick name type body pset location))) - - (parse-message (type name pset location) - "class-item ::= declspec+ declarator -!- (method-body | `;') - - The declarator must describe a function type." - (make-sod-message class name type pset location) - (unless (require-token lexer #\; :errorp nil) - (parse-method type nick name nil location))) - - (parse-initializer-body () - "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment" - (let ((char (lexer-char lexer))) - (loop - (when (or (null char) (not (whitespace-char-p char))) - (return)) - (setf char (next-char lexer))) - (cond ((eql char #\{) - (next-char lexer) - (let ((frag (scan-c-fragment lexer '(#\})))) - (next-token lexer) - (require-token lexer #\}) - (values :compound frag))) - (t - (let ((frag (scan-c-fragment lexer '(#\, #\;)))) - (next-token lexer) - (values :simple frag)))))) - - (parse-slots (declspec type name pset location) - "class-item ::= - declspec+ init-declarator [`,' init-declarator-list] `;' - - init-declarator ::= declarator -!- [initializer]" - (loop - (make-sod-slot class name type pset location) - (when (eql (token-type lexer) #\=) - (multiple-value-bind (kind form) (parse-initializer-body) - (make-sod-instance-initializer class nick name - kind form nil - location))) - (unless (require-token lexer #\, :errorp nil) - (return)) - (setf (values type name) - (parse-c-declarator lexer declspec) - location (file-location lexer))) - (require-token lexer #\;)) - - (parse-initializers (constructor pset location) - "class-item ::= [`class'] -!- slot-initializer-list `;' - - slot-initializer ::= id `.' id initializer" - (loop - (let ((nick (prog1 (require-token lexer :id) - (require-token lexer #\.))) - (name (require-token lexer :id))) - (require-token lexer #\=) - (multiple-value-bind (kind form) - (parse-initializer-body) - (funcall constructor class nick name kind form - pset location))) - (unless (require-token lexer #\, :errorp nil) - (return)) - (setf location (file-location lexer))) - (require-token lexer #\;))) - - (loop - (when (require-token lexer #\} :errorp nil) - (return)) - (parse-item))) - - (finalize-sod-class class) - (add-to-module *module* class))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/output.lisp b/pre-reorg/output.lisp deleted file mode 100644 index dd8bc04..0000000 --- a/pre-reorg/output.lisp +++ /dev/null @@ -1,63 +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.")) - -;;;-------------------------------------------------------------------------- -;;; 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/pre-reorg/parse-c-types.lisp b/pre-reorg/parse-c-types.lisp deleted file mode 100644 index 63e8b9b..0000000 --- a/pre-reorg/parse-c-types.lisp +++ /dev/null @@ -1,534 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Parser for C types -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Declaration specifiers. -;;; -;;; This is a little messy. The C rules, which we're largely following, -;;; allow declaration specifiers to be written in any oreder, and allows an -;;; arbitrary number of the things. This is mainly an exercise in -;;; book-keeping, but we make an effort to categorize the various kinds of -;;; specifiers rather better than the C standard. -;;; -;;; We consider four kinds of declaration specifiers: -;;; -;;; * Type qualifiers: `const', `restrict', and `volatile'. -;;; * Sign specifiers: `signed' and `unsigned'. -;;; * Size specifiers: `short' and `long'. -;;; * Type specifiers: `void', `char', `int', `float', and `double', -;;; -;;; The C standard acknowledges the category of type qualifiers (6.7.3), but -;;; groups the other three kinds together and calls them all `type -;;; specifiers' (6.7.2). - -;; Let's not repeat ourselves. -(macrolet ((define-declaration-specifiers (&rest defs) - (let ((mappings nil) - (deftypes nil) - (hashvar (gensym "HASH")) - (keyvar (gensym "KEY")) - (valvar (gensym "VAL"))) - (dolist (def defs) - (destructuring-bind (kind &rest clauses) def - (let ((maps (mapcar (lambda (clause) - (if (consp clause) - clause - (cons (string-downcase clause) - clause))) - clauses))) - (push `(deftype ,(symbolicate 'decl- kind) () - '(member ,@(mapcar #'cdr maps))) - deftypes) - (setf mappings (nconc (remove-if-not #'car maps) - mappings))))) - `(progn - ,@(nreverse deftypes) - (defparameter *declspec-map* - (let ((,hashvar (make-hash-table :test #'equal))) - (mapc (lambda (,keyvar ,valvar) - (setf (gethash ,keyvar ,hashvar) ,valvar)) - ',(mapcar #'car mappings) - ',(mapcar #'cdr mappings)) - ,hashvar)))))) - (define-declaration-specifiers - (type :char :int :float :double :void) - (size :short :long (nil . :long-long)) - (sign :signed :unsigned) - (qualifier :const :restrict :volatile) - (tagged :enum :struct :union))) - -(defstruct (declspec - (:predicate declspecp)) - "Represents a declaration specifier being built." - (qualifiers nil :type list) - (sign nil :type (or decl-sign null)) - (size nil :type (or decl-size null)) - (type nil :type (or decl-type c-type null))) - -(defun check-declspec (spec) - "Check that the declaration specifiers in SPEC are a valid combination. - - This is surprisingly hairy. - - It could be even worse: at least validity is monotonic. Consider an - alternate language where `double' is a size specifier like `long' rather - than being a primary type specifier like `float' (so you'd be able to say - things like `long double float'). Then `long float' would be invalid, but - `long float double' would be OK. We'd therefore need an additional - argument to know whether we were preparing a final set of specifiers (in - which case we'd have to reject `long float') or whether this is an - intermediate step (in which case we'd have to tentatively allow it in the - hope that the user added the necessary `double' later)." - - (let ((sign (declspec-sign spec)) - (size (declspec-size spec)) - (type (declspec-type spec))) - - (and (loop for (good-type good-signs good-sizes) in - - ;; The entries in this table have the form (GOOD-TYPE - ;; GOOD-SIGNS GOOD-SIZES). The GOOD-TYPE is either a keyword - ;; or T (matches anything); the GOOD-SIZES and GOOD-SIGNS are - ;; lists. The SPEC must match at least one entry, as follows: - ;; the type must be NIL or match GOOD-TYPE; and the size and - ;; sign must match one of the elements of the corresponding - ;; GOOD list. - '((:int (nil :signed :unsigned) (nil :short :long :long-long)) - (:char (nil :signed :unsigned) (nil)) - (:double (nil) (nil :long)) - (t (nil) (nil))) - - thereis (and (or (eq type nil) - (eq good-type t) - (eq type good-type)) - (member sign good-signs) - (member size good-sizes))) - spec))) - -(defun update-declspec-qualifiers (spec qual) - "Update the qualifiers in SPEC by adding QUAL. - - The new declspec is returned if it's valid; otherwise NIL. SPEC is not - modified." - - (let ((new (copy-declspec spec))) - (pushnew qual (declspec-qualifiers new)) - (check-declspec new))) - -(defun update-declspec-sign (spec sign) - "Update the signedness in SPEC to be SIGN. - - The new declspec is returned if it's valid; otherwise NIL. SPEC is not - modified." - - (and (null (declspec-sign spec)) - (let ((new (copy-declspec spec))) - (setf (declspec-sign new) sign) - (check-declspec new)))) - -(defun update-declspec-size (spec size) - "Update the size in SPEC according to SIZE. - - The new declspec is returned if it's valid; otherwise NIL. (This is a - little subtle because :LONG in particular can modify an existing size - entry.) SPEC is not modified." - - (let ((new-size (case (declspec-size spec) - ((nil) size) - (:long (if (eq size :long) :long-long nil))))) - (and new-size - (let ((new (copy-declspec spec))) - (setf (declspec-size new) new-size) - (check-declspec new))))) - -(defun update-declspec-type (spec type) - "Update the type in SPEC to be TYPE. - - The new declspec is returned if it's valid; otherwise NIL. SPEC is not - modified." - - (and (null (declspec-type spec)) - (let ((new (copy-declspec spec))) - (setf (declspec-type new) type) - (check-declspec new)))) - -(defun canonify-declspec (spec) - "Transform the declaration specifiers SPEC into a canonical form. - - The idea is that, however grim the SPEC, we can turn it into something - vaguely idiomatic, and pick precisely one of the possible synonyms. - - The rules are that we suppress `signed' when it's redundant, and suppress - `int' if a size or signedness specifier is present. (Note that `signed - char' is not the same as `char', so stripping `signed' is only correct - when the type is `int'.) - - The qualifiers are sorted and uniquified here; the relative ordering of - the sign/size/type specifiers will be determined by DECLSPEC-KEYWORDS." - - (let ((quals (declspec-qualifiers spec)) - (sign (declspec-sign spec)) - (size (declspec-size spec)) - (type (declspec-type spec))) - (cond ((eq type :int) - (when (eq sign :signed) - (setf (declspec-sign spec) nil)) - (when (or sign size) - (setf (declspec-type spec) nil))) - ((not (or sign size type)) - (setf (declspec-type spec) :int))) - (setf (declspec-qualifiers spec) - (delete-duplicates (sort (copy-list quals) #'string<))) - spec)) - -(defun declspec-keywords (spec &optional qualsp) - "Return a list of strings for the declaration specifiers SPEC. - - If QUALSP then return the type qualifiers as well." - - (let ((quals (declspec-qualifiers spec)) - (sign (declspec-sign spec)) - (size (declspec-size spec)) - (type (declspec-type spec))) - (nconc (and qualsp (mapcar #'string-downcase quals)) - (and sign (list (string-downcase sign))) - (case size - ((nil) nil) - (:long-long (list "long long")) - (t (list (string-downcase size)))) - (etypecase type - (null nil) - (keyword (list (string-downcase type))) - (simple-c-type (list (c-type-name type))) - (tagged-c-type (list (string-downcase (c-tagged-type-kind type)) - (c-type-tag type))))))) - -(defun declspec-c-type (spec) - "Return a C-TYPE object corresponding to SPEC." - (canonify-declspec spec) - (let* ((type (declspec-type spec)) - (base (etypecase type - (symbol (make-simple-type - (format nil "~{~A~^ ~}" - (declspec-keywords spec)))) - (c-type type)))) - (qualify-type base (declspec-qualifiers spec)))) - -(defun declaration-specifier-p (lexer) - "Answer whether the current token might be a declaration specifier." - (and (eq (token-type lexer) :id) - (let ((id (token-value lexer))) - (or (gethash id *declspec-map*) - (gethash id *type-map*))))) - -(defun parse-c-type (lexer) - "Parse declaration specifiers from LEXER and return a C-TYPE." - - (let ((spec (make-declspec)) - (found-any nil) - tok) - (flet ((token (&optional (ty (next-token lexer))) - (setf tok - (or (and (eq ty :id) - (gethash (token-value lexer) *declspec-map*)) - ty))) - (update (func value) - (let ((new (funcall func spec value))) - (cond (new (setf spec new)) - (t (cerror* "Invalid declaration specifier ~(~A~) ~ - following `~{~A~^ ~}' (ignored)" - (format-token tok (token-value lexer)) - (declspec-keywords spec t)) - nil))))) - (token (token-type lexer)) - (loop - (typecase tok - (decl-qualifier (update #'update-declspec-qualifiers tok)) - (decl-sign (when (update #'update-declspec-sign tok) - (setf found-any t))) - (decl-size (when (update #'update-declspec-size tok) - (setf found-any t))) - (decl-type (when (update #'update-declspec-type tok) - (setf found-any t))) - (decl-tagged (let ((class (ecase tok - (:enum 'c-enum-type) - (:struct 'c-struct-type) - (:union 'c-union-type)))) - (let ((tag (require-token lexer :id))) - (when tag - (update #'update-declspec-type - (make-instance class :tag tag)))))) - ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*))) - (when (or found-any (not ty)) - (return)) - (when (update #'update-declspec-type ty) - (setf found-any t)))) - (t (return))) - (token)) - (unless found-any - (cerror* "Missing type name (guessing at `int')")) - (declspec-c-type spec)))) - -;;;-------------------------------------------------------------------------- -;;; Parsing declarators. -;;; -;;; This is a whole different ball game. The syntax is simple enough, but -;;; the semantics is inside-out in a particularly unpleasant way. -;;; -;;; The basic idea is that declarator operators closer to the identifier (or -;;; where the identifier would be) should be applied last (with postfix -;;; operators being considered `closer' than prefix). -;;; -;;; One might thing that we can process prefix operators immediately. For -;;; outer prefix operators, this is indeed correct, but in `int (*id)[]', for -;;; example, we must wait to process the array before applying the pointer. -;;; -;;; We can translate each declarator operator into a function which, given a -;;; type, returns the appropriate derived type. If we can arrange these -;;; functions in the right order during the parse, we have only to compose -;;; them together and apply them to the base type in order to finish the job. -;;; -;;; Consider the following skeletal declarator, with <> as a parenthesized -;;; subdeclarator within. -;;; -;;; * * <> [] [] ---> a b d c z -;;; a b z c d -;;; -;;; The algorithm is therefore as follows. We first read the prefix -;;; operators, translate them into closures, and push them onto a list. Each -;;; parenthesized subdeclarator gets its own list, and we push those into a -;;; stack each time we encounter a `('. We then parse the middle bit, which -;;; is a little messy (see the comment there), and start an empty final list -;;; of operators. Finally, we scan postfix operators; these get pushed onto -;;; the front of the operator list as we find them. Each time we find a `)', -;;; we reverse the current prefix-operators list, and attach it to the front -;;; of the operator list, and pop a new prefix list off the stack: at this -;;; point, the operator list reflects the type of the subdeclarator we've -;;; just finished. Eventually we should reach the end with an empty stack -;;; and a prefix list, which again we reverse and attach to the front of the -;;; list. -;;; -;;; Finally, we apply the operator functions in order. - -(defun parse-c-declarator (lexer type &key abstractp dottedp) - "Parse a declarator. Return two values: the complete type, and the name. - - Parse a declarator from LEXER. The base type is given by TYPE. If - ABSTRACTP is NIL, then require a name; if T then forbid a name; if :MAYBE - then don't care either way. If no name is given, return NIL. - - If DOTTEDP then the name may be a dotted item name `NICK.NAME', returned - as a cons (NICK . NAME)." - - (let ((ops nil) - (item nil) - (stack nil) - (prefix nil)) - - ;; Scan prefix operators. - (loop - (case (token-type lexer) - - ;; Star: a pointer type. - (#\* (let ((quals nil) - (tok (next-token lexer))) - - ;; Gather following qualifiers. - (loop - (case tok - ((:const :volatile :restrict) - (pushnew tok quals)) - (t - (return)))) - - ;; And stash the item. - (setf quals (sort quals #'string<)) - (push (lambda (ty) - (make-instance 'c-pointer-type - :qualifiers quals - :subtype ty)) - prefix))) - - ;; An open-paren: start a new level of nesting. Maybe. There's an - ;; unpleasant ambiguity (DR9, DR249) between a parenthesized - ;; subdeclarator and a postfix function argument list following an - ;; omitted name. If the next thing looks like it might appear as a - ;; declaration specifier then assume it is one, push the paren back, - ;; and leave; do the same if the parens are empty, because that's not - ;; allowed otherwise. - (#\( (let ((tok (next-token lexer))) - (when (and abstractp - (or (eql tok #\)) - (declaration-specifier-p lexer))) - (pushback-token lexer #\() - (return)) - (push prefix stack) - (setf prefix nil))) - - ;; Anything else: we're done. - (t (return)))) - - ;; We're now at the middle of the declarator. If there's an item name - ;; here, we want to snarf it. - (when (and (not (eq abstractp t)) - (eq (token-type lexer) :id)) - (let ((name (token-value lexer))) - (next-token lexer) - (cond ((and dottedp (require-token lexer #\. :errorp nil)) - (let ((sub (require-token lexer :id :default (gensym)))) - (setf item (cons name sub)))) - (t - (setf item name))))) - - ;; If we were meant to have a name, but weren't given one, make one up. - (when (and (null item) - (not abstractp)) - (cerror* "Missing name; inventing one") - (setf item (gensym))) - - ;; Finally scan the postfix operators. - (loop - (case (token-type lexer) - - ;; Open-bracket: an array. The dimensions are probably some - ;; gods-awful C expressions which we'll just tuck away rather than - ;; thinking about too carefully. Our representation of C types is - ;; capable of thinking about multidimensional arrays, so we slurp up - ;; as many dimensions as we can. - (#\[ (let ((dims nil)) - (loop - (let* ((frag (scan-c-fragment lexer '(#\]))) - (dim (c-fragment-text frag))) - (push (if (plusp (length dim)) dim nil) dims)) - (next-token lexer) - (unless (eq (next-token lexer) #\[) - (return))) - (setf dims (nreverse dims)) - (push (lambda (ty) - (when (typep ty 'c-function-type) - (error "Array element type cannot be ~ - a function type")) - (make-instance 'c-array-type - :dimensions dims - :subtype ty)) - ops))) - - ;; Open-paren: a function with arguments. - (#\( (let ((args nil)) - (unless (eql (next-token lexer) #\)) - (loop - - ;; Grab an argument and stash it. - (cond ((eql (token-type lexer) :ellipsis) - (push :ellipsis args)) - (t - (let ((base-type (parse-c-type lexer))) - (multiple-value-bind (type name) - (parse-c-declarator lexer base-type - :abstractp :maybe) - (push (make-argument name type) args))))) - - ;; Decide whether to take another one. - (case (token-type lexer) - (#\) (return)) - (#\, (next-token lexer)) - (t (cerror* "Missing `)' inserted before ~A" - (format-token lexer)) - (return))))) - (next-token lexer) - - ;; Catch: if the only thing in the list is `void' (with no - ;; identifier) then kill the whole thing. - (setf args - (if (and args - (null (cdr args)) - (eq (argument-type (car args)) (c-type void)) - (not (argument-name (car args)))) - nil - (nreverse args))) - - ;; Stash the operator. - (push (lambda (ty) - (when (typep ty '(or c-function-type c-array-type)) - (error "Function return type cannot be ~ - a function or array type")) - (make-instance 'c-function-type - :arguments args - :subtype ty)) - ops))) - - ;; Close-paren: exit a level of nesting. Prepend the current prefix - ;; list and pop a new level. If there isn't one, this isn't our - ;; paren, so we're done. - (#\) (unless stack - (return)) - (setf ops (nreconc prefix ops) - prefix (pop stack)) - (next-token lexer)) - - ;; Anything else means we've finished. - (t (return)))) - - ;; If we still have operators stacked then something went wrong. - (setf ops (nreconc prefix ops)) - (when stack - (cerror* "Missing `)'(s) inserted before ~A" - (format-token lexer)) - (dolist (prefix stack) - (setf ops (nreconc prefix ops)))) - - ;; Finally, grind through the list of operations. - (do ((ops ops (cdr ops)) - (type type (funcall (car ops) type))) - ((endp ops) (values type item))))) - -;;;-------------------------------------------------------------------------- -;;; Testing cruft. - -#+test -(with-input-from-string (in " -// int stat(struct stat *st) -// void foo(void) - int vsnprintf(size_t n, char *buf, va_list ap) -// size_t size_t; -// int (*signal(int sig, int (*handler)(int s)))(int t) -") - (let* ((stream (make-instance 'position-aware-input-stream - :file "" - :stream in)) - (lex (make-instance 'sod-lexer :stream stream))) - (next-char lex) - (next-token lex) - (let ((ty (parse-c-type lex))) - (multiple-value-bind (type name) (parse-c-declarator lex ty) - (list ty - (list type name) - (with-output-to-string (out) - (pprint-c-type type out name) - (format-token lex))))))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/posn-stream.lisp b/pre-reorg/posn-stream.lisp deleted file mode 100644 index ffc06d6..0000000 --- a/pre-reorg/posn-stream.lisp +++ /dev/null @@ -1,437 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Position-aware stream type -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Compatibility hacking. - -;; ECL doesn't clobber the standard CLOSE and STREAM-ELEMENT-TYPE functions -;; with the Gray generic versions. -#-ecl -(eval-when (:compile-toplevel :load-toplevel :execute) - (setf (fdefinition 'stream-close) #'cl:close - (fdefinition 'stream-elt-type) #'cl:stream-element-type)) - -;;;-------------------------------------------------------------------------- -;;; File names. - -(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 TRUENAMEd, - ;; which isn't ideal. We'll hack around this later. - (:method ((stream stream)) - nil) - (:method ((stream file-stream)) - (pathname stream))) - -;;;-------------------------------------------------------------------------- -;;; Locations. - -(defclass file-location () - ((pathname :initarg :pathname :type (or pathname null) - :accessor file-location-pathname) - (line :initarg :line :type (or fixnum null) :accessor file-location-line) - (column :initarg :column :type (or fixnum null) - :accessor file-location-column)) - (:documentation - "A simple structure containing file location information. - - Construct using MAKE-FILE-LOCATION; the main useful function is - ERROR-FILE-LOCATION.")) - -(defun make-file-location (pathname line column) - "Constructor for FILE-LOCATION objects. - - Returns a FILE-LOCATION object with the given contents." - (make-instance 'file-location - :pathname (and pathname (pathname pathname)) - :line line :column column)) - -(defgeneric file-location (thing) - (:documentation - "Convert THING into a FILE-LOCATION, if possible.") - (:method ((thing null)) (make-file-location nil nil nil)) - (:method ((thing file-location)) thing) - (:method ((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) - (with-slots (pathname line column) object - (format stream "~:[~;~:*~A~]~@[:~D~]~@[:~D~]" - pathname line column)))) - -(defmethod make-load-form ((object file-location) &optional environment) - (make-load-form-saving-slots object :environment environment)) - -;;;-------------------------------------------------------------------------- -;;; 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 stream-close ((stream proxy-stream) &key abort) - (with-slots (ustream) stream - (close ustream :abort abort))) - -(defmethod stream-elt-type ((stream proxy-stream)) - (with-slots (ustream) stream - (stream-elt-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. - -(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. - -(declaim (inline update-position)) -(defun update-position (char line column) - "Updates LINE and COLUMN according to the character CHAR. - - Returns the new LINE and COLUMN numbers resulting from having read CHAR." - (case char - ((#\newline #\vt #\page) - (values (1+ line) 0)) - ((#\tab) - (values line (logandc2 (+ column 7) 7))) - (t - (values line (1+ column))))) - -(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." - - (let ((streamvar (gensym "STREAM")) - (linevar (gensym "LINE")) - (colvar (gensym "COLUMN")) - (charvar (gensym "CHAR"))) - `(let* ((,streamvar ,stream) - (,linevar (position-aware-stream-line ,streamvar)) - (,colvar (position-aware-stream-column ,streamvar))) - (macrolet ((update (,charvar) - ;; This gets a little hairy. Hold tight. - `(multiple-value-setq (,',linevar ,',colvar) - (update-position ,,charvar ,',linevar ,',colvar)))) - (unwind-protect - (progn ,@body) - (setf (position-aware-stream-line ,streamvar) ,linevar - (position-aware-stream-column ,streamvar) ,colvar)))))) - -;; 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) - - ;; Tweak the position so that the next time the character is read, it will - ;; end up here. 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. - (with-slots (line column) stream - (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) - (decf line) - (setf column 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. - (#\tab - (decf column)) - - ;; Anything else: just decrement the column and cross fingers. - (t - (decf column)))) - - ;; And actually do it. (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.) - (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. - -(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/pre-reorg/pset.lisp b/pre-reorg/pset.lisp deleted file mode 100644 index 20f0ff9..0000000 --- a/pre-reorg/pset.lisp +++ /dev/null @@ -1,272 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Collections of properties -;;; -;;; (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) - -;;;-------------------------------------------------------------------------- -;;; Expression parser. - -(defun parse-expression (lexer) - "Parse an expression from the LEXER. - - The return values are the expression's VALUE and TYPE; currently the types - are :ID, :INTEGER, :STRING, and :CHAR. If an error prevented a sane value - being produced, the TYPE :INVALID is returned. - - Expression syntax is rather limited at the moment: - - expression : term | expression `+' term | expression `-' term - term : factor | term `*' factor | term `/' factor - factor : primary | `+' factor | `-' factor - primary : integer | identifier | string - | `(' expression `)' - | `?' lisp-expression - - Identifiers are just standalone things. They don't name values. The - operators only work on integer values at the moment. (Confusingly, you - can manufacture rational numbers using the division operator, but they - still get called integers.)" - - (let ((valstack nil) - (opstack nil)) - - ;; The following is a simple operator-precedence parser: the - ;; recursive-descent parser I wrote the first time was about twice the - ;; size and harder to extend. - ;; - ;; The parser flips between two states, OPERAND and OPERATOR. It starts - ;; out in OPERAND state, and tries to parse a sequence of prefix - ;; operators followed by a primary expression. Once it's found one, it - ;; pushes the operand onto the value stack and flips to OPERATOR state; - ;; if it fails, it reports a syntax error and exits. The OPERAND state - ;; tries to read a sequence of postfix operators followed by an infix - ;; operator; if it fails, it assumes that it hit the stuff following the - ;; expression and stops. - ;; - ;; Each operator is pushed onto a stack consisting of lists of the form - ;; (FUNC PREC TY*). The PREC is a precedence -- higher numbers mean - ;; tighter binding. The TY* are operand types; operands are popped off - ;; the operand stack, checked against the requested types, and passed to - ;; the FUNC, which returns a new operand to be pushed in their place. - ;; - ;; Usually, when a binary operator is pushed, existing stacked operators - ;; with higher precedence are applied. Whether operators with /equal/ - ;; precedence are also applied depends on the associativity of the - ;; operator: apply equal precedence operators for left-associative - ;; operators, don't apply for right-associative. When we reach the end - ;; of the expression, all the remaining operators on the stack are - ;; applied. - ;; - ;; Parenthesized subexpressions are implemented using a hack: when we - ;; find an open paren in operand position, a fake operator is pushed with - ;; an artificially low precedece, which protects the operators beneath - ;; from premature application. The fake operator's function reports an - ;; error -- this will be triggered only if we reach the end of the - ;; expression before a matching close-paren, because the close-paren - ;; handler will pop the fake operator before it does any harm. - - (restart-case - (labels ((apply-op (op) - ;; Apply the single operator list OP to the values on the - ;; value stack. - (let ((func (pop op)) - (args nil)) - (dolist (ty (reverse (cdr op))) - (let ((arg (pop valstack))) - (cond ((eq (car arg) :invalid) - (setf func nil)) - ((eq (car arg) ty) - (push (cdr arg) args)) - (t - (cerror* "Type mismatch: wanted ~A; found ~A" - ty (car arg)) - (setf func nil))))) - (if func - (multiple-value-bind (type value) (apply func args) - (push (cons type value) valstack)) - (push '(:invalid . nil) valstack)))) - - (apply-all (prec) - ;; Apply all operators with precedence PREC or higher. - (loop - (when (or (null opstack) (< (cadar opstack) prec)) - (return)) - (apply-op (pop opstack))))) - - (tagbody - - operand - ;; Operand state. Push prefix operators, and try to read a - ;; primary operand. - (case (token-type lexer) - - ;; Aha. A primary. Push it onto the stack, and see if - ;; there's an infix operator. - ((:integer :id :string :char) - (push (cons (token-type lexer) - (token-value lexer)) - valstack) - (go operator)) - - ;; Look for a Lisp S-expression. - (#\? - (with-lexer-stream (stream lexer) - (let ((value (eval (read stream t)))) - (push (cons (property-type value) value) valstack))) - (go operator)) - - ;; Arithmetic unary operators. Push an operator for `+' for - ;; the sake of type-checking. - (#\+ - (push (list (lambda (x) (values :integer x)) - 10 :integer) - opstack)) - (#\- - (push (list (lambda (x) (values :integer (- x))) - 10 :integer) - opstack)) - - ;; The open-paren hack. Push a magic marker which will - ;; trigger an error if we hit the end of the expression. - ;; Inside the paren, we're still looking for an operand. - (#\( - (push (list (lambda () - (error "Expected `)' but found ~A" - (format-token lexer))) - -1) - opstack)) - - ;; Failed to find anything. Report an error and give up. - (t - (error "Expected expression but found ~A" - (format-token lexer)))) - - ;; Assume prefix operators as the default, so go round for more. - (next-token lexer) - (go operand) - - operator - ;; Operator state. Push postfix operators, and try to read an - ;; infix operator. It turns out that we're always a token - ;; behind here, so catch up. - (next-token lexer) - (case (token-type lexer) - - ;; Binary operators. - (#\+ (apply-all 3) - (push (list (lambda (x y) (values :integer (+ x y))) - 3 :integer :integer) - opstack)) - (#\- (apply-all 3) - (push (list (lambda (x y) (values :integer (- x y))) - 3 :integer :integer) - opstack)) - (#\* (apply-all 5) - (push (list (lambda (x y) (values :integer (* x y))) - 5 :integer :integer) - opstack)) - (#\/ (apply-all 5) - (push (list (lambda (x y) - (if (zerop y) - (progn (cerror* "Division by zero") - (values nil :invalid)) - (values (/ x y) :integer))) - 5 :integer :integer) - opstack)) - - ;; The close-paren hack. Finish off the operators pushed - ;; since the open-paren. If the operator stack is now empty, - ;; this is someone else's paren, so exit. Otherwise pop our - ;; magic marker, and continue looking for an operator. - (#\) (apply-all 0) - (when (null opstack) - (go done)) - (pop opstack) - (go operator)) - - ;; Nothing useful. Must have hit the end, so leave. - (t (go done))) - - ;; Assume we found the binary operator as a default, so snarf a - ;; token and head back. - (next-token lexer) - (go operand) - - done) - - ;; Apply all the pending operators. If there's an unmatched - ;; open paren, this will trigger the error message. - (apply-all -99) - - ;; If everything worked out, we should have exactly one operand - ;; left. This is the one we want. - (assert (and (consp valstack) - (null (cdr valstack)))) - (values (cdar valstack) (caar valstack))) - (continue () - :report "Return an invalid value and continue." - (values nil :invalid))))) - -;;;-------------------------------------------------------------------------- -;;; Property set parsing. - -(defun parse-property (lexer pset) - "Parse a single property from LEXER; add it to PSET." - (let ((name (require-token lexer :id))) - (require-token lexer #\=) - (multiple-value-bind (value type) (parse-expression lexer) - (unless (eq type :invalid) - (add-property pset name value :type type :location lexer))))) - -(defun parse-property-set (lexer) - "Parse a property set from LEXER. - - If there wasn't one to parse, return nil; this isn't considered an error, - and GET-PROPERTY will perfectly happily report defaults for all requested - properties." - - (when (require-token lexer #\[ :errorp nil) - (let ((pset (make-pset))) - (loop - (parse-property lexer pset) - (unless (require-token lexer #\, :errorp nil) - (return))) - (require-token lexer #\]) - pset))) - -;;;-------------------------------------------------------------------------- -;;; Testing cruft. - -#+test -(with-input-from-string (raw "[role = before, integer = 42 * (3 - 1)]") - (let* ((in (make-instance 'position-aware-input-stream :stream raw)) - (lexer (make-instance 'sod-lexer :stream in))) - (next-char lexer) - (next-token lexer) - (multiple-value-call #'values - (parse-property-set lexer) - (token-type lexer)))) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/pre-reorg/sift.lisp b/pre-reorg/sift.lisp deleted file mode 100644 index 7d78774..0000000 --- a/pre-reorg/sift.lisp +++ /dev/null @@ -1,333 +0,0 @@ -;;; 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/pre-reorg/sod.asd b/pre-reorg/sod.asd deleted file mode 100644 index 48dbcaa..0000000 --- a/pre-reorg/sod.asd +++ /dev/null @@ -1,94 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; System definition for SOD -;;; -;;; (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:defpackage #:sod-package - (:use #:common-lisp #:asdf)) - -(cl:in-package #:sod-package) - -;;;-------------------------------------------------------------------------- -;;; 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 Definition 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." - - ;; And now for how to build it. - ;; - ;; The big tables in parser.lisp need to be earlier. CLEAR-THE-DECKS ought - ;; to do more stuff, including calling BOOTSTRAP-CLASSES. Generally, the - ;; code isn't very well organized at the moment. - :components - ((:file "package") - (:file "utilities" :depends-on ("package")) - (:file "tables" :depends-on ("package")) - (:file "c-types" :depends-on ("utilities")) - (:file "codegen" :depends-on ("c-types")) - (:file "posn-stream" :depends-on ("utilities")) - (:file "errors" :depends-on ("posn-stream")) - (:file "lex" :depends-on ("posn-stream" "errors")) - (:file "pset" :depends-on ("lex")) - (:file "parse-c-types" :depends-on ("lex" "c-types" "tables")) - (:file "class-defs" :depends-on ("parse-c-types")) - (:file "cpl" :depends-on ("class-defs")) - (: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" "class-defs" "tables")) - (:file "builtin" :depends-on ("module" "class-layout")) - (:file "output" :depends-on ("module")) - (: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/pre-reorg/tables.lisp b/pre-reorg/tables.lisp deleted file mode 100644 index a639770..0000000 --- a/pre-reorg/tables.lisp +++ /dev/null @@ -1,80 +0,0 @@ -;;; -*-lisp-*- -;;; -;;; Main tables for the 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) - -;;;-------------------------------------------------------------------------- -;;; Main tables. - -(defvar *module-map* (make-hash-table :test #'equal) - "A hash table mapping file truenames (pathnames) to modules. - - This is used to prevent multiple inclusion of a single module, which would - be bad. Usually it maps pathnames to MODULE objects. As a special case, - the truename a module which is being parsed maps to :IN-PROGRESS, which - can be used to detect dependency cycles.") - -(defvar *type-map* (make-hash-table :test #'equal) - "A hash table mapping type names to the C types they describe. - - Since a class is a C type, it gets its own entry in here as a C-CLASS-TYPE - object. This is how we find classes by name: the C-CLASS-TYPE object has - a reference to the underlying SOD-CLASS instance.") - -(defparameter *builtin-module* nil - "Built-in module; populated later.") - -;;;-------------------------------------------------------------------------- -;;; Utilities. - -(defparameter *clear-the-decks-functions* - '(reset-type-and-module-map - reset-builtin-module)) - -(defun reset-type-and-module-map () - "Reset the main hash tables, clearing the translator's state. - - One of the *CLEAR-THE-DECKS-FUNCTIONS*." - - (setf *module-map* (make-hash-table :test #'equal) - *type-map* (make-hash-table :test #'equal))) - -(defun populate-type-map () - "Store some important simple types in the type map." - (dolist (name '("va_list" "size_t" "ptrdiff_t")) - (setf (gethash name *type-map*) - (make-simple-type name)))) - -(defun clear-the-decks () - "Reinitialize the translator's state. - - This is mainly useful when testing the translator from a Lisp REPL." - (dolist (func *clear-the-decks-functions*) - (funcall func))) - -#+test -(clear-the-decks) - -;;;----- That's all, folks -------------------------------------------------- diff --git a/sod.pc.in b/sod.pc.in new file mode 100644 index 0000000..7b7709e --- /dev/null +++ b/sod.pc.in @@ -0,0 +1,10 @@ +prefix=@prefix@ +exec_prefix=@exec_prefix@ +libdir=@libdir@ +includedir=@includedir@ + +Name: sod +Description: Sensible object design, runtime library +Version: @VERSION@ +Libs: -L${libdir} -lsod +Cflags: -I${includedir} diff --git a/src/Makefile.am b/src/Makefile.am index 9773237..7b23dd8 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -25,87 +25,109 @@ include $(top_srcdir)/vars.am -dist_pkglispsrc_DATA = +nobase_dist_pkglispsrc_DATA = $(LISP_SOURCES) +LISP_SOURCES = +SYSDEFS = ###-------------------------------------------------------------------------- ### The source files. -## The system definition file. -dist_pkglispsrc_DATA += sod.asd - ## The package definition file. -dist_pkglispsrc_DATA += package.lisp +LISP_SOURCES += package.lisp ## General utilities. -dist_pkglispsrc_DATA += utilities.lisp +LISP_SOURCES += utilities.lisp ## The parser library. -dist_pkglispsrc_DATA += parser/floc-proto.lisp parser/floc-impl.lisp -dist_pkglispsrc_DATA += parser/streams-proto.lisp parser/streams-impl.lisp -dist_pkglispsrc_DATA += parser/scanner-proto.lisp parser/scanner-impl.lisp -dist_pkglispsrc_DATA += parser/scanner-charbuf-impl.lisp -dist_pkglispsrc_DATA += parser/scanner-token-impl.lisp -dist_pkglispsrc_DATA += parser/parser-proto.lisp parser/parser-impl.lisp -dist_pkglispsrc_DATA += parser/parser-expr-proto.lisp \ +LISP_SOURCES += parser/package.lisp +LISP_SOURCES += parser/floc-proto.lisp parser/floc-impl.lisp +LISP_SOURCES += parser/streams-proto.lisp parser/streams-impl.lisp +LISP_SOURCES += parser/scanner-proto.lisp parser/scanner-impl.lisp +LISP_SOURCES += parser/scanner-charbuf-impl.lisp +LISP_SOURCES += parser/scanner-token-impl.lisp +LISP_SOURCES += parser/parser-proto.lisp parser/parser-impl.lisp +LISP_SOURCES += parser/parser-expr-proto.lisp \ parser/parser-expr-impl.lisp -dist_pkglispsrc_DATA += parser/scanner-context-impl.lisp +LISP_SOURCES += parser/scanner-context-impl.lisp ## Lexical analysis and translator-specific parser utilities. -dist_pkglispsrc_DATA += lexer-proto.lisp lexer-impl.lisp -dist_pkglispsrc_DATA += fragment-parse.lisp +LISP_SOURCES += lexer-proto.lisp lexer-impl.lisp +LISP_SOURCES += fragment-parse.lisp ## C type representation. -dist_pkglispsrc_DATA += c-types-proto.lisp c-types-impl.lisp \ +LISP_SOURCES += c-types-proto.lisp c-types-impl.lisp \ c-types-parse.lisp ## Property sets. -dist_pkglispsrc_DATA += pset-proto.lisp pset-impl.lisp pset-parse.lisp +LISP_SOURCES += pset-proto.lisp pset-impl.lisp pset-parse.lisp ## Code generation. -dist_pkglispsrc_DATA += codegen-proto.lisp codegen-impl.lisp +LISP_SOURCES += codegen-proto.lisp codegen-impl.lisp ## Output machinery. -dist_pkglispsrc_DATA += output-proto.lisp output-impl.lisp +LISP_SOURCES += output-proto.lisp output-impl.lisp ## Modules. -dist_pkglispsrc_DATA += module-proto.lisp module-impl.lisp -dist_pkglispsrc_DATA += module-parse.lisp module-output.lisp -dist_pkglispsrc_DATA += builtin.lisp +LISP_SOURCES += module-proto.lisp module-impl.lisp +LISP_SOURCES += module-parse.lisp module-output.lisp +LISP_SOURCES += builtin.lisp ## Class representation and layout. -dist_pkglispsrc_DATA += classes.lisp c-types-class-impl.lisp -dist_pkglispsrc_DATA += class-utilities.lisp -dist_pkglispsrc_DATA += class-make-proto.lisp class-make-impl.lisp -dist_pkglispsrc_DATA += class-layout-proto.lisp class-layout-impl.lisp -dist_pkglispsrc_DATA += class-finalize-proto.lisp class-finalize-impl.lisp -dist_pkglispsrc_DATA += class-output.lisp +LISP_SOURCES += classes.lisp c-types-class-impl.lisp +LISP_SOURCES += class-utilities.lisp +LISP_SOURCES += class-make-proto.lisp class-make-impl.lisp +LISP_SOURCES += class-layout-proto.lisp class-layout-impl.lisp +LISP_SOURCES += class-finalize-proto.lisp class-finalize-impl.lisp +LISP_SOURCES += class-output.lisp ## Method generation. -dist_pkglispsrc_DATA += method-proto.lisp method-impl.lisp +LISP_SOURCES += method-proto.lisp method-impl.lisp +LISP_SOURCES += method-aggregate.lisp ## User interface. -dist_pkglispsrc_DATA += sod-frontend.asd -dist_pkglispsrc_DATA += frontend.lisp optparse.lisp +LISP_SOURCES += frontend.lisp optparse.lisp + +## Finishing touches. +LISP_SOURCES += final.lisp ###-------------------------------------------------------------------------- ### Constructing an output image. CLEANFILES += *.$(fasl) parser/*.$(fasl) +## Autodetected configuration. +EXTRA_DIST += auto.lisp.in +CLEANFILES += auto.lisp +auto.lisp: auto.lisp.in Makefile + $(SUBST) $(srcdir)/auto.lisp.in >$@.new $(SUBSTITUTIONS) && \ + grep '^[^;]' $@.new >$@.strip && \ + rm -f $@.new && mv $@.strip $@ + +## Building a working-tree system definition. +EXTRA_DIST += sod.asd.in +CLEANFILES += sod.asd +sod.asd: sod.asd.in Makefile + $(SUBST) $(srcdir)/sod.asd.in >$@.new $(SUBSTITUTIONS) && \ + mv $@.new $@ + +EXTRA_DIST += sod-frontend.asd.in +CLEANFILES += sod-frontend.asd +sod-frontend.asd: sod-frontend.asd.in Makefile + $(SUBST) $(srcdir)/sod-frontend.asd.in >$@.new $(SUBSTITUTIONS) && \ + mv $@.new $@ + ## Building the executable image. bin_PROGRAMS += sod sod_SOURCES = -sod: $(dist_pkglispsrc_DATA) - set -ex; true_srcdir=$$(cd $(srcdir); pwd); \ - ASDF_OUTPUT_TRANSLATIONS=$$true_srcdir:$(abs_builddir): \ - $(CL_LAUNCH) -o sod -d ! -l $(LISPSYS) +I -S $$true_srcdir/: \ +sod: $(LISP_SOURCES) sod.asd sod-frontend.asd auto.lisp + $(V_DUMP)$(CL_LAUNCH) -o sod -d ! -l $(LISPSYS) +I \ -s sod-frontend -r sod-frontend:main ###-------------------------------------------------------------------------- ### Unit testing. ## The system definition. -EXTRA_DIST += sod-test.asd +EXTRA_DIST += sod-test.asd.in ## Basic utilities. EXTRA_DIST += test-base.lisp @@ -119,12 +141,20 @@ EXTRA_DIST += c-types-test.lisp EXTRA_DIST += codegen-test.lisp EXTRA_DIST += lexer-test.lisp +## The system definition. +EXTRA_DIST += sod-test.asd.in +CLEANFILES += sod-test.asd +sod-test.asd: sod-test.asd.in Makefile + $(SUBST) $(srcdir)/sod-test.asd.in >$@.new $(SUBSTITUTIONS) && \ + mv $@.new $@ + ## Running the Lisp tests. -check-local: - set -ex; true_srcdir=$$(cd $(srcdir); pwd); \ - ASDF_OUTPUT_TRANSLATIONS=$$true_srcdir:$(abs_builddir): \ - $(CL_LAUNCH) -l $(LISPSYS) +I -S $$true_srcdir/: \ - -i '(asdf:test-system "sod")' +check-local: sod sod-test.asd + $(V_TEST)$(CL_LAUNCH) -l $(LISPSYS) -s sod-test +I \ + -i '(handler-case (asdf:test-system "sod") ;\ + (error (cond) ;\ + (format *error-output* "ERR: ~A~%" cond) ;\ + (cl-launch:quit 1)))' ###-------------------------------------------------------------------------- ### Installation. @@ -136,9 +166,9 @@ check-local: ## don't have spaces in them; but that's generally a bad idea in Makefiles ## anyway. install-data-local: - $(MKDIR_P) $(DESTDIR)$(lispsysdir) + $(MKDIR_P) $(DESTDIR)$(lispsysdir) $(DESTDIR)$(pkglispsrcdir) @set -e; \ - from=$(lispsysdir) to=$(pkglispsrcdir)/sod.asd; \ + from=$(lispsysdir) to=$(pkglispsrcdir); \ set -- $$(echo $$from | tr "/" " "); fwd=$$*; \ set -- $$(echo $$to | tr "/" " "); twd=$$*; \ while :; do \ @@ -151,8 +181,21 @@ install-data-local: done; \ dots=$$(echo $$fwd | sed 's/[^ ][^ ]*/../g'); \ rel=$$(echo $$dots $$twd | tr " " "/"); \ - echo >&2 "ln -s $$rel $$to"; \ - ln -s $$rel $(DESTDIR)$$from/sod.asd.new; \ - mv $(DESTDIR)$$from/sod.asd.new $(DESTDIR)$$from/sod.asd + for i in sod.asd sod-frontend.asd; do \ + echo >&2 "CREATE $$to/$$i"; \ + sed -e '/#|@-auto-@|#/ { r auto.lisp' -e ' d; }' \ + -e '/#|@-path-@|#/ d' \ + $(srcdir)/$$i.in >$(DESTDIR)$(pkglispsrcdir)/$$i.new; \ + mv $(DESTDIR)$(pkglispsrcdir)/$$i.new \ + $(DESTDIR)$(pkglispsrcdir)/$$i; \ + echo >&2 "LINK $$rel/$$i $$to/$$i"; \ + ln -s $$rel/$$i $(DESTDIR)$$from/$$i.new; \ + mv $(DESTDIR)$$from/$$i.new $(DESTDIR)$$from/$$i; \ + done + +uninstall-local: + for i in sod.asd sod-frontend.asd; do \ + rm -f $(DESTDIR)$(pkglispsrcdir)/$$i $(DESTDIR)$(lispsysdir)/$$i; \ + done ###----- That's all, folks -------------------------------------------------- diff --git a/src/auto.lisp.in b/src/auto.lisp.in new file mode 100644 index 0000000..758ef23 --- /dev/null +++ b/src/auto.lisp.in @@ -0,0 +1,7 @@ +;;; -*-lisp-*- + +(defparameter *version* "@VERSION@" + "The official Sod revision number.") + +(defparameter *sysdef-version* "@ASDF_VERSION@" + "The Sod revision number, forced into ASDF's limited format.") diff --git a/src/builtin.lisp b/src/builtin.lisp index c38d92c..5aad5f5 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -61,7 +61,7 @@ ',name (lambda (,classvar) (make-sod-slot ,classvar ,name (c-type ,type) - (make-property-set :lisp-class 'sod-class-slot + (make-property-set :slot-class 'sod-class-slot :initializer-function (lambda (,class) ,init) @@ -95,7 +95,7 @@ static void *~A__imprint(void *p) { struct ~A *sod__obj = p; - ~:{sod__obj->~A.~A._vt = &~A;~:^~% ~} + ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~} return (p); }~2%" class @@ -105,7 +105,8 @@ static void *~A__imprint(void *p) (tail (ichain-tail ichain))) (list (sod-class-nickname head) (sod-class-nickname tail) - (vtable-name class head)))) + (vtable-name class head) + (sod-class-nickname tail)))) (ilayout-ichains ilayout))))) (define-class-slot "init" (class stream) @@ -331,4 +332,7 @@ static const SodClass *const ~A__cpl[] = { (bootstrap-classes module)) (setf *builtin-module* module))) +(define-clear-the-decks builtin-module + (unless *builtin-module* (make-builtin-module))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/c-types-class-impl.lisp b/src/c-types-class-impl.lisp index 36e9c50..da16cd2 100644 --- a/src/c-types-class-impl.lisp +++ b/src/c-types-class-impl.lisp @@ -30,8 +30,8 @@ (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) + ((%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. diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index be2c055..4a0f6e2 100644 --- a/src/c-types-impl.lisp +++ b/src/c-types-impl.lisp @@ -431,6 +431,7 @@ (make-instance 'c-function-type :subtype subtype :arguments (if (and arguments (null (cdr arguments)) + (not (eq (car arguments) :ellipsis)) (eq (argument-type (car arguments)) c-type-void)) nil @@ -484,7 +485,7 @@ (list (argument-name arg) (argument-type arg)))) (c-function-arguments type)))) -(export '(fun function func fn)) +(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. diff --git a/src/c-types-parse.lisp b/src/c-types-parse.lisp index 4a8e1d7..b398ca9 100644 --- a/src/c-types-parse.lisp +++ b/src/c-types-parse.lisp @@ -233,7 +233,7 @@ (gethash kw *declspec-map*)))))) (cond ((or (not ds) (and predicate (not (funcall predicate ds)))) (values (list indicator) nil nil)) - ((ds-taggedp ds) + ((and (typep ds 'declspec) (ds-taggedp ds)) (scanner-step scanner) (if (eq (token-type scanner) :id) (let ((ty (make-c-tagged-type (ds-label ds) @@ -336,13 +336,18 @@ (make-pointer-type type quals))) (cdr state)))))) - (next-declspec-p () - ;; Ansert whether the next token is a valid declaration - ;; specifier, without consuming it. - (and (eq (token-type scanner) :id) - (let ((id (token-value scanner))) - (or (gethash id *module-type-map*) - (gethash id *declspec-map*))))) + (predict-argument-list-p () + ;; See `prefix-lparen'. Predict an argument list rather + ;; than a nested declarator if (a) abstract declarators are + ;; permitted and (b) the next token is a declaration + ;; specifier or ellipsis. + (let ((type (token-type scanner)) + (value (token-value scanner))) + (and abstractp + (or (eq type :ellipsis) + (and (eq type :id) + (or (gethash value *module-type-map*) + (gethash value *declspec-map*))))))) (prefix-lparen () ;; Prefix: `(' @@ -357,7 +362,7 @@ ;; specifier, then we have a postfix argument list. (parse (peek (seq (#\( - (nil (if (and abstractp (next-declspec-p)) + (nil (if (predict-argument-list-p) (values nil nil nil) (values t t nil)))) (lparen #\)))))) @@ -367,15 +372,34 @@ (cons #'identity name)))) (argument-list () - ;; [ argument [ `,' argument ]* ] - - (parse (list (:min 0) - (seq ((base-type (parse-c-type scanner)) - (dtor (parse-declarator scanner - base-type - :abstractp t))) - (make-argument (cdr dtor) (car dtor))) - #\,))) + ;; [argument [`,' argument]* [`,' `...']] | `...' + ;; + ;; The possibility of a trailing `,' `...' means that we + ;; can't use the standard `list' parser. Note that, unlike + ;; `real' C, we allow an ellipsis even if there are no + ;; explicit arguments. + + (let ((args nil)) + (loop + (when (eq (token-type scanner) :ellipsis) + (push :ellipsis args) + (scanner-step scanner) + (return)) + (multiple-value-bind (arg winp consumedp) + (parse (seq ((base-type (parse-c-type scanner)) + (dtor (parse-declarator scanner + base-type + :abstractp t))) + (make-argument (cdr dtor) (car dtor)))) + (unless winp + (if (or consumedp args) + (return-from argument-list (values arg nil t)) + (return))) + (push arg args)) + (unless (eq (token-type scanner) #\,) + (return)) + (scanner-step scanner)) + (values (nreverse args) t args))) (postfix-lparen () ;; Postfix: `(' argument-list `)' diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp index 9481a99..b9b61bf 100644 --- a/src/c-types-proto.lisp +++ b/src/c-types-proto.lisp @@ -149,7 +149,7 @@ This function is suitable for use in `format's ~/.../ command.")) -(export 'expand-c-type-spec) +(export '(expand-c-type-spec expand-c-type-form)) (eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric expand-c-type-spec (spec) (:documentation @@ -239,11 +239,13 @@ ;;; Function arguments. (export '(argument argumentp make-argument argument-name argument-type)) -(defstruct (argument (:constructor make-argument (name type)) +(defstruct (argument (:constructor make-argument (name type + &aux (%type type))) (:predicate argumentp)) "Simple structure representing a function argument." name - type) + %type) +(define-access-wrapper argument-type argument-%type) (export 'commentify-argument-name) (defgeneric commentify-argument-name (name) diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 39ac234..9c34bd7 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -381,12 +381,6 @@ (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) @@ -397,4 +391,18 @@ (:finalized t)))) +(macrolet ((define-layout-slot (slot (class) &body body) + `(define-on-demand-slot sod-class ,slot (,class) + (check-class-is-finalized ,class) + ,@body))) + (flet ((check-class-is-finalized (class) + (unless (eq (sod-class-state class) :finalized) + (error "Class ~S is not finalized" class)))) + (define-layout-slot %ilayout (class) + (compute-ilayout class)) + (define-layout-slot effective-methods (class) + (compute-effective-methods class)) + (define-layout-slot vtables (class) + (compute-vtables class)))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index 3a5b5cd..7a2d9cc 100644 --- a/src/class-layout-impl.lisp +++ b/src/class-layout-impl.lisp @@ -104,9 +104,10 @@ (defmethod print-object ((entry method-entry) stream) (maybe-print-unreadable-object (entry stream :type t) - (format stream "~A:~A" + (format stream "~A:~A~@[ ~S~]" (method-entry-effective-method entry) - (sod-class-nickname (method-entry-chain-head entry))))) + (sod-class-nickname (method-entry-chain-head entry)) + (method-entry-role entry)))) (defmethod compute-sod-effective-method ((message sod-message) (class sod-class)) @@ -128,12 +129,6 @@ (sod-class-messages super))) (sod-class-precedence-list class))) -(defmethod slot-unbound - (clos-class (class sod-class) (slot-name (eql 'effective-methods))) - (declare (ignore clos-class)) - (setf (slot-value class 'effective-methods) - (compute-effective-methods class))) - ;;;-------------------------------------------------------------------------- ;;; Instance layout. @@ -206,12 +201,6 @@ (reverse chain))) (sod-class-chains class)))) -(defmethod slot-unbound - (clos-class (class sod-class) (slot-name (eql 'ilayout))) - (declare (ignore clos-class)) - (setf (slot-value class 'ilayout) - (compute-ilayout class))) - ;;;-------------------------------------------------------------------------- ;;; Vtable layout. @@ -229,17 +218,17 @@ (subclass sod-class) (chain-head sod-class) (chain-tail sod-class)) - (flet ((make-entry (message) + (flet ((make-entries (message) (let ((method (find message (sod-class-effective-methods subclass) :key #'effective-method-message))) - (make-method-entry method chain-head chain-tail)))) + (make-method-entries method chain-head chain-tail)))) (make-instance 'vtmsgs :class class :subclass subclass :chain-head chain-head :chain-tail chain-tail - :entries (mapcar #'make-entry + :entries (mapcan #'make-entries (sod-class-messages class))))) ;;; class-pointer @@ -389,10 +378,4 @@ (compute-vtable class (reverse chain))) (sod-class-chains class))) -(defmethod slot-unbound - (clos-class (class sod-class) (slot-name (eql 'vtables))) - (declare (ignore clos-class)) - (setf (slot-value class 'vtables) - (compute-vtables class))) - ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-layout-proto.lisp b/src/class-layout-proto.lisp index ef75710..684fb32 100644 --- a/src/class-layout-proto.lisp +++ b/src/class-layout-proto.lisp @@ -31,7 +31,7 @@ (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) + ((%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)) @@ -65,7 +65,7 @@ (export '(islots islots-class islots-subclass islots-slots)) (defclass islots () - ((class :initarg :class :type sod-class :reader islots-class) + ((%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 @@ -88,7 +88,7 @@ (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) + ((%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 @@ -106,7 +106,7 @@ (export '(ichain ichain-class ichain-head ichain-tail ichain-body)) (defclass ichain () - ((class :initarg :class :type sod-class :reader ichain-class) + ((%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)) @@ -133,7 +133,7 @@ (export '(ilayout ilayout-class ilayout-ichains)) (defclass ilayout () - ((class :initarg :class :type sod-class :reader ilayout-class) + ((%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. @@ -152,7 +152,7 @@ ;;; vtmsgs (defclass vtmsgs () - ((class :initarg :class :type sod-class :reader vtmsgs-class) + ((%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) @@ -169,24 +169,24 @@ 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) +(export 'compute-vtmsgs) (defgeneric compute-vtmsgs (class subclass chain-head chain-tail) (:documentation - "Return a VTMSGS object containing method entries for CLASS. + "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.")) + 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) + ((%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 @@ -216,7 +216,7 @@ (export '(base-offset base-offset-class base-offset-chain-head)) (defclass base-offset () - ((class :initarg :class :type sod-class :reader base-offset-class) + ((%class :initarg :class :type sod-class :reader base-offset-class) (chain-head :initarg :chain-head :type sod-class :reader base-offset-chain-head)) (:documentation @@ -237,7 +237,7 @@ (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) + ((%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 @@ -263,7 +263,7 @@ (export '(vtable vtable-class vtable-body vtable-chain-head vtable-chain-tail)) (defclass vtable () - ((class :initarg :class :type sod-class :reader vtable-class) + ((%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 diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index 09ce441..878f813 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -79,7 +79,7 @@ (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 + (let ((slot (make-instance (get-property pset :slot-class :symbol 'sod-slot) :class class :name name @@ -87,7 +87,8 @@ :location (file-location location) :pset pset))) (with-slots (slots) class - (setf slots (append slots (list slot))))))) + (setf slots (append slots (list slot)))) + slot))) (defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset) "This method does nothing. @@ -111,7 +112,8 @@ (file-location location)))) (with-slots (instance-initializers) class (setf instance-initializers - (append instance-initializers (list initializer))))))) + (append instance-initializers (list initializer)))) + initializer))) (defmethod make-sod-class-initializer ((class sod-class) nick name value-kind value-form pset @@ -124,12 +126,13 @@ (file-location location)))) (with-slots (class-initializers) class (setf class-initializers - (append class-initializers (list initializer))))))) + (append class-initializers (list initializer)))) + initializer))) (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) + (make-instance (get-property pset :initializer-class :symbol init-class) :class class :slot slot :value-kind value-kind @@ -152,20 +155,24 @@ (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))) + (let* ((msg-class (or (get-property pset :message-class :symbol) + (and (get-property pset :combination :keyword) + 'aggregating-message) + 'standard-message)) + (message (make-instance msg-class + :class class + :name name + :type type + :location (file-location location) + :pset pset))) (with-slots (messages) class - (setf messages (append messages (list message))))))) + (setf messages (append messages (list message)))) + message))) (defmethod shared-initialize :after ((message sod-message) slot-names &key pset) (declare (ignore slot-names pset)) - (with-slots (type) message + (with-slots ((type %type)) message (check-message-type message type))) (defmethod check-message-type ((message sod-message) (type c-function-type)) @@ -185,11 +192,12 @@ type body pset (file-location location)))) (with-slots (methods) class - (setf methods (append methods (list method))))))) + (setf methods (append methods (list method)))) + method))) (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) + (make-instance (or (get-property pset :method-class :symbol) (sod-message-method-class message class pset)) :message message :class class @@ -208,16 +216,17 @@ (declare (ignore slot-names pset)) ;; Check that the arguments are named if we have a method body. - (with-slots (body type) method + (with-slots (body (type %type)) method (unless (or (not body) (every (lambda (arg) - (or (argument-name arg) + (or (eq arg :ellipsis) + (argument-name arg) (eq (argument-type arg) (c-type void)))) (c-function-arguments type))) (error "Abstract declarators not permitted in method definitions"))) ;; Check the method type. - (with-slots (message type) method + (with-slots (message (type %type)) method (check-method-type method message type))) (defmethod check-method-type @@ -226,7 +235,7 @@ (defmethod check-method-type ((method sod-method) (message sod-message) (type c-function-type)) - (with-slots ((msgtype type)) message + (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" diff --git a/src/class-make-proto.lisp b/src/class-make-proto.lisp index 2b4463a..c04727c 100644 --- a/src/class-make-proto.lisp +++ b/src/class-make-proto.lisp @@ -33,8 +33,8 @@ "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 + follows. The `:lisp-metaclass' 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 @@ -45,7 +45,7 @@ (with-default-error-location (location) (let* ((pset (property-set pset)) - (class (make-instance (get-property pset :lisp-class :symbol + (class (make-instance (get-property pset :lisp-metaclass :symbol 'sod-class) :name name :superclasses superclasses @@ -71,7 +71,7 @@ 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 + process. The default method uses the `:slot-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 @@ -111,11 +111,11 @@ 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 + class and slot types. The default method uses the `:initializer-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 @@ -136,12 +136,13 @@ 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'.")) + process. The default method uses the `:message-class' property to choose + a (CLOS) class to instantiate; if no such property is provided but a + `combination' property is present, then `aggregating-message' is chosen; + otherwise `standard-message' is used. 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'.")) (export 'make-sod-method) (defgeneric make-sod-method @@ -167,7 +168,7 @@ 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 + the `:method-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 @@ -187,9 +188,9 @@ "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.")) + `:method-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) diff --git a/src/class-output.lisp b/src/class-output.lisp index 687b22c..35269a7 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -44,6 +44,7 @@ (class :ichains :start) (class :ichains :end) (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end) (class :conversions) + (class :message-macros) (class :object) (:classes :end)) @@ -97,20 +98,74 @@ (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)~])~%" + (format stream "#define ~:@(~A__CONV_~A~)(_obj) ((~A *)~ + ~:[SOD_XCHAIN(~A, (_obj))~;(_obj)~])~%" class (sod-class-nickname super) super (eq chain-head super-head) (sod-class-nickname super-head)))) (terpri stream))))) + ;; Provide convenience macros for sending the newly defined messages. (The + ;; macros work on all subclasses too.) + ;; + ;; We need each message's method entry type for this, so we need to dig it + ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains + ;; entries for precisely the messages we want to make macros for. + (when (sod-class-messages class) + (sequence-output (stream sequencer) + ((class :message-macros) + (let* ((vtable (find (sod-class-chain-head class) + (sod-class-vtables class) + :key #'vtable-chain-head)) + (vtmsgs (find-if (lambda (item) + (and (typep item 'vtmsgs) + (eql (vtmsgs-class item) class))) + (vtable-body vtable)))) + (format stream "/* Message invocation macros. */~%") + (dolist (entry (vtmsgs-entries vtmsgs)) + (let* ((type (method-entry-function-type entry)) + (args (c-function-arguments type)) + (in-names nil) (out-names nil) (varargsp nil) (me "me")) + (do ((args args (cdr args))) + ((endp args)) + (let* ((raw-name (princ-to-string (argument-name (car args)))) + (name (if (find raw-name + (list "_vt" + (sod-class-nickname class) + (method-entry-slot-name entry)) + :test #'string=) + (format nil "sod__a_~A" raw-name) + raw-name))) + (cond ((and (cdr args) (eq (cadr args) :ellipsis)) + (setf varargsp t) + (unless in-names (setf me "SOD_CAR(__VA_ARGS__)")) + (push (format nil "/*~A*/ ..." name) in-names) + (push "__VA_ARGS__" out-names) + (return)) + (t + (push name in-names) + (push name out-names))))) + (when varargsp + (format stream "#if __STDC_VERSION__ >= 199901~%")) + (format stream "#define ~A(~{~A~^, ~}) ~ + ~A->_vt->~A.~A(~{~A~^, ~})~%" + (message-macro-name class entry) + (nreverse in-names) + me + (sod-class-nickname class) + (method-entry-slot-name entry) + (nreverse out-names)) + (when varargsp + (format stream "#endif~%")))) + (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 + (with-slots ((ilayout %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)) @@ -137,7 +192,7 @@ (hook-output item reason sequencer))) (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer) - (with-slots (class ichains) ilayout + (with-slots ((class %class) ichains) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) (format stream "/* Instance layout. */~@ @@ -149,7 +204,7 @@ (hook-output ichain 'ilayout sequencer)))) (defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) ichain + (with-slots ((class %class) chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :ichains :start) @@ -180,7 +235,7 @@ (defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout)) sequencer) - (with-slots (class chain-head chain-tail) ichain + (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) (format stream " union ~A ~A;~%" @@ -190,7 +245,7 @@ (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtptr + (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) ((class :ichain chain-head :slots) (format stream " const struct ~A *_vt;~%" @@ -201,7 +256,7 @@ (hook-output slot reason sequencer))) (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer) - (with-slots (class subclass slots) islots + (with-slots ((class %class) subclass slots) islots (sequence-output (stream sequencer) ((subclass :ichain (sod-class-chain-head class) :slots) (format stream " struct ~A ~A;~%" @@ -218,7 +273,7 @@ (defmethod hook-output progn ((method sod-method) (reason (eql :h)) sequencer) - (with-slots (class) method + (with-slots ((class %class)) method (sequence-output (stream sequencer) ((class :methods) (let ((type (sod-method-function-type method))) @@ -228,7 +283,7 @@ (format stream ";~%")))))) (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (with-slots ((class %class) chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -241,15 +296,27 @@ struct ~A {~%" (vtable-struct-tag chain-tail chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%")))) + (format stream "};~2%") + (format stream "/* Union of equivalent superclass vtables. */~@ + union ~A {~@ + ~:{ struct ~A ~A;~%~}~ + };~2%" + (vtable-union-tag chain-tail chain-head) + + ;; As for the ichain union, make sure the most specific + ;; class is first. + (mapcar (lambda (super) + (list (vtable-struct-tag super chain-head) + (sod-class-nickname super))) + (sod-class-chain chain-tail)))))) (sequence-output (stream sequencer) ((class :vtable-externs) - (format stream "~@~%" - (vtable-struct-tag chain-tail chain-head) + (format stream "~@~%" + (vtable-union-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 + (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs (sequence-output (stream sequencer) ((subclass :vtable chain-head :slots) (format stream " struct ~A ~A;~%" @@ -260,7 +327,7 @@ (reason (eql 'vtmsgs)) sequencer) (when (vtmsgs-entries vtmsgs) - (with-slots (class subclass) vtmsgs + (with-slots ((class %class) subclass) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtmsgs :start) (subclass :vtmsgs class :start) @@ -291,13 +358,13 @@ (sequence-output (stream sequencer) ((class :vtmsgs (sod-message-class message) :slots) (pprint-logical-block (stream nil :prefix " " :suffix ";") - (pprint-c-type pointer-type stream (sod-message-name message))) + (pprint-c-type pointer-type stream (method-entry-slot-name entry))) (terpri stream))))) (defmethod hook-output progn ((cptr class-pointer) (reason (eql :h)) sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr + (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%" @@ -306,7 +373,7 @@ (sod-class-nickname meta-chain-head))))))) (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head) boff + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (write-line " size_t _base;" stream))))) @@ -314,7 +381,7 @@ (defmethod hook-output progn ((choff chain-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head target-head) choff + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (format stream " ptrdiff_t _off_~A;~%" @@ -360,7 +427,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)) sequencer) - (with-slots (class body) method + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -375,7 +442,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method sod-method) (reason (eql :c)) sequencer) - (with-slots (class body) method + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -397,7 +464,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method basic-effective-method) (reason (eql :c)) sequencer) - (with-slots (class functions) method + (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) (dolist (func functions) @@ -407,7 +474,7 @@ const struct ~A ~A__classobj = {~%" ;;; Vtables. (defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (with-slots ((class %class) chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) (class :vtable chain-head :start) @@ -415,17 +482,17 @@ const struct ~A ~A__classobj = {~%" (class :vtables :end)) ((class :vtable chain-head :start) (format stream "/* Vtable for ~A chain. */~@ - const struct ~A ~A = {~%" + const union ~A ~A = { {~%" chain-head - (vtable-struct-tag chain-tail chain-head) + (vtable-union-tag chain-tail chain-head) (vtable-name class chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%"))))) + (format stream "} };~2%"))))) (defmethod hook-output progn ((cptr class-pointer) (reason (eql :c)) sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr + (with-slots ((class %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) @@ -441,7 +508,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname metaclass)))))) (defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head) boff + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :base-offset) @@ -455,7 +522,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((choff chain-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head target-head) choff + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :chain-offset target-head) @@ -468,7 +535,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname target-head)))))) (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) - (with-slots (class subclass chain-head) vtmsgs + (with-slots ((class %class) subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) (subclass :vtable chain-head :vtmsgs class :start) @@ -484,15 +551,15 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((entry method-entry) (reason (eql :c)) sequencer) - (with-slots (method chain-head chain-tail) entry + (with-slots ((method %method) chain-head chain-tail role) 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 " /* ~19@A = */ ~A,~%" - (sod-message-name message) - (method-entry-function-name method chain-head))))))) + (method-entry-slot-name entry) + (method-entry-function-name method chain-head role))))))) ;;;-------------------------------------------------------------------------- ;;; Filling in the class object. @@ -500,7 +567,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((ichain ichain) (reason (eql 'class)) sequencer) - (with-slots (class chain-head) ichain + (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) (*instance-class* :object chain-head :ichain :start) @@ -515,7 +582,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((islots islots) (reason (eql 'class)) sequencer) - (with-slots (class) islots + (with-slots ((class %class)) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -531,14 +598,16 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class)) sequencer) - (with-slots (class chain-head chain-tail) vtptr + (with-slots ((class %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)))))) + (format stream " /* ~17@A = */ &~A.~A,~%" + "_vt" + (vtable-name class chain-head) + (sod-class-nickname chain-tail)))))) (defgeneric find-class-initializer (slot class) (:method ((slot effective-slot) (class sod-class)) @@ -582,7 +651,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((slot effective-slot) (reason (eql 'class)) sequencer) - (with-slots (class (dslot slot)) slot + (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) (sequence-output (stream sequencer) diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp index 491671d..0aec35a 100644 --- a/src/class-utilities.lisp +++ b/src/class-utilities.lisp @@ -160,7 +160,8 @@ (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 method-arg) + (c-type va-list)) (c-type-equal-p (argument-type message-arg) (argument-type method-arg)))) message-args method-args))) @@ -188,6 +189,10 @@ (defun vtmsgs-struct-tag (class super) (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) +(export 'vtable-union-tag) +(defun vtable-union-tag (class chain-head) + (format nil "~A__vtu_~A" class (sod-class-nickname chain-head))) + (export 'vtable-struct-tag) (defun vtable-struct-tag (class chain-head) (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) @@ -196,4 +201,8 @@ (defun vtable-name (class chain-head) (format nil "~A__vtable_~A" class (sod-class-nickname chain-head))) +(export 'message-macro-name) +(defun message-macro-name (class entry) + (format nil "~A_~A" class (method-entry-slot-name entry))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/classes.lisp b/src/classes.lisp index c81c41e..afbb485 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -25,6 +25,21 @@ (cl:in-package #:sod) +;;; Note! You'll notice that none of the classes defined here store property +;;; sets persistently, even though there's a `:pset' keyword argument +;;; accepted by many of the classes' initialization methods. That's because +;;; part of the pset protocol involves checking that there are no unused +;;; properties, and this typically happens shortly after the appropriate +;;; objects are constructed. It would be tempting to stash the pset at +;;; initialization time, and then pick some property from it out later -- but +;;; that won't work in general because an error might have been signalled +;;; about that property. It wouldn't surprise me greatly to discover that +;;; `most' code paths resulted in the property being looked up in time to +;;; avoid the unused-property error, but a subtle change in circumstances +;;; then causes a thing done on demand to be done later, leading to +;;; irritating and misleading errors being reported to the user. So please +;;; don't do that. + ;;;-------------------------------------------------------------------------- ;;; Classes. @@ -63,13 +78,13 @@ (class-precedence-list :type list :accessor sod-class-precedence-list) - (type :type c-class-type :accessor sod-class-type) + (%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) + (%ilayout :type ilayout :accessor sod-class-ilayout) (effective-methods :type list :accessor sod-class-effective-methods) (vtables :type list :accessor sod-class-vtables) @@ -179,19 +194,19 @@ 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'. + computed on demand (see `define-on-demand-slot'). * The ILAYOUT describes the layout for an instance of the class. It's - quite complicated; see the documentation of the ILAYOUT class for + 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.")) + 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) @@ -205,8 +220,8 @@ ((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)) + (%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. @@ -244,7 +259,7 @@ ((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) + (%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 @@ -323,8 +338,8 @@ ((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)) + (%class :initarg :class :type sod-class :reader sod-message-class) + (%type :initarg :type :type c-function-type :reader sod-message-type)) (:documentation "Messages are the means for stimulating an object to behave. @@ -375,8 +390,8 @@ ((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) + (%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. diff --git a/src/codegen-impl.lisp b/src/codegen-impl.lisp index 2b23661..170f4a8 100644 --- a/src/codegen-impl.lisp +++ b/src/codegen-impl.lisp @@ -40,7 +40,6 @@ (defmethod commentify-argument-name ((name temporary-name)) nil) -(export 'temporary-function) (defun temporary-function () "Return a temporary function name." (make-instance 'temporary-function @@ -66,49 +65,44 @@ ;; 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)) +;; HACK: use gensyms for the `condition' slots to avoid leaking the slot +;; names, since the symbol `condition' actually comes from the `common-lisp' +;; package. The `definst' machinery will symbolicate the various associated +;; methods correctly despite this subterfuge. -(definst if (stream) (condition consequent alternative) +(definst if (stream :export t) (#1=#:condition consequent alternative) (format-compound-statement (stream consequent alternative) - (format stream "if (~A)" condition)) + (format stream "if (~A)" #1#)) (when alternative (format-compound-statement (stream alternative) (write-string "else" stream)))) -(definst while (stream) (condition body) +(definst while (stream :export t) (#1=#:condition body) (format-compound-statement (stream body) - (format stream "while (~A)" condition))) + (format stream "while (~A)" #1#))) -(definst do-while (stream) (body condition) +(definst do-while (stream :export t) (body #1=#:condition) (format-compound-statement (stream body :space) (write-string "do" stream)) - (format stream "while (~A);" condition)) + (format stream "while (~A);" #1#)) ;; 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) +(definst va-start (stream :export t) (ap arg) (format stream "va_start(~@<~A, ~_~A~:>);" ap arg)) -(definst va-copy (stream) (to from) +(definst va-copy (stream :export t) (to from) (format stream "va_copy(~@<~A, ~_~A~:>);" to from)) -(definst va-end (stream) (ap) +(definst va-end (stream :export t) (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)) +;; HACK: use a gensym for the `func' slot to avoid leaking the slot name, +;; since the symbol `func' is exported from our package. +(definst call (stream :export t) (#1=#:func args) + (format stream "~A(~@<~{~A~^, ~_~}~:>)" #1# args)) ;;;-------------------------------------------------------------------------- ;;; Code generator objects. @@ -137,9 +131,17 @@ (defmethod emit-insts ((codegen basic-codegen) insts) (asetf (codegen-insts codegen) (revappend insts it))) +(defmethod emit-decl ((codegen basic-codegen) inst) + (push inst (codegen-vars codegen))) + +(defmethod emit-decls ((codegen basic-codegen) insts) + (asetf (codegen-vars 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))) + (var (find name + (remove-if-not (lambda (var) (typep var 'var-inst)) vars) + :key #'inst-name :test #'equal))) (cond ((not var) (setf (codegen-vars codegen) (cons (make-var-inst name type init) vars))) @@ -188,7 +190,7 @@ (c-type-equal-p type (inst-type var))) name nil))) - vars) + (remove-if-not (lambda (var) (typep var 'var-inst)) vars)) (let* ((name (make-instance 'temporary-variable :in-use-p t :tag (prog1 temp-index diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index b8206fa..535839c 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -49,7 +49,7 @@ ;; Root class. -(export 'temporary-name) +(export '(temporary-name temp-tag)) (defclass temporary-name () ((tag :initarg :tag :reader temp-tag)) (:documentation @@ -74,6 +74,8 @@ (make-instance 'temporary-name :tag "sod__ap")) (defparameter *sod-master-ap* (make-instance 'temporary-name :tag "sod__master_ap")) +(defparameter *sod-tmp-ap* + (make-instance 'temporary-name :tag "sod__tmp_ap")) ;;;-------------------------------------------------------------------------- ;;; Instructions. @@ -120,7 +122,7 @@ ;; Instruction definition. (export 'definst) -(defmacro definst (code (streamvar) args &body body) +(defmacro definst (code (streamvar &key export) args &body body) "Define an instruction type and describe how to output it. An `inst' can represent any structured piece of output syntax: a @@ -138,10 +140,14 @@ * A print method, which prints a diagnostic dump if `*print-escape*' is set, or invokes the BODY (with STREAMVAR bound to the output stream) otherwise. The BODY is expected to produce target code at this - point." + point. + + If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst' + symbols." (let ((inst-var (gensym "INST")) (class-name (symbolicate code '-inst)) + (constructor-name (symbolicate 'make- code '-inst)) (keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword)) args))) `(progn @@ -149,7 +155,7 @@ ,(mapcar (lambda (arg key) `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg))) args keys)) - (defun ,(symbolicate 'make- code '-inst) (,@args) + (defun ,constructor-name (,@args) (make-instance ',class-name ,@(mappend #'list keys args))) (defmethod inst-metric ((,inst-var ,class-name)) (with-slots (,@args) ,inst-var @@ -160,33 +166,43 @@ (print-unreadable-object (,inst-var ,streamvar :type t) (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>" ,@(mappend #'list keys args))) - (progn ,@body))))))) + (progn ,@body)))) + ,@(and export `((export '(,class-name ,constructor-name + ,@(mapcar (lambda (arg) + (symbolicate 'inst- arg)) + args))))) + ',code))) ;; 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)) +;; HACK: use a gensym for the `expr' and `type' slots to avoid leaking the +;; slot names, since the symbol `expr' is exported from our package and +;; `type' belongs to the `common-lisp' package. -(definst var (stream) (name type init) - (pprint-c-type type stream name) +(definst var (stream :export t) (name #1=#:type init) + (pprint-c-type #1# 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~^~:@_~}~:>~:@_}" + (format stream " = ~A" init)) + (write-char #\; stream)) +(definst set (stream :export t) (var #1=#:expr) + (format stream "~@<~A = ~@_~2I~A;~:>" var #1#)) +(definst update (stream :export t) (var op #1=#:expr) + (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op #1#)) +(definst return (stream :export t) (#1=#:expr) + (format stream "return~@[ (~A)~];" #1#)) +(definst break (stream :export t) () + (format stream "break;")) +(definst continue (stream :export t) () + (format stream "continue;")) +(definst expr (stream :export t) (#1=#:expr) + (format stream "~A;" #1#)) +(definst block (stream :export t) (decls body) + (format stream "{~:@_~@< ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}" decls body)) -(definst function (stream) (name type body) +(definst function (stream :export t) (name #1=#:type body) (pprint-logical-block (stream nil) (princ "static " stream) - (pprint-c-type type stream name) + (pprint-c-type #1# stream name) (format stream "~:@_~A~:@_~:@_" body))) ;; Formatting utilities. @@ -254,6 +270,14 @@ (:method (codegen insts) (dolist (inst insts) (emit-inst codegen inst)))) +(export '(emit-decl emit-decls)) +(defgeneric emit-decl (codegen inst) + (:documentation + "Add INST to the end of CODEGEN's list of declarations.")) +(defgeneric emit-decls (codegen insts) + (:documentation + "Add a list of INSTS to the end of CODEGEN's list of declarations.")) + (export 'codegen-push) (defgeneric codegen-push (codegen) (:documentation diff --git a/src/final.lisp b/src/final.lisp new file mode 100644 index 0000000..5df72f1 --- /dev/null +++ b/src/final.lisp @@ -0,0 +1,70 @@ +;;; -*-lisp-*- +;;; +;;; Finishing touches for Sod +;;; +;;; (c) 2015 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) + +;;;-------------------------------------------------------------------------- +;;; Debugging utilities. + +(export '*debugout-pathname*) +(defvar *debugout-pathname* #p"debugout.c") + +(export 'test-module) +(defun test-module (path reason) + "Reset the translator's state, read a module from PATH and output it with + REASON, returning the result as a string." + (clear-the-decks) + (setf *module-map* (make-hash-table :test #'equal)) + (with-open-file (out *debugout-pathname* + :direction :output + :if-exists :supersede + :if-does-not-exist :create) + (output-module (read-module path) reason out))) + +;;;-------------------------------------------------------------------------- +;;; Calisthenics. + +(export 'exercise) +(defun exercise () + "Exercise the pieces of the metaobject protocol. + + In some Lisps, the compiler is run the first time methods are called, to + do fancy just-in-time optimization things. This is great, only the + program doesn't actually run for very long and a lot of that work is + wasted because we're going to have to do it again next time the program + starts. Only, if we exercise the various methods, or at least a large + fraction of them, before we dump an image, then everything will be fast. + + That's the theory anyway. Call this function before you dump an image and + see what happens." + + (clear-the-decks) + (dolist (reason '(:h :c)) + (with-output-to-string (bitbucket) + (output-module *builtin-module* reason bitbucket))) + + (clear-the-decks)) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/frontend.lisp b/src/frontend.lisp index 9ed6f30..98652ec 100644 --- a/src/frontend.lisp +++ b/src/frontend.lisp @@ -30,6 +30,12 @@ (cl:in-package #:sod-frontend) ;;;-------------------------------------------------------------------------- +;;; Preparation for dumping. + +(clear-the-decks) +(exercise) + +;;;-------------------------------------------------------------------------- ;;; The main program. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -85,7 +91,7 @@ :usage "SOURCES..." :options (options (help-options :short-version #\V) - "Crazy options" + "Translator options" (#\I "include" (:arg "DIR") ("Search DIR for module imports.") (list *module-dirs* 'string)) @@ -110,9 +116,6 @@ (or builtinsp args)) (die-usage)) - ;; Prepare the builtins. - (make-builtin-module) - ;; Do the main parsing job. (multiple-value-bind (hunoz nerror nwarn) (count-and-report-errors () @@ -169,12 +172,10 @@ ;; If we're writing the builtin module then now seems like a ;; good time to do that. (when builtinsp - (clear-the-decks) (hack-module *builtin-module*)) ;; Parse and write out the remaining modules. (dolist (arg args) - (clear-the-decks) (hack-module (read-module arg)))))) ;; Report on how well everything worked. diff --git a/src/method-aggregate.lisp b/src/method-aggregate.lisp new file mode 100644 index 0000000..e374924 --- /dev/null +++ b/src/method-aggregate.lisp @@ -0,0 +1,438 @@ +;;; -*-lisp-*- +;;; +;;; Aggregating method combinations +;;; +;;; (c) 2015 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 and protocol. + +(export 'aggregating-message) +(defclass aggregating-message (simple-message) + ((combination :initarg :combination :type keyword + :reader message-combination) + (kernel-function :type function :reader message-kernel-function)) + (:documentation + "Message class for aggregating method combinations. + + An aggregating method combination invokes the primary methods in order, + most-specific first, collecting their return values, and combining them + together in some way to produce a result for the effective method as a + whole. + + Mostly, this is done by initializing an accumulator to some appropriate + value, updating it with the result of each primary method in turn, and + finally returning some appropriate output function of it. The order is + determined by the `:most-specific' property, which may have the value + `:first' or `:last'. + + The `progn' method combination is implemented as a slightly weird special + case of an aggregating method combination with a trivial state. More + typical combinations are `:sum', `:product', `:min', `:max', `:and', and + `:or'. Finally, there's a `custom' combination which uses user-supplied + code fragments to stitch everything together.")) + +(export 'aggregating-message-properties) +(defgeneric aggregating-message-properties (message combination) + (:documentation + "Return a description of the properties needed by the method COMBINATION. + + The description should be a plist of alternating property name and type + keywords. The named properties will be looked up in the pset supplied at + initialization time, and supplied to `compute-aggregating-message-kernel' + as keyword arguments. Defaults can be supplied in method BVLs. + + The default is not to capture any property values. + + The reason for this is as not to retain the pset beyond message object + initialization.") + (:method (message combination) nil)) + +(export 'compute-aggregating-message-kernel) +(defgeneric compute-aggregating-message-kernel + (message combination codegen target methods arg-names &key) + (:documentation + "Determine how to aggregate the direct methods for an aggregating message. + + The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES + METHODS): it should emit, to CODEGEN, an appropriate effective-method + kernel which invokes the listed direct METHODS, in the appropriate order, + collects and aggregates their values, and delivers to TARGET the final + result of the method kernel. + + The easy way to implement this method is to use the macro + `define-aggregating-method-combination'.")) + +(export 'check-aggregating-message-type) +(defgeneric check-aggregating-message-type (message combination type) + (:documentation + "Check that TYPE is an acceptable function TYPE for the COMBINATION. + + For example, `progn' messages must return `void', while `and' and `or' + messages must return `int'.") + (:method (message combination type) + t)) + +(export 'aggregating-effective-method) +(defclass aggregating-effective-method (simple-effective-method) () + (:documentation "Effective method counterpart to `aggregating-message'.")) + +;;;-------------------------------------------------------------------------- +;;; Implementation. + +(defmethod check-message-type ((message aggregating-message) type) + (with-slots (combination) message + (check-aggregating-message-type message combination type))) + +(defmethod message-effective-method-class ((message aggregating-message)) + 'aggregating-effective-method) + +(defmethod simple-method-body + ((method aggregating-effective-method) codegen target) + (let ((argument-names (effective-method-basic-argument-names method)) + (primary-methods (effective-method-primary-methods method))) + (funcall (message-kernel-function (effective-method-message method)) + codegen target argument-names primary-methods))) + +(defmethod shared-initialize :before + ((message aggregating-message) slot-names &key pset) + (declare (ignore slot-names)) + (with-slots (combination kernel-function) message + (let ((most-specific (get-property pset :most-specific :keyword :first)) + (comb (get-property pset :combination :keyword))) + + ;; Check that we've been given a method combination and make sure it + ;; actually exists. + (unless comb + (error "The `combination' property is required.")) + (unless (some (lambda (method) + (let* ((specs (method-specializers method)) + (message-spec (car specs)) + (combination-spec (cadr specs))) + (and (typep message-spec 'class) + (typep message message-spec) + (typep combination-spec 'eql-specializer) + (eq (eql-specializer-object combination-spec) + comb)))) + (generic-function-methods + #'compute-aggregating-message-kernel)) + (error "Unknown method combination `~(~A~)'." comb)) + (setf combination comb) + + ;; Make sure the ordering is actually valid. + (unless (member most-specific '(:first :last)) + (error "The `most_specific' property must be `first' or `last'.")) + + ;; Set up the function which will compute the kernel. + (let ((magic (cons nil nil)) + (keys nil)) + + ;; Collect the property values wanted by the method combination. + (do ((want (aggregating-message-properties message comb) + (cddr want))) + ((endp want)) + (let* ((name (car want)) + (type (cadr want)) + (prop (get-property pset name type magic))) + (unless (eq prop magic) + (setf keys (list* name prop keys))))) + + ;; Set the kernel function for later. + (setf kernel-function + (lambda (codegen target arg-names methods) + (apply #'compute-aggregating-message-kernel + message comb + codegen target + (ecase most-specific + (:first methods) + (:last (setf methods (reverse methods)))) + arg-names + keys))))))) + +;;;-------------------------------------------------------------------------- +;;; Utilities. + +(export 'define-aggregating-method-combination) +(defmacro define-aggregating-method-combination + (comb + (vars + &key (codegen (gensym "CODEGEN-")) + (methods (gensym "METHODS-"))) + &key properties return-type + ((:around around-func) '#'funcall) + ((:first-method first-method-func) nil firstp) + ((:methods methods-func) '#'funcall)) + "Utility macro for definining aggregating method combinations. + + The VARS are a list of variable names to be bound to temporary variable + objects of the method's return type. Additional keyword arguments define + variables names to be bound to other possibly interesting values: + + * CODEGEN is the `codegen' object passed at effective-method computation + time; and + + * METHODS is the list of primary methods, in the order in which they + should be invoked. Note that this list must be non-empty, since + otherwise the method on `compute-effective-method-body' specialized to + `simple-effective-method' will suppress the method entirely. + + The PROPERTIES, if specified, are a list of properties to be collected + during message-object initialization; items in the list have the form + + (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP]) + + similar to a `&key' BVL entry, except for the additional TYPE entry. In + particular, a symbolic NAME may be written in place of a singleton list. + The KEYWORD names the property as it should be looked up in the pset, + while the NAME names a variable to which the property value or default is + bound. + + All of these variables, and the VARS, are available in the functions + described below. + + If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined + on `check-aggregating-message-type' to check the that the message's return + type matches RETURN-TYPE. + + The AROUND, FIRST-METHOD, and METHODS are function designators (probably + `lambda' forms) providing pieces of the aggregating behaviour. + + The AROUND function is called first, with a single argument BODY, though + the variables above are also in scope. It is expected to emit code to + CODEGEN which invokes the METHODS in the appropriate order, and arranges + to store the aggregated return value in the first of the VARS. + + It may call BODY as a function in order to assist with this; let ARGS be + the list of arguments supplied to it. The default behaviour is to call + BODY with no arguments. The BODY function first calls FIRST-METHOD, + passing it as arguments a function INVOKE and the ARGS which were passed + to BODY, and then calls METHODS once for each remaining method, again + passing an INVOKE function and the ARGS. If FIRST-METHOD is not + specified, then the METHODS function is used for all of the methods. If + METHODS is not specified, then the behaviour is simply to call INVOKE + immediately. (See the definition of the `:progn' method combination.) + + Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call + the appropriate direct method and deliver its return value to TARGET, + which defaults to `:void'." + + (with-gensyms (type msg combvar target arg-names args want-type + meth targ func call-methfunc + aroundfunc fmethfunc methfunc) + `(progn + + ;; If properties are listed, arrange for them to be collected. + ,@(and properties + `((defmethod aggregating-message-properties + ((,msg aggregating-message) (,combvar (eql ',comb))) + ',(mapcan (lambda (prop) + (list (let* ((name (car prop)) + (names (if (listp name) name + (list name)))) + (if (cddr names) (car names) + (intern (car names) :keyword))) + (cadr prop))) + properties)))) + + ;; If a particular return type is wanted, check that. + ,@(and return-type + `((defmethod check-aggregating-message-type + ((,msg aggregating-message) + (,combvar (eql ',comb)) + (,type c-function-type)) + (let ((,want-type (c-type ,return-type))) + (unless (c-type-equal-p (c-type-subtype ,type) + ,want-type) + (error "Messages with `~(~A~)' combination ~ + must return `~A'." + ,combvar ,want-type))) + (call-next-method)))) + + ;; Define the main kernel-compuation method. + (defmethod compute-aggregating-message-kernel + ((,msg aggregating-message) (,combvar (eql ',comb)) + ,codegen ,target ,methods ,arg-names + &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop))) + properties)) + (declare (ignore ,combvar)) + + ;; Declare the necessary variables and give names to the functions + ;; supplied by the caller. + (let* (,@(and vars + `((,type (c-type-subtype (sod-message-type ,msg))))) + ,@(mapcar (lambda (var) + (list var `(temporary-var ,codegen ,type))) + vars) + (,aroundfunc ,around-func) + (,methfunc ,methods-func) + (,fmethfunc ,(if firstp first-method-func methfunc))) + + ;; Arrange to release the temporaries when we're finished with + ;; them. + (unwind-protect + (progn + + ;; Wrap the AROUND function around most of the work. + (funcall ,aroundfunc + (lambda (&rest ,args) + (flet ((,call-methfunc (,func ,meth) + ;; Call FUNC, passing it an INVOKE + ;; function which will generate a call + ;; to METH. + (apply ,func + (lambda + (&optional (,targ :void)) + (invoke-method ,codegen + ,targ + ,arg-names + ,meth)) + ,args))) + + ;; The first method might need special + ;; handling. + (,call-methfunc ,fmethfunc (car ,methods)) + + ;; Call the remaining methods in the right + ;; order. + (dolist (,meth (cdr ,methods)) + (,call-methfunc ,methfunc ,meth))))) + + ;; Outside the AROUND function now, deliver the final + ;; result to the right place. + (deliver-expr ,codegen ,target ,(car vars))) + + ;; Finally, release the temporary variables. + ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil)) + vars)))) + + ',comb))) + +;;;-------------------------------------------------------------------------- +;;; Fixed aggregating method combinations. + +(define-aggregating-method-combination :progn (nil) + :return-type void) + +(define-aggregating-method-combination :sum ((acc val) :codegen codegen) + :first-method (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-set-inst acc val))) + :methods (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-update-inst acc #\+ val)))) + +(define-aggregating-method-combination :product ((acc val) :codegen codegen) + :first-method (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-set-inst acc val))) + :methods (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-update-inst acc #\* val)))) + +(define-aggregating-method-combination :min ((acc val) :codegen codegen) + :first-method (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-set-inst acc val))) + :methods (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val) + (make-set-inst acc val) nil)))) + +(define-aggregating-method-combination :max ((acc val) :codegen codegen) + :first-method (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-set-inst acc val))) + :methods (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val) + (make-set-inst acc val) nil)))) + +(define-aggregating-method-combination :and ((ret val) :codegen codegen) + :return-type int + :around (lambda (body) + (codegen-push codegen) + (deliver-expr codegen ret 0) + (funcall body) + (deliver-expr codegen ret 1) + (emit-inst codegen + (make-do-while-inst (codegen-pop-block codegen) 0))) + :methods (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-if-inst (format nil "!~A" val) + (make-break-inst) nil)))) + +(define-aggregating-method-combination :or ((ret val) :codegen codegen) + :return-type int + :around (lambda (body) + (codegen-push codegen) + (deliver-expr codegen ret 1) + (funcall body) + (deliver-expr codegen ret 0) + (emit-inst codegen + (make-do-while-inst (codegen-pop-block codegen) 0))) + :methods (lambda (invoke) + (funcall invoke val) + (emit-inst codegen (make-if-inst val (make-break-inst) nil)))) + +;;;-------------------------------------------------------------------------- +;;; A customizable aggregating method combination. + +(defmethod aggregating-message-properties + ((message aggregating-message) (combination (eql :custom))) + '(:retvar :id + :valvar :id + :decls :fragment + :before :fragment + :first :fragment + :each :fragment + :after :fragment + :count :id)) + +(defmethod compute-aggregating-message-kernel + ((message aggregating-message) (combination (eql :custom)) + codegen target methods arg-names + &key (retvar "sod_ret") (valvar "sod_val") + decls before each (first each) after count) + (let* ((type (c-type-subtype (sod-message-type message))) + (not-void-p (not (eq type c-type-void)))) + (when not-void-p + (ensure-var codegen retvar type) + (ensure-var codegen valvar type)) + (when count + (ensure-var codegen count c-type-int (length methods))) + (when decls + (emit-decl codegen decls)) + (labels ((maybe-emit (fragment) + (when fragment (emit-inst codegen fragment))) + (invoke (method fragment) + (invoke-method codegen (if not-void-p valvar :void) + arg-names method) + (maybe-emit fragment))) + (maybe-emit before) + (invoke (car methods) first) + (dolist (method (cdr methods)) (invoke method each)) + (maybe-emit after) + (deliver-expr codegen target retvar)))) + +;;;----- That's all, folks -------------------------------------------------- diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 09dbb2b..6c9b28d 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -40,33 +40,24 @@ inheriting its default behaviour. 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'.")) + reader methods. The actual values are computed on demand.")) -(defmethod slot-unbound (class - (message basic-message) - (slot-name (eql 'argument-tail))) - (declare (ignore class)) +(define-on-demand-slot basic-message argument-tail (message) (let ((seq 0)) - (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))) - (declare (ignore class)) - (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)))) + (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))))) + +(define-on-demand-slot basic-message no-varargs-tail (message) + (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) @@ -98,6 +89,9 @@ (call-next-method) (primary-method-class message))) +(defmethod primary-method-class ((message simple-message)) + 'basic-direct-method) + ;;;-------------------------------------------------------------------------- ;;; Direct method classes. @@ -117,25 +111,21 @@ categorization. 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'.")) + slot reader methods.")) (defmethod shared-initialize :after ((method basic-direct-method) slot-names &key pset) (declare (ignore slot-names)) (default-slot (method 'role) (get-property pset :role :keyword nil))) -(defmethod slot-unbound - (class (method basic-direct-method) (slot-name (eql 'function-type))) - (declare (ignore class)) +(define-on-demand-slot basic-direct-method function-type (method) (let ((type (sod-method-type method))) - (setf (slot-value method 'function-type) - (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (sod-method-class method)))) - . (c-function-arguments type)))))) + (c-type (fun (lisp (c-type-subtype type)) + ("me" (* (class (sod-method-class method)))) + . (c-function-arguments type))))) (defmethod sod-method-function-name ((method basic-direct-method)) - (with-slots (class role message) method + (with-slots ((class %class) role message) method (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role (sod-class-nickname (sod-message-class message)) (sod-message-name message)))) @@ -156,7 +146,7 @@ (defmethod check-method-type ((method daemon-direct-method) (message sod-message) (type c-function-type)) - (with-slots ((msgtype type)) message + (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))) (unless (argument-lists-compatible-p (c-function-arguments msgtype) @@ -181,40 +171,36 @@ its `next_method' function if necessary.) The function type protocol is implemented on `delegating-direct-method' - using slot reader methods. The actual values are computed on demand in - methods defined on `slot-unbound'.")) + using slot reader methods..")) -(defmethod slot-unbound (class - (method delegating-direct-method) - (slot-name (eql 'next-method-type))) - (declare (ignore class)) +(define-on-demand-slot delegating-direct-method next-method-type (method) (let* ((message (sod-method-message method)) - (type (sod-message-type message))) - (setf (slot-value method 'next-method-type) - (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (sod-method-class method)))) - . - (c-function-arguments type)))))) - -(defmethod slot-unbound (class - (method delegating-direct-method) - (slot-name (eql 'function-type))) - (declare (ignore class)) + (return-type (c-type-subtype (sod-message-type message))) + (msgargs (sod-message-argument-tail message)) + (arguments (if (varargs-message-p message) + (cons (make-argument *sod-master-ap* + (c-type va-list)) + (butlast msgargs)) + msgargs))) + (c-type (fun (lisp return-type) + ("me" (* (class (sod-method-class method)))) + . arguments)))) + +(define-on-demand-slot delegating-direct-method function-type (method) (let* ((message (sod-method-message method)) (type (sod-method-type method)) (method-args (c-function-arguments type))) - (setf (slot-value method 'function-type) - (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (sod-method-class method)))) - ("next_method" (* (lisp (commentify-function-type - (sod-method-next-method-type - method))))) - . - (if (varargs-message-p message) - (cons (make-argument *sod-master-ap* - (c-type va-list)) - method-args) - method-args)))))) + (c-type (fun (lisp (c-type-subtype type)) + ("me" (* (class (sod-method-class method)))) + ("next_method" (* (lisp (commentify-function-type + (sod-method-next-method-type + method))))) + . + (if (varargs-message-p message) + (cons (make-argument *sod-master-ap* + (c-type va-list)) + method-args) + method-args))))) ;;;-------------------------------------------------------------------------- ;;; Effective method classes. @@ -238,18 +224,12 @@ 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'.")) + using a slot reader method.")) -(defmethod slot-unbound (class - (method basic-effective-method) - (slot-name (eql 'basic-argument-names))) - (declare (ignore class)) +(define-on-demand-slot basic-effective-method basic-argument-names (method) (let ((message (effective-method-message method))) - (setf (slot-value method 'basic-argument-names) - (subst *sod-master-ap* *sod-ap* - (mapcar #'argument-name - (sod-message-no-varargs-tail message)))))) + (mapcar #'argument-name + (sod-message-no-varargs-tail message)))) (defmethod effective-method-function-name ((method effective-method)) (let* ((class (effective-method-class method)) @@ -260,11 +240,8 @@ (sod-class-nickname message-class) (sod-message-name message)))) -(defmethod slot-unbound - (class (method basic-effective-method) (slot-name (eql 'functions))) - (declare (ignore class)) - (setf (slot-value method 'functions) - (compute-method-entry-functions method))) +(define-on-demand-slot basic-effective-method functions (method) + (compute-method-entry-functions method)) (export 'simple-effective-method) (defclass simple-effective-method (basic-effective-method) @@ -316,23 +293,23 @@ returned by the outermost `around' method -- or, if there are none, delivered by the BODY -- is finally delivered to the TARGET." - (with-slots (message class before-methods after-methods around-methods) + (with-slots (message (class %class) + before-methods after-methods around-methods) method (let* ((message-type (sod-message-type message)) (return-type (c-type-subtype message-type)) - (voidp (eq return-type (c-type void))) (basic-tail (effective-method-basic-argument-names method))) (flet ((method-kernel (target) (dolist (before before-methods) (invoke-method codegen :void basic-tail before)) - (if (or voidp (null after-methods)) + (if (null after-methods) (funcall body target) (convert-stmts codegen target return-type (lambda (target) (funcall body target) (dolist (after (reverse after-methods)) (invoke-method codegen :void - after basic-tail))))))) + basic-tail after))))))) (invoke-delegation-chain codegen target basic-tail around-methods #'method-kernel))))) @@ -349,33 +326,51 @@ effective method out into its own function.") (defmethod method-entry-function-name - ((method effective-method) (chain-head sod-class)) + ((method effective-method) (chain-head sod-class) role) (let* ((class (effective-method-class method)) (message (effective-method-message method)) (message-class (sod-message-class message))) (if (or (not (slot-boundp method 'functions)) (slot-value method 'functions)) - (format nil "~A__mentry_~A__~A__chain_~A" - class + (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A" + class role (sod-class-nickname message-class) (sod-message-name message) (sod-class-nickname chain-head)) 0))) +(defmethod method-entry-slot-name ((entry method-entry)) + (let* ((method (method-entry-effective-method entry)) + (message (effective-method-message method)) + (name (sod-message-name message)) + (role (method-entry-role entry))) + (method-entry-slot-name-by-role entry role name))) + (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))) + (type (sod-message-type message)) + (tail (ecase (method-entry-role entry) + ((nil) (sod-message-argument-tail message)) + (:valist (sod-message-no-varargs-tail 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)) + . tail)))) + +(defmethod make-method-entries ((method basic-effective-method) + (chain-head sod-class) + (chain-tail sod-class)) + (let ((entries nil) + (message (effective-method-message method))) + (flet ((make (role) + (push (make-instance 'method-entry + :method method :role role + :chain-head chain-head + :chain-tail chain-tail) + entries))) + (when (varargs-message-p message) (make :valist)) + (make nil) + entries))) (defmethod compute-method-entry-functions ((method basic-effective-method)) @@ -410,32 +405,25 @@ :class class :method method)) - ;; Effective method function details. - (emf-name (effective-method-function-name method)) - (ilayout-type (c-type (* (struct (ilayout-struct-tag class))))) - (emf-arg-tail (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))) - (emf-type (c-type (fun (lisp return-type) - ("sod__obj" (lisp ilayout-type)) - . (sod-message-no-varargs-tail message)))) - ;; Method entry details. (chain-tails (remove-if-not (lambda (super) (sod-subclass-p super message-class)) (mapcar #'car (sod-class-chains class)))) (n-entries (length chain-tails)) - (entry-args (sod-message-argument-tail message)) - (parm-n (do ((prev "me" (car args)) - (args entry-args (cdr args))) - ((endp args) nil) - (when (eq (car args) :ellipsis) - (return prev)))) - (entry-target (codegen-target codegen))) + (raw-entry-args (sod-message-argument-tail message)) + (entry-args (sod-message-no-varargs-tail message)) + (parm-n (let ((tail (last raw-entry-args 2))) + (and tail (eq (cadr tail) :ellipsis) (car tail)))) + (entry-target (codegen-target codegen)) + + ;; Effective method function details. + (emf-name (effective-method-function-name method)) + (ilayout-type (c-type (* (struct (ilayout-struct-tag class))))) + (emf-arg-tail (sod-message-no-varargs-tail message)) + (emf-type (c-type (fun (lisp return-type) + ("sod__obj" (lisp ilayout-type)) + . emf-arg-tail)))) (flet ((setup-entry (tail) (let ((head (sod-class-chain-head tail))) @@ -443,23 +431,40 @@ (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)) + (role (if parm-n :valist nil)) + (name (method-entry-function-name method head role)) (type (c-type (fun (lisp return-type) ("me" (* (class tail))) . entry-args)))) - (codegen-pop-function codegen name type)))) + (codegen-pop-function codegen name type) + + ;; If this is a varargs method then we've made the + ;; `:valist' role. Also make the `nil' role. + (when parm-n + (let ((call (make-call-inst name + (cons "me" + (mapcar #'argument-name + entry-args)))) + (main (method-entry-function-name method head nil)) + (main-type (c-type (fun (lisp return-type) + ("me" (* (class tail))) + . raw-entry-args)))) + (codegen-push codegen) + (ensure-var codegen *sod-ap* (c-type va-list)) + (emit-inst codegen + (make-va-start-inst *sod-ap* + (argument-name parm-n))) + (convert-stmts codegen entry-target return-type + (lambda (target) + (deliver-expr codegen target call))) + (emit-inst codegen (make-va-end-inst *sod-ap*)) + (codegen-pop-function codegen main main-type)))))) ;; Generate the method body. We'll work out what to do with it later. (codegen-push codegen) - (let* ((result (if (eq return-type (c-type void)) nil + (let* ((result (if (eq return-type c-type-void) nil (temporary-var codegen return-type))) (emf-target (or result :void))) (compute-effective-method-body method codegen emf-target) @@ -474,11 +479,11 @@ (dolist (tail chain-tails) (setup-entry tail) (dolist (var vars) - (ensure-var codegen (inst-name var) - (inst-type var) (inst-init var))) - (when parm-n (varargs-prologue)) + (if (typep var 'var-inst) + (ensure-var codegen (inst-name var) + (inst-type var) (inst-init var)) + (emit-decl codegen var))) (emit-insts codegen insts) - (when parm-n (varargs-epilogue)) (deliver-expr codegen entry-target result) (finish-entry tail))) @@ -496,15 +501,7 @@ emf-arg-tail))))) (dolist (tail chain-tails) (setup-entry tail) - (cond (parm-n - (varargs-prologue) - (convert-stmts codegen entry-target return-type - (lambda (target) - (deliver-expr codegen - target call) - (varargs-epilogue)))) - (t - (deliver-expr codegen entry-target call))) + (deliver-expr codegen entry-target call) (finish-entry tail))))))) (codegen-functions codegen)))) @@ -517,12 +514,11 @@ (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))))) + (basic-effective-method-body codegen target method + (lambda (target) + (simple-method-body method + codegen + target)))) ;;;-------------------------------------------------------------------------- ;;; Standard method combination. @@ -531,7 +527,7 @@ (defclass standard-message (simple-message) () (:documentation - "Message class for standard method combination. + "Message class for standard method combinations. Standard method combination is a simple method combination where the primary methods are invoked as a delegation chain, from most- to diff --git a/src/method-proto.lisp b/src/method-proto.lisp index 51bd1a3..b4b788d 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -32,7 +32,7 @@ (defclass effective-method () ((message :initarg :message :type sod-message :reader effective-method-message) - (class :initarg :class :type sod-class :reader effective-method-class)) + (%class :initarg :class :type sod-class :reader effective-method-class)) (:documentation "The behaviour invoked by sending a message to an instance of a class. @@ -80,19 +80,21 @@ (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) + ((%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)) + :reader method-entry-chain-tail) + (role :initarg :role :type (or :keyword null) :reader method-entry-role)) (: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. + Specifically, this is the entry point to the effective METHOD invoked via + the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE. + 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 @@ -101,16 +103,24 @@ job of the method entry to adjust the instance pointers correctly for the rest of the effective method. + A vtable can contain more than one entry for the same message. Such + entries are distinguished by their roles. A message always has an entry + with the `nil role; in addition, a varargs message also has a `:valist' + role, which accepts a `va_list' argument in place of the variable argument + listNo other roles are currently defined, though they may be introduced by + extensions. + 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) +(export 'make-method-entries) +(defgeneric make-method-entries (effective-method chain-head chain-tail) (:documentation - "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD. + "Return a list of `method-entry' objects 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 @@ -180,6 +190,19 @@ (:documentation "Return the C function type for a method entry.")) +(export 'method-entry-slot-name) +(defgeneric method-entry-slot-name (entry) + (:documentation + "Return the `vtmsgs' slot name for a method entry. + + The default method indirects through `method-entry-slot-name-by-role'.")) + +(defgeneric method-entry-slot-name-by-role (entry role name) + (:documentation "Easier implementation for `method-entry-slot-name'.") + (:method ((entry method-entry) (role (eql nil)) name) name) + (:method ((entry method-entry) (role (eql :valist)) name) + (format nil "~A__v" name))) + (export 'effective-method-basic-argument-names) (defgeneric effective-method-basic-argument-names (method) (:documentation @@ -200,8 +223,8 @@ 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) + (%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. @@ -234,10 +257,13 @@ ;;; Additional instructions. -(export 'convert-to-ilayout) -(definst convert-to-ilayout (stream) (class chain-head expr) +;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the +;; slot names, because `expr' is exported by our package, and `class' is +;; actually from the `common-lisp' package. +(definst convert-to-ilayout (stream :export t) + (#1=#:class chain-head #2=#:expr) (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" - class (sod-class-nickname chain-head) expr)) + #1# (sod-class-nickname chain-head) #2#)) ;;; Utilities. @@ -252,8 +278,7 @@ 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'." + prevailing argument pointer is provided in place of the `:ellipsis'." (let* ((message (sod-method-message direct-method)) (class (sod-method-class direct-method)) @@ -267,14 +292,14 @@ (convert-stmts codegen target (c-type-subtype (sod-method-type direct-method)) (lambda (var) - (ensure-var codegen *sod-ap* (c-type va-list)) + (ensure-var codegen *sod-tmp-ap* (c-type va-list)) (emit-inst codegen - (make-va-copy-inst *sod-ap* - *sod-master-ap*)) + (make-va-copy-inst *sod-tmp-ap* + *sod-ap*)) (deliver-expr codegen var (make-call-inst function arguments)) (emit-inst codegen - (make-va-end-inst *sod-ap*)))) + (make-va-end-inst *sod-tmp-ap*)))) (deliver-expr codegen target (make-call-inst function arguments))))) (export 'ensure-ilayout-var) @@ -311,12 +336,12 @@ (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)))) + (raw-args (sod-message-argument-tail message)) + (arguments (if (varargs-message-p message) + (cons (make-argument *sod-ap* + (c-type va-list)) + (butlast raw-args)) + raw-args))) (codegen-push codegen) (ensure-ilayout-var codegen super) (funcall body (codegen-target codegen)) @@ -334,13 +359,13 @@ "Returns the function name of an effective method.")) (export 'method-entry-function-name) -(defgeneric method-entry-function-name (method chain-head) +(defgeneric method-entry-function-name (method chain-head role) (: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.")) + The method entry is given as an effective method/chain-head/role triple, + 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) @@ -378,7 +403,7 @@ (let* ((message (codegen-message codegen)) (argument-tail (if (varargs-message-p message) - (cons *sod-master-ap* basic-tail) + (cons *sod-tmp-ap* basic-tail) basic-tail))) (labels ((next-trampoline (method chain) (if (or kernel chain) diff --git a/src/module-impl.lisp b/src/module-impl.lisp index 89e1ffb..fe6b545 100644 --- a/src/module-impl.lisp +++ b/src/module-impl.lisp @@ -45,7 +45,7 @@ (defmethod finalize-module ((module module)) (let* ((pset (module-pset module)) - (class (get-property pset :lisp-class :symbol 'module))) + (class (get-property pset :module-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 @@ -167,7 +167,8 @@ (line (file-location-line location)) (filename (file-location-filename location))) (cond (line - (format stream "~&#line ~D~@[ ~S~]~%" line filename) + (when (typep stream 'position-aware-stream) + (format stream "~&#line ~D~@[ ~S~]~%" line filename)) (funcall thunk) (when (typep stream 'position-aware-stream) (fresh-line stream) diff --git a/src/module-parse.lisp b/src/module-parse.lisp index df4ea27..9cad3d4 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -197,9 +197,16 @@ (parse-message-item (sub-pset type name) ;; message-item ::= ;; declspec+ declarator -!- (method-body | `;') - (make-sod-message class name type sub-pset scanner) - (parse (or #\; (parse-method-item sub-pset - type nick name)))) + ;; + ;; Don't allow a method-body here if the message takes a + ;; varargs list, because we don't have a name for the + ;; `va_list' parameter. + (let ((message (make-sod-message class name type + sub-pset scanner))) + (if (varargs-message-p message) + (parse #\;) + (parse (or #\; (parse-method-item sub-pset + type nick name)))))) (parse-method-item (sub-pset type sub-nick name) ;; method-item ::= @@ -335,13 +342,13 @@ ;; (which might be dotted). So we parse that here and ;; dispatch based on what we find. (parse (or (plug class-item scanner class sub-pset) - ;(peek + (peek (seq ((ds (parse-c-type scanner)) (dc (parse-maybe-dotted-declarator ds)) (nil (class-item-dispatch sub-pset ds (car dc) - (cdr dc)))));) + (cdr dc)))))) (and "class" (parse-initializer-item sub-pset diff --git a/src/module-proto.lisp b/src/module-proto.lisp index 4152329..9c7fcaf 100644 --- a/src/module-proto.lisp +++ b/src/module-proto.lisp @@ -101,7 +101,7 @@ During module 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' + an instance of whatever type is requested in the module's `:module-class' property.") (export 'module-import) @@ -135,9 +135,9 @@ 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 + according to the class choice set in the module's `:module-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.)")) @@ -148,7 +148,8 @@ (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) + (%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) diff --git a/src/output-proto.lisp b/src/output-proto.lisp index 3483daa..65068f3 100644 --- a/src/output-proto.lisp +++ b/src/output-proto.lisp @@ -119,6 +119,7 @@ ;;;-------------------------------------------------------------------------- ;;; Useful syntax. +(export 'sequence-output) (defmacro sequence-output ((streamvar sequencer) &body clauses) "Register output behaviour in a convenient manner. diff --git a/src/package.lisp b/src/package.lisp index a6b9785..d6e47f4 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -31,7 +31,7 @@ (cl:in-package #:sod) (export '*sod-version*) -(defvar *sod-version* (asdf:component-version (asdf:find-system "sod")) +(defparameter *sod-version* sod-sysdef:*version* "The version of the SOD translator system, as a string.") ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index ca5aaee..1c3c930 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -58,8 +58,8 @@ (export '(enclosing-condition enclosed-condition)) (define-condition enclosing-condition (condition) - ((enclosed-condition :initarg :condition :type condition - :reader enclosed-condition)) + ((%enclosed-condition :initarg :condition :type condition + :reader enclosed-condition)) (:documentation "A condition which encloses another condition diff --git a/src/parser/parser-expr-impl.lisp b/src/parser/parser-expr-impl.lisp index e0c681b..5ae4035 100644 --- a/src/parser/parser-expr-impl.lisp +++ b/src/parser/parser-expr-impl.lisp @@ -116,14 +116,14 @@ (defmethod apply-operator ((operator simple-unary-operator) (state expression-parse-state)) - (with-slots (function) operator + (with-slots ((function %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 ((function %function)) operator (with-slots (valstack) state (assert (not (or (null valstack) (null (cdr valstack))))) diff --git a/src/parser/parser-expr-proto.lisp b/src/parser/parser-expr-proto.lisp index 7fc2609..ec35445 100644 --- a/src/parser/parser-expr-proto.lisp +++ b/src/parser/parser-expr-proto.lisp @@ -154,7 +154,7 @@ (export 'simple-operator) (defclass simple-operator () - ((function :initarg :function :reader operator-function) + ((%function :initarg :function :reader operator-function) (name :initarg :name :initform "" :reader operator-name)) (:documentation diff --git a/src/parser/parser-impl.lisp b/src/parser/parser-impl.lisp index 0a7d667..352a725 100644 --- a/src/parser/parser-impl.lisp +++ b/src/parser/parser-impl.lisp @@ -129,12 +129,12 @@ (export 'string-parser) (defclass string-parser (character-parser-context) - ((string :initarg :string :reader parser-string) + ((%string :initarg :string :reader parser-string) (index :initarg :index :initform 0 :reader parser-index) - (length :initform (gensym "LEN-") :reader parser-length))) + (%length :initform (gensym "LEN-") :reader parser-length))) (defmethod wrap-parser ((context string-parser) form) - (with-slots (string index length) context + (with-slots ((string %string) index (length %length)) context `(let* (,@(unless (symbolp string) (let ((s string)) (setf string (gensym "STRING-")) diff --git a/src/parser/parser-test.lisp b/src/parser/parser-test.lisp index 1fb292d..4041586 100644 --- a/src/parser/parser-test.lisp +++ b/src/parser/parser-test.lisp @@ -38,6 +38,7 @@ (once-only (string value winp consumedp) (with-gensyms (my-value my-winp my-consumedp label what) `(let ((,scanner (make-string-scanner ,string))) + (declare (ignorable ,scanner)) (multiple-value-bind (,my-value ,my-winp ,my-consumedp) (with-parser-context (character-scanner-context :scanner ,scanner) diff --git a/src/parser/scanner-charbuf-impl.lisp b/src/parser/scanner-charbuf-impl.lisp index 65f6e1e..1919b69 100644 --- a/src/parser/scanner-charbuf-impl.lisp +++ b/src/parser/scanner-charbuf-impl.lisp @@ -65,7 +65,7 @@ (export 'charbuf-scanner) (defclass charbuf-scanner (character-scanner) - ((stream :initarg :stream :type stream) + ((%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)) @@ -143,7 +143,7 @@ (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 + (with-slots ((stream %stream) buf size index tail captures) scanner (loop (acond @@ -254,7 +254,7 @@ ;; 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 + (with-slots ((stream %stream)) scanner (aif (stream-pathname stream) (namestring it) nil))) ;; Get ready with the first character. diff --git a/src/parser/scanner-impl.lisp b/src/parser/scanner-impl.lisp index 0849648..2abdff4 100644 --- a/src/parser/scanner-impl.lisp +++ b/src/parser/scanner-impl.lisp @@ -62,12 +62,15 @@ (defstruct (string-scanner (:constructor make-string-scanner (string &key (start 0) end - &aux (index start) + &aux (%string string) + (index start) (limit (or end (length string)))))) "Scanner structure for a simple string scanner." - (string "" :type string :read-only t) + (%string "" :type string :read-only t) (index 0 :type (and fixnum unsigned-byte)) (limit nil :type (and fixnum unsigned-byte) :read-only t)) +(define-access-wrapper string-scanner-string string-scanner-%string + :read-only t) (defmethod scanner-at-eof-p ((scanner string-scanner)) (>= (string-scanner-index scanner) (string-scanner-limit scanner))) @@ -86,7 +89,7 @@ (defmethod scanner-interval ((scanner string-scanner) place-a &optional place-b) - (with-slots (string index) scanner + (with-slots ((string %string) index) scanner (subseq string place-a (or place-b index)))) ;;;-------------------------------------------------------------------------- @@ -94,13 +97,14 @@ (export 'list-scanner) (defstruct (list-scanner - (:constructor make-list-scanner (list))) + (:constructor make-list-scanner (list &aux (%list 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)) + (%list nil :type list)) +(define-access-wrapper list-scanner-list list-scanner-%list) (defmethod scanner-step ((scanner list-scanner)) (pop (list-scanner-list scanner))) diff --git a/src/parser/scanner-proto.lisp b/src/parser/scanner-proto.lisp index d590d77..bd7e160 100644 --- a/src/parser/scanner-proto.lisp +++ b/src/parser/scanner-proto.lisp @@ -176,7 +176,7 @@ (export '(token-scanner token-type token-value)) (defclass token-scanner () - ((type :reader token-type) + ((%type :reader token-type) (value :reader token-value) (captures :initform 0 :type fixnum) (tail :initform nil :type (or token-scanner-place null)) @@ -206,7 +206,10 @@ ;; A place marker. (export '(token-scanner-place token-scanner-place-p)) -(defstruct token-scanner-place +(defstruct (token-scanner-place + (:constructor make-token-scanner-place + (&key scanner next type value line column + &aux (%type type)))) "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 @@ -220,10 +223,12 @@ (scanner nil :type token-scanner :read-only t) (next nil :type (or token-scanner-place null)) - (type nil :read-only t) + (%type nil :read-only t) (value nil :read-only t) (line 1 :type (or fixnum null) :read-only t) (column 0 :type (or fixnum null) :read-only t)) +(define-access-wrapper token-scanner-place-type token-scanner-place-%type + :read-only t) ;; Protocol. diff --git a/src/parser/scanner-token-impl.lisp b/src/parser/scanner-token-impl.lisp index 8ab427a..7629b2d 100644 --- a/src/parser/scanner-token-impl.lisp +++ b/src/parser/scanner-token-impl.lisp @@ -39,11 +39,11 @@ (scanner-step scanner)) (defmethod scanner-at-eof-p ((scanner token-scanner)) - (with-slots (type) scanner + (with-slots ((type %type)) scanner (eq type :eof))) (defmethod scanner-step ((scanner token-scanner)) - (with-slots (type value tail captures line column) scanner + (with-slots ((type %type) value tail captures line column) scanner (acond ((and tail (token-scanner-place-next tail)) (setf type (token-scanner-place-type it) value (token-scanner-place-value it) @@ -64,7 +64,7 @@ (setf tail nil))))))) (defmethod scanner-capture-place ((scanner token-scanner)) - (with-slots (type value captures tail line column) scanner + (with-slots ((type %type) value captures tail line column) scanner (incf captures) (or tail (setf tail (make-token-scanner-place :scanner scanner @@ -72,7 +72,7 @@ :line line :column column))))) (defmethod scanner-restore-place ((scanner token-scanner) place) - (with-slots (type value tail line column) scanner + (with-slots ((type %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) diff --git a/src/pset-parse.lisp b/src/pset-parse.lisp index f81ce92..11b4003 100644 --- a/src/pset-parse.lisp +++ b/src/pset-parse.lisp @@ -82,7 +82,8 @@ expression: term | expression `+' term | expression `-' term term: factor | term `*' factor | term `/' factor factor: primary | `+' factor | `-' factor - primary: int | id | string | `(' expression `)' | `?' lisp-expression + primary: int | id | string | `(' expression `)' | `{' fragment `}' + | `?' lisp-expression Only operators for dealing with integers are provided." (with-parser-context (token-scanner-context :scanner scanner) @@ -101,6 +102,11 @@ (multiple-value-bind (type value) (decode-property sexp) (values (cons type value) t t)))) + (#\{ + (values (cons :fragment + (parse-delimited-fragment scanner + #\{ #\})) + t t)) (t (values (list :int :id :char :string #\?) nil nil))))) diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp index 0c133d6..e58a928 100644 --- a/src/pset-proto.lisp +++ b/src/pset-proto.lisp @@ -45,7 +45,7 @@ (:constructor %make-property (name value &key type location seenp - &aux (key (property-key name))))) + &aux (key (property-key name)) (%type type)))) "A simple structure for holding a property in a property set. The main useful feature is the ability to tick off properties which have @@ -57,10 +57,11 @@ (name nil :type (or string symbol)) (value nil :type t) - (type nil :type symbol) + (%type nil :type symbol) (location (file-location nil) :type file-location) (key nil :type symbol) (seenp nil :type boolean)) +(define-access-wrapper p-type p-%type) (export 'decode-property) (defgeneric decode-property (raw) diff --git a/src/sod-frontend.asd b/src/sod-frontend.asd.in similarity index 95% rename from src/sod-frontend.asd rename to src/sod-frontend.asd.in index 6ba17cd..b81fd2d 100644 --- a/src/sod-frontend.asd +++ b/src/sod-frontend.asd.in @@ -28,15 +28,18 @@ (cl:in-package #:sod-sysdef) +#|@-auto-@|# (load "auto.lisp") + ;;;-------------------------------------------------------------------------- ;;; Definition. (defsystem sod-frontend ;; Boring copyright stuff. - :version "1.0.0" + :version #.*sysdef-version* :author "Mark Wooding" :license "GNU General Public License, version 2 or later" + #|@-path-@|# :pathname "@srcdir@" ;; Documentation. :description "A Sensible Object Design for C, command-line frontend." diff --git a/src/sod-test.asd b/src/sod-test.asd.in similarity index 87% rename from src/sod-test.asd rename to src/sod-test.asd.in index a0a3972..6b2a83b 100644 --- a/src/sod-test.asd +++ b/src/sod-test.asd.in @@ -23,10 +23,12 @@ ;;; 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 +(cl:defpackage #:sod-sysdef (:use #:common-lisp #:asdf)) -(cl:in-package #:sod-test-sysdef) +(cl:in-package #:sod-sysdef) + +#|@-auto-@|# (load "auto.lisp") ;;;-------------------------------------------------------------------------- ;;; Definition. @@ -34,9 +36,10 @@ (defsystem sod-test ;; Boring copyright stuff. - :version "1.0.0" + :version #:*sysdef-version* :author "Mark Wooding" :license "GNU General Public License, version 2 or later" + #|@-path-@|# :pathname "@srcdir@" ;; Documentation. :description "Tests for the Sensible Object Design translator." @@ -68,6 +71,8 @@ (declare (ignore cond)) (invoke-restart 'muffle-warning)))) (operate 'load-op system) - (funcall (find-symbol "RUN-TESTS" "SOD-TEST")))) + (let ((result (funcall (find-symbol "RUN-TESTS" "SOD-TEST")))) + (unless (funcall (find-symbol "WAS-SUCCESSFUL" "XLUNIT") result) + (error "Failed test"))))) ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/sod.asd b/src/sod.asd.in similarity index 93% rename from src/sod.asd rename to src/sod.asd.in index a618e39..d710fb1 100644 --- a/src/sod.asd +++ b/src/sod.asd.in @@ -24,19 +24,23 @@ ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (cl:defpackage #:sod-sysdef - (:use #:common-lisp #:asdf)) + (:use #:common-lisp #:asdf) + (:export #:*version*)) (cl:in-package #:sod-sysdef) +#|@-auto-@|# (load "auto.lisp") + ;;;-------------------------------------------------------------------------- ;;; Definition. (defsystem sod ;; Boring copyright stuff. - :version "0.1.0" + :version #.*sysdef-version* :author "Mark Wooding" :license "GNU General Public License, version 2 or later" + #|@-path-@|# :pathname "@srcdir@" ;; Documentation. :description "A Sensible Object Design for C." @@ -156,13 +160,16 @@ (:file "class-finalize-impl" :depends-on ("class-finalize-proto")) ;; Method generation. - (:file "method-proto" :depends-on ("class-utilities")) + (:file "method-proto" :depends-on ("class-make-proto")) (:file "method-impl" :depends-on ("method-proto")) + (:file "method-aggregate" :depends-on ("method-impl")) ;; Class output. (:file "class-output" :depends-on - ("classes" "class-layout-proto" "class-layout-impl" - "method-proto" "method-impl" "output-proto")))) + ("classes" "class-layout-impl" "method-impl" "output-proto")) + + ;; Finishing touches of various kinds. + (:file "final" :depends-on ("builtin" "module-output")))) ;;;-------------------------------------------------------------------------- ;;; Testing. diff --git a/src/test-base.lisp b/src/test-base.lisp index ffc8e19..203f918 100644 --- a/src/test-base.lisp +++ b/src/test-base.lisp @@ -52,6 +52,9 @@ rather than `~A'." object print string)))) +(defclass base-test (test-case) ()) +(add-test *sod-test-suite* (get-suite base-test)) + (defun run-tests (&optional which) (textui-test-run (acond ((null which) *sod-test-suite*) diff --git a/src/utilities.lisp b/src/utilities.lisp index be5ce56..98d314a 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -694,6 +694,38 @@ ,(loopguts indexvar t nil)))))))))) ;;;-------------------------------------------------------------------------- +;;; Structure accessor hacks. + +(export 'define-access-wrapper) +(defmacro define-access-wrapper (from to &key read-only) + "Make (FROM THING) work like (TO THING). + + If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like + (setf (TO THING) VALUE). + + This is mostly useful for structure slot accessors where the slot has to + be given an unpleasant name to avoid it being an external symbol." + `(progn + (declaim (inline ,from ,@(and (not read-only) `((setf ,from))))) + (defun ,from (object) + (,to object)) + ,@(and (not read-only) + `((defun (setf ,from) (value object) + (setf (,to object) value)))))) + +(export 'define-on-demand-slot) +(defmacro define-on-demand-slot (class slot (instance) &body body) + "Defines a slot which computes its initial value on demand. + + Sets up the named SLOT of CLASS to establish its value as the implicit + progn BODY, by defining an appropriate method on `slot-unbound'." + (with-gensyms (classvar slotvar) + `(defmethod slot-unbound + (,classvar (,instance ,class) (,slotvar (eql ',slot))) + (declare (ignore ,classvar)) + (setf (slot-value ,instance ',slot) (progn ,@body))))) + +;;;-------------------------------------------------------------------------- ;;; CLOS hacking. (export 'default-slot) diff --git a/test/chimaera.ref b/test/chimaera.ref index 1842c08..897e953 100644 --- a/test/chimaera.ref +++ b/test/chimaera.ref @@ -30,7 +30,13 @@ provoking Chimaera as a serpent Nom! tickle Chimaera #0... Munch! +Bonk! +Sssss! tickle Chimaera #1... Munch! +Bonk! +Sssss! tickle Chimaera #2... Munch! +Bonk! +Nom! diff --git a/test/chimaera.sod b/test/chimaera.sod index ca775bc..e9b9077 100644 --- a/test/chimaera.sod +++ b/test/chimaera.sod @@ -16,28 +16,29 @@ code h : includes { class Animal : SodObject { int tickles = 0; - void tickle(void) { } + [combination = progn] + void tickle(); [role = before] - void nml.tickle(void) { me->nml.tickles++; } + void nml.tickle() { me->nml.tickles++; } } class Lion : Animal { - void bite(void) { puts("Munch!"); } - void nml.tickle(void) { me->_vt->lion.bite(me); } + void bite() { puts("Munch!"); } + void nml.tickle() { Lion_bite(me); } } class Goat : Animal { - void butt(void) { puts("Bonk!"); } - void nml.tickle(void) { me->_vt->goat.butt(me); } + void butt() { puts("Bonk!"); } + void nml.tickle() { Goat_butt(me); } } class Serpent : Animal { - void hiss(void) { puts("Sssss!"); } - void bite(void) { puts("Nom!"); } - void nml.tickle(void) { - if (SERPENT__CONV_NML(me)->nml.tickles > 2) me->_vt->serpent.bite(me); - else me->_vt->serpent.hiss(me); + void hiss() { puts("Sssss!"); } + void bite() { puts("Nom!"); } + void nml.tickle() { + if (SERPENT__CONV_NML(me)->nml.tickles <= 2) Serpent_hiss(me); + else Serpent_bite(me); } } @@ -54,32 +55,28 @@ static void tickle_animal(Animal *a) for (i = 0; i < 3; i++) { printf("tickle %s #%d...\n", a->_vt->_class->cls.name, i); - a->_vt->nml.tickle(a); + Animal_tickle(a); } } static void provoke_lion(Lion *l) { printf("provoking %s as a lion\n", l->_vt->_class->cls.name); - l->_vt->lion.bite(l); + Lion_bite(l); } static void provoke_goat(Goat *g) { printf("provoking %s as a goat\n", g->_vt->_class->cls.name); - g->_vt->goat.butt(g); + Goat_butt(g); } static void provoke_serpent(Serpent *s) { printf("provoking %s as a serpent\n", s->_vt->_class->cls.name); - s->_vt->serpent.bite(s); + Serpent_bite(s); } -#define SOD_DECL(cls_, var_) \ - struct cls_##__ilayout var_##__layout; \ - cls_ *var_ = cls_##__class->cls.init(&var_##__layout) - int main(void) { { diff --git a/vars.am b/vars.am index 7e2a89f..7e7406c 100644 --- a/vars.am +++ b/vars.am @@ -43,6 +43,8 @@ bin_PROGRAMS = check_PROGRAMS = pkginclude_HEADERS = +dist_man_MANS = + CLEANFILES += $(BUILT_SOURCES) ###-------------------------------------------------------------------------- @@ -55,14 +57,51 @@ AM_CPPFLAGS = $(SOD_INCLUDES) LDADD = $(top_builddir)/lib/libsod.la ###-------------------------------------------------------------------------- +### Standard configuration substitutions. + +## Substitute tags in files. +confsubst = $(top_srcdir)/config/confsubst + +SUBSTITUTIONS = \ + prefix=$(prefix) exec_prefix=$(exec_prefix) \ + libdir=$(libdir) includedir=$(includedir) \ + bindir=$(bindir) sbindir=$(sbindir) \ + srcdir=$(srcdir) \ + PACKAGE=$(PACKAGE) VERSION=$(VERSION) ASDF_VERSION=$(ASDF_VERSION) + +V_SUBST = $(V_SUBST_$(V)) +V_SUBST_ = $(V_SUBST_$(AM_DEFAULT_VERBOSITY)) +V_SUBST_0 = @echo " SUBST $@"; +SUBST = $(V_SUBST)$(confsubst) + +###-------------------------------------------------------------------------- ### Translating SOD input files. ## The tool location. SOD = $(top_builddir)/src/sod +## Silent rules treatment. +V_SOD_c = $(V_SOD_c_$(V)) +V_SOD_c_ = $(V_SOD_c_$(AM_DEFAULT_VERBOSITY)) +V_SOD_c_0 = @echo " SOD[c] $@"; +V_SOD_h = $(V_SOD_h_$(V)) +V_SOD_h_ = $(V_SOD_h_$(AM_DEFAULT_VERBOSITY)) +V_SOD_h_0 = @echo " SOD[h] $@"; + ## Build rules. SUFFIXES += .c .h .sod -.sod.c: $(SOD); $(SOD) -tc $< -.sod.h: $(SOD); $(SOD) -th $< +.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $< +.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $< + +###-------------------------------------------------------------------------- +### Silent rules for Lisp. + +V_DUMP = $(V_DUMP_$(V)) +V_DUMP_ = $(V_DUMP_$(AM_DEFAULT_VERBOSITY)) +V_DUMP_0 = @echo " DUMP $@"; + +V_TEST = $(V_TEST_$(V)) +V_TEST_ = $(V_TEST_$(AM_DEFAULT_VERBOSITY)) +V_TEST_0 = @echo " TEST $@"; ###----- That's all, folks --------------------------------------------------