/autom4te.cache/
/config/
/configure
+/doc/SYMBOLS
COPYING
COPYING.LIB
config/auto-version
+config/confsubst
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.
## 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 --------------------------------------------------
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],
--- /dev/null
+sod (0.2.0) experimental; urgency=low
+
+ * Initial Debian packaging.
+
+ -- Mark Wooding <mdw@distorted.org.uk> Sun, 06 Sep 2015 22:38:24 +0100
--- /dev/null
+Source: sod
+Section: devel
+Priority: extra
+Maintainer: Mark Wooding <mdw@distorted.org.uk>
+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.
--- /dev/null
+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.
--- /dev/null
+/usr/include/sod
+/usr/lib/*/libsod.a
+/usr/lib/*/libsod.la
+/usr/lib/*/libsod.so
+/usr/lib/*/pkgconfig
--- /dev/null
+/usr/lib/*/libsod.so.*
--- /dev/null
+#! /usr/bin/make -f
+%:; dh $@ --parallel -Bdebian/build
--- /dev/null
+/usr/share/common-lisp
--- /dev/null
+/usr/bin/sod
--- /dev/null
+(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"))))
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 --------------------------------------------------
--- /dev/null
+.\" -*-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 <sod/sod.h>
+
+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, <mdw@distorted.org.uk>
+.
+.\"----- That's all, folks --------------------------------------------------
--- /dev/null
+.\" -*-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 <sod/sod.h>
+.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, <mdw@distorted.org.uk>
+.
+.\"----- That's all, folks --------------------------------------------------
*
* 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 ------------------------------------------------------*/
*
* 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
* 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,
* 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@ --- *
*
((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@ --- *
#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@ --- *
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Builtin module provides basic definitions
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; 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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 "~:@<CLASS ~@_~S~{ ~_~S~}~:>"
- (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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
- (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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;;--------------------------------------------------------------------------
-;;; 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
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-(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=))))
+++ /dev/null
-;;;
-(write-line "stuff's a-goin' on")
+++ /dev/null
-;;; -*-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) "<end-of-file>")
- ((eql :string) "<string-literal>")
- ((eql :char) "<character-literal>")
- ((eql :id) (format nil "<identifier~@[ `~A'~]>" 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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 <class-item>; found ~A (skipped)"
- (format-token lexer))
- (next-token lexer))
- ((string= (token-value lexer) "class")
- (next-token lexer)
- (parse-initializers #'make-sod-class-initializer
- pset location))
- (t
- (parse-initializers #'make-sod-instance-initializer
- pset location)))))
-
- (parse-method (type nick name pset location)
- "class-item ::= declspec+ dotted-declarator -!- method-body
-
- method-body ::= `{' c-fragment `}' | `extern' `;'
-
- The dotted-declarator must describe a function type."
- (let ((body (cond ((eq (token-type lexer) #\{)
- (prog1 (scan-c-fragment lexer '(#\}))
- (next-token lexer)
- (require-token lexer #\})))
- ((and (eq (token-type lexer) :id)
- (string= (token-value lexer)
- "extern"))
- (next-token lexer)
- (require-token lexer #\;)
- nil)
- (t
- (cerror* "Expected <method-body>; ~
- found ~A"
- (format-token lexer))))))
- (make-sod-method class nick name type body pset location)))
-
- (parse-message (type name pset location)
- "class-item ::= declspec+ declarator -!- (method-body | `;')
-
- The declarator must describe a function type."
- (make-sod-message class name type pset location)
- (unless (require-token lexer #\; :errorp nil)
- (parse-method type nick name nil location)))
-
- (parse-initializer-body ()
- "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
- (let ((char (lexer-char lexer)))
- (loop
- (when (or (null char) (not (whitespace-char-p char)))
- (return))
- (setf char (next-char lexer)))
- (cond ((eql char #\{)
- (next-char lexer)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (values :compound frag)))
- (t
- (let ((frag (scan-c-fragment lexer '(#\, #\;))))
- (next-token lexer)
- (values :simple frag))))))
-
- (parse-slots (declspec type name pset location)
- "class-item ::=
- declspec+ init-declarator [`,' init-declarator-list] `;'
-
- init-declarator ::= declarator -!- [initializer]"
- (loop
- (make-sod-slot class name type pset location)
- (when (eql (token-type lexer) #\=)
- (multiple-value-bind (kind form) (parse-initializer-body)
- (make-sod-instance-initializer class nick name
- kind form nil
- location)))
- (unless (require-token lexer #\, :errorp nil)
- (return))
- (setf (values type name)
- (parse-c-declarator lexer declspec)
- location (file-location lexer)))
- (require-token lexer #\;))
-
- (parse-initializers (constructor pset location)
- "class-item ::= [`class'] -!- slot-initializer-list `;'
-
- slot-initializer ::= id `.' id initializer"
- (loop
- (let ((nick (prog1 (require-token lexer :id)
- (require-token lexer #\.)))
- (name (require-token lexer :id)))
- (require-token lexer #\=)
- (multiple-value-bind (kind form)
- (parse-initializer-body)
- (funcall constructor class nick name kind form
- pset location)))
- (unless (require-token lexer #\, :errorp nil)
- (return))
- (setf location (file-location lexer)))
- (require-token lexer #\;)))
-
- (loop
- (when (require-token lexer #\} :errorp nil)
- (return))
- (parse-item)))
-
- (finalize-sod-class class)
- (add-to-module *module* class)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 "<string>"
- :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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 "~:[<unnamed>~;~:*~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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; 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)))))
-
+++ /dev/null
-;;; -*-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 --------------------------------------------------
+++ /dev/null
-;;; -*-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 --------------------------------------------------
--- /dev/null
+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}
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
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.
## 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 \
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 --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+
+(defparameter *version* "@VERSION@"
+ "The official Sod revision number.")
+
+(defparameter *sysdef-version* "@ASDF_VERSION@"
+ "The Sod revision number, forced into ASDF's limited format.")
',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)
{
struct ~A *sod__obj = p;
- ~:{sod__obj->~A.~A._vt = &~A;~:^~% ~}
+ ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~}
return (p);
}~2%"
class
(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)
(bootstrap-classes module))
(setf *builtin-module* module)))
+(define-clear-the-decks builtin-module
+ (unless *builtin-module* (make-builtin-module)))
+
;;;----- That's all, folks --------------------------------------------------
(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.
(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
(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.
(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)
(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: `('
;; 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 #\))))))
(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 `)'
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
;;; 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)
(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)
(: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 --------------------------------------------------
(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))
(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.
(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.
(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
(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 --------------------------------------------------
(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))
(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
(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
(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))
(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.
;;; 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)
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
(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
(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
(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
(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
: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.
(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
(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
(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))
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
(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
(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"
"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
(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
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
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
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
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
"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)
(class :ichains :start) (class :ichains :end)
(class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
(class :conversions)
+ (class :message-macros)
(class :object)
(:classes :end))
(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))
(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. */~@
(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)
(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;~%"
(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;~%"
(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;~%"
(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)))
(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)
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 "~@<extern const struct ~A ~2I~_~A__vtable_~A;~:>~%"
- (vtable-struct-tag chain-tail chain-head)
+ (format stream "~@<extern const union ~A ~2I~_~A__vtable_~A;~:>~%"
+ (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;~%"
(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)
(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~];~%"
(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)))))
(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;~%"
(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)
(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)
(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)
;;; 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)
(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)
(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)
(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)
(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)
(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.
(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)
(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)
(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))
(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)
(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)))
(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)))
(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 --------------------------------------------------
(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.
(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)
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)
((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.
((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
((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.
((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.
(defmethod commentify-argument-name ((name temporary-name))
nil)
-(export 'temporary-function)
(defun temporary-function ()
"Return a temporary function name."
(make-instance 'temporary-function
;; 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.
(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)))
(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
;; Root class.
-(export 'temporary-name)
+(export '(temporary-name temp-tag))
(defclass temporary-name ()
((tag :initarg :tag :reader temp-tag))
(:documentation
(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.
;; 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
* 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
,(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
(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.
(: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
--- /dev/null
+;;; -*-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 --------------------------------------------------
(cl:in-package #:sod-frontend)
;;;--------------------------------------------------------------------------
+;;; Preparation for dumping.
+
+(clear-the-decks)
+(exercise)
+
+;;;--------------------------------------------------------------------------
;;; The main program.
(eval-when (:compile-toplevel :load-toplevel :execute)
: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))
(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 ()
;; 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.
--- /dev/null
+;;; -*-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 --------------------------------------------------
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)
(call-next-method)
(primary-method-class message)))
+(defmethod primary-method-class ((message simple-message))
+ 'basic-direct-method)
+
;;;--------------------------------------------------------------------------
;;; Direct method classes.
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))))
(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)
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.
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))
(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)
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)))))
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))
: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)))
(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)
(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)))
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))))
(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.
(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
(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.
(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
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
(: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
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.
;;; 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.
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))
(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)
(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))
"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)
(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)
(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
(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)
(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 ::=
;; (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
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)
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.)"))
(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)
;;;--------------------------------------------------------------------------
;;; Useful syntax.
+(export 'sequence-output)
(defmacro sequence-output
((streamvar sequencer) &body clauses)
"Register output behaviour in a convenient manner.
(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 --------------------------------------------------
(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
(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)))))
(export 'simple-operator)
(defclass simple-operator ()
- ((function :initarg :function :reader operator-function)
+ ((%function :initarg :function :reader operator-function)
(name :initarg :name :initform "<unnamed operator>"
:reader operator-name))
(:documentation
(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-"))
(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)
(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))
(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
;; 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.
(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)))
(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))))
;;;--------------------------------------------------------------------------
(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)))
(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))
;; 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
(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.
(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)
(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
: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)
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)
(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)))))
(: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
(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)
(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."
;;; 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.
(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."
(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 --------------------------------------------------
;;; 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."
(: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.
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*)
,(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)
Nom!
tickle Chimaera #0...
Munch!
+Bonk!
+Sssss!
tickle Chimaera #1...
Munch!
+Bonk!
+Sssss!
tickle Chimaera #2...
Munch!
+Bonk!
+Nom!
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);
}
}
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)
{
{
check_PROGRAMS =
pkginclude_HEADERS =
+dist_man_MANS =
+
CLEANFILES += $(BUILT_SOURCES)
###--------------------------------------------------------------------------
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 --------------------------------------------------
~mdw / sod / commitdiff