/autom4te.cache/
/config/
/configure
+/doc/SYMBOLS
POST_UNINSTALL = :
build_triplet = @build@
host_triplet = @host@
-DIST_COMMON = $(am__configure_deps) $(pkginclude_HEADERS) \
- $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
- $(top_srcdir)/configure $(top_srcdir)/vars.am COPYING \
- COPYING.LIB config/config.guess config/config.sub \
- config/depcomp config/install-sh config/ltmain.sh \
- config/missing
+DIST_COMMON = $(am__configure_deps) $(dist_man_MANS) \
+ $(pkginclude_HEADERS) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.in $(top_srcdir)/configure \
+ $(top_srcdir)/vars.am COPYING COPYING.LIB config/config.guess \
+ config/config.sub config/depcomp config/install-sh \
+ config/ltmain.sh config/missing
bin_PROGRAMS =
check_PROGRAMS =
subdir = .
SUFFIXES = .c .h .sod
BUILT_SOURCES =
pkginclude_HEADERS =
+dist_man_MANS =
###--------------------------------------------------------------------------
### Include and library path.
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.69 for sod 0.2.0.
+# Generated by GNU Autoconf 2.69 for sod 0.2.0-29-g54c0.
#
# Report bugs to <mdw@distorted.org.uk>.
#
# Identity of this package.
PACKAGE_NAME='sod'
PACKAGE_TARNAME='sod'
-PACKAGE_VERSION='0.2.0'
-PACKAGE_STRING='sod 0.2.0'
+PACKAGE_VERSION='0.2.0-29-g54c0'
+PACKAGE_STRING='sod 0.2.0-29-g54c0'
PACKAGE_BUGREPORT='mdw@distorted.org.uk'
PACKAGE_URL=''
# Omit some internal or obsolete options to make the list less imposing.
# This message is too long to be a string in the A/UX 3.1 sh.
cat <<_ACEOF
-\`configure' configures sod 0.2.0 to adapt to many kinds of systems.
+\`configure' configures sod 0.2.0-29-g54c0 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of sod 0.2.0:";;
+ short | recursive ) echo "Configuration of sod 0.2.0-29-g54c0:";;
esac
cat <<\_ACEOF
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-sod configure 0.2.0
+sod configure 0.2.0-29-g54c0
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by sod $as_me 0.2.0, which was
+It was created by sod $as_me 0.2.0-29-g54c0, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
# Define the identity of the package.
PACKAGE='sod'
- VERSION='0.2.0'
+ VERSION='0.2.0-29-g54c0'
cat >>confdefs.h <<_ACEOF
# report actual input values of CONFIG_FILES etc. instead of their
# values after options handling.
ac_log="
-This file was extended by sod $as_me 0.2.0, which was
+This file was extended by sod $as_me 0.2.0-29-g54c0, which was
generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-sod config.status 0.2.0
+sod config.status 0.2.0-29-g54c0
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
--- /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"))))
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 --------------------------------------------------
POST_UNINSTALL = :
build_triplet = @build@
host_triplet = @host@
-DIST_COMMON = $(pkginclude_HEADERS) $(srcdir)/Makefile.am \
- $(srcdir)/Makefile.in $(top_srcdir)/vars.am
+DIST_COMMON = $(dist_man_MANS) $(pkginclude_HEADERS) \
+ $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
+ $(top_srcdir)/vars.am
bin_PROGRAMS =
check_PROGRAMS =
subdir = lib
$(am__cd) "$$dir" && rm -f $$files; }; \
}
am__installdirs = "$(DESTDIR)$(libdir)" "$(DESTDIR)$(bindir)" \
- "$(DESTDIR)$(pkgincludedir)" "$(DESTDIR)$(pkgincludedir)"
+ "$(DESTDIR)$(man3dir)" "$(DESTDIR)$(pkgincludedir)" \
+ "$(DESTDIR)$(pkgincludedir)"
LTLIBRARIES = $(lib_LTLIBRARIES)
libsod_la_LIBADD =
am_libsod_la_OBJECTS = sod.lo
n|no|NO) false;; \
*) (install-info --version) >/dev/null 2>&1;; \
esac
+man3dir = $(mandir)/man3
+NROFF = nroff
+MANS = $(dist_man_MANS)
HEADERS = $(nodist_pkginclude_HEADERS) $(pkginclude_HEADERS)
ETAGS = etags
CTAGS = ctags
pkginclude_HEADERS = sod.h
###--------------------------------------------------------------------------
+### Manual pages.
+dist_man_MANS = sod.3 sod-structs.3
+
+###--------------------------------------------------------------------------
### Include and library path.
SOD_INCLUDES = \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
clean-libtool:
-rm -rf .libs _libs
+install-man3: $(dist_man_MANS)
+ @$(NORMAL_INSTALL)
+ @list1=''; \
+ list2='$(dist_man_MANS)'; \
+ test -n "$(man3dir)" \
+ && test -n "`echo $$list1$$list2`" \
+ || exit 0; \
+ echo " $(MKDIR_P) '$(DESTDIR)$(man3dir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(man3dir)" || exit 1; \
+ { for i in $$list1; do echo "$$i"; done; \
+ if test -n "$$list2"; then \
+ for i in $$list2; do echo "$$i"; done \
+ | sed -n '/\.3[a-z]*$$/p'; \
+ fi; \
+ } | while read p; do \
+ if test -f $$p; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; echo "$$p"; \
+ done | \
+ sed -e 'n;s,.*/,,;p;h;s,.*\.,,;s,^[^3][0-9a-z]*$$,3,;x' \
+ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,' | \
+ sed 'N;N;s,\n, ,g' | { \
+ list=; while read file base inst; do \
+ if test "$$base" = "$$inst"; then list="$$list $$file"; else \
+ echo " $(INSTALL_DATA) '$$file' '$(DESTDIR)$(man3dir)/$$inst'"; \
+ $(INSTALL_DATA) "$$file" "$(DESTDIR)$(man3dir)/$$inst" || exit $$?; \
+ fi; \
+ done; \
+ for i in $$list; do echo "$$i"; done | $(am__base_list) | \
+ while read files; do \
+ test -z "$$files" || { \
+ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(man3dir)'"; \
+ $(INSTALL_DATA) $$files "$(DESTDIR)$(man3dir)" || exit $$?; }; \
+ done; }
+
+uninstall-man3:
+ @$(NORMAL_UNINSTALL)
+ @list=''; test -n "$(man3dir)" || exit 0; \
+ files=`{ for i in $$list; do echo "$$i"; done; \
+ l2='$(dist_man_MANS)'; for i in $$l2; do echo "$$i"; done | \
+ sed -n '/\.3[a-z]*$$/p'; \
+ } | sed -e 's,.*/,,;h;s,.*\.,,;s,^[^3][0-9a-z]*$$,3,;x' \
+ -e 's,\.[0-9a-z]*$$,,;$(transform);G;s,\n,.,'`; \
+ dir='$(DESTDIR)$(man3dir)'; $(am__uninstall_files_from_dir)
install-nodist_pkgincludeHEADERS: $(nodist_pkginclude_HEADERS)
@$(NORMAL_INSTALL)
@list='$(nodist_pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
-rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
distdir: $(DISTFILES)
+ @list='$(MANS)'; if test -n "$$list"; then \
+ list=`for p in $$list; do \
+ if test -f $$p; then d=; else d="$(srcdir)/"; fi; \
+ if test -f "$$d$$p"; then echo "$$d$$p"; else :; fi; done`; \
+ if test -n "$$list" && \
+ grep 'ab help2man is required to generate this page' $$list >/dev/null; then \
+ echo "error: found man pages containing the \`missing help2man' replacement text:" >&2; \
+ grep -l 'ab help2man is required to generate this page' $$list | sed 's/^/ /' >&2; \
+ echo " to fix them, install help2man, remove and regenerate the man pages;" >&2; \
+ echo " typically \`make maintainer-clean' will remove them" >&2; \
+ exit 1; \
+ else :; fi; \
+ else :; fi
@srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
list='$(DISTFILES)'; \
$(MAKE) $(AM_MAKEFLAGS) $(check_PROGRAMS)
check: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) check-am
-all-am: Makefile $(LTLIBRARIES) $(PROGRAMS) $(HEADERS)
+all-am: Makefile $(LTLIBRARIES) $(PROGRAMS) $(MANS) $(HEADERS)
install-binPROGRAMS: install-libLTLIBRARIES
installdirs:
- for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgincludedir)" "$(DESTDIR)$(pkgincludedir)"; do \
+ for dir in "$(DESTDIR)$(libdir)" "$(DESTDIR)$(bindir)" "$(DESTDIR)$(man3dir)" "$(DESTDIR)$(pkgincludedir)" "$(DESTDIR)$(pkgincludedir)"; do \
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
done
install: $(BUILT_SOURCES)
info-am:
-install-data-am: install-nodist_pkgincludeHEADERS \
+install-data-am: install-man install-nodist_pkgincludeHEADERS \
install-pkgincludeHEADERS
install-dvi: install-dvi-am
install-info-am:
-install-man:
+install-man: install-man3
install-pdf: install-pdf-am
ps-am:
uninstall-am: uninstall-binPROGRAMS uninstall-libLTLIBRARIES \
- uninstall-nodist_pkgincludeHEADERS uninstall-pkgincludeHEADERS
+ uninstall-man uninstall-nodist_pkgincludeHEADERS \
+ uninstall-pkgincludeHEADERS
+
+uninstall-man: uninstall-man3
.MAKE: all check check-am install install-am install-strip
install-binPROGRAMS install-data install-data-am install-dvi \
install-dvi-am install-exec install-exec-am install-html \
install-html-am install-info install-info-am \
- install-libLTLIBRARIES install-man \
+ install-libLTLIBRARIES install-man install-man3 \
install-nodist_pkgincludeHEADERS install-pdf install-pdf-am \
install-pkgincludeHEADERS install-ps install-ps-am \
install-strip installcheck installcheck-am installdirs \
maintainer-clean maintainer-clean-generic mostlyclean \
mostlyclean-compile mostlyclean-generic mostlyclean-libtool \
pdf pdf-am ps ps-am tags uninstall uninstall-am \
- uninstall-binPROGRAMS uninstall-libLTLIBRARIES \
- uninstall-nodist_pkgincludeHEADERS uninstall-pkgincludeHEADERS
+ uninstall-binPROGRAMS uninstall-libLTLIBRARIES uninstall-man \
+ uninstall-man3 uninstall-nodist_pkgincludeHEADERS \
+ uninstall-pkgincludeHEADERS
.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $<
.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $<
--- /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 --------------------------------------------------
* 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@ --- *
+/* --- @SOD_CAR@ --- *
*
* Arguments: @...@ = a nonempty list of arguments
*
*/
#if __STDC_VERSION__ >= 199901
-# define SOD__CAR(...) SOD__CARx(__VA_LIST__, _)
+# define SOD_CAR(...) SOD__CARx(__VA_LIST__, _)
# define SOD__CARx(a, ...) a
#endif
LISP_SOURCES += sod-frontend.asd
LISP_SOURCES += frontend.lisp optparse.lisp
-## Interactive testing.
-LISP_SOURCES += debug.lisp
+## Finishing touches.
+LISP_SOURCES += final.lisp
###--------------------------------------------------------------------------
### Constructing an output image.
POST_UNINSTALL = :
build_triplet = @build@
host_triplet = @host@
-DIST_COMMON = $(nobase_dist_pkglispsrc_DATA) $(pkginclude_HEADERS) \
- $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
- $(top_srcdir)/vars.am
+DIST_COMMON = $(dist_man_MANS) $(nobase_dist_pkglispsrc_DATA) \
+ $(pkginclude_HEADERS) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.in $(top_srcdir)/vars.am
bin_PROGRAMS = sod$(EXEEXT)
check_PROGRAMS =
subdir = src
SUFFIXES = .c .h .sod
BUILT_SOURCES =
pkginclude_HEADERS =
+dist_man_MANS =
###--------------------------------------------------------------------------
### Include and library path.
class-finalize-proto.lisp class-finalize-impl.lisp \
class-output.lisp method-proto.lisp method-impl.lisp \
method-aggregate.lisp sod-frontend.asd frontend.lisp \
- optparse.lisp debug.lisp
+ optparse.lisp final.lisp
sod_SOURCES =
all: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) all-am
{
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.
(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.
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 --------------------------------------------------
(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.
(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.
(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 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))
(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 (eq arg :ellipsis)
(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"
(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))))
raw-name)))
(cond ((and (cdr args) (eq (cadr args) :ellipsis))
(setf varargsp t)
- (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
+ (unless in-names (setf me "SOD_CAR(__VA_ARGS__)"))
(push (format nil "/*~A*/ ..." name) in-names)
(push "__VA_ARGS__" out-names)
(return))
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)
(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 role) 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)))
(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)
(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)))
(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
((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.
-(definst if (stream :export t) (condition consequent alternative)
+;; 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 :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 :export t) (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 :export t) (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.
;; Expressions.
-(definst call (stream :export t) (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.
;; Root class.
-(export 'temporary-name)
+(export '(temporary-name temp-tag))
(defclass temporary-name ()
((tag :initarg :tag :reader temp-tag))
(:documentation
(format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
,@(mappend #'list keys args)))
(progn ,@body))))
- ,@(and export `((export '(,class-name ,constructor-name))))
+ ,@(and export `((export '(,class-name ,constructor-name
+ ,@(mapcar (lambda (arg)
+ (symbolicate 'inst- arg))
+ args)))))
',code)))
;; Important instruction classes.
-(definst var (stream :export t) (name type init)
- (pprint-c-type type stream name)
+;; 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 :export t) (name #1=#:type init)
+ (pprint-c-type #1# stream name)
(when init
(format stream " = ~A" init))
(write-char #\; stream))
-(definst set (stream :export t) (var expr)
- (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
-(definst update (stream :export t) (var op expr)
- (format stream "~@<~A ~A= ~@_~2I~A;~:>" var op expr))
-(definst return (stream :export t) (expr)
- (format stream "return~@[ (~A)~];" expr))
+(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) (expr)
- (format stream "~A;" expr))
+(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 :export t) (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.
;;; -*-lisp-*-
;;;
-;;; Debugging utilities for Sod
+;;; Finishing touches for Sod
;;;
;;; (c) 2015 Straylight/Edgeware
;;;
(cl:in-package #:sod)
+;;;--------------------------------------------------------------------------
+;;; Debugging utilities.
+
(export '*debugout-pathname*)
(defvar *debugout-pathname* #p"debugout.c")
(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."
- (unless *builtin-module* (make-builtin-module))
(clear-the-decks)
(setf *module-map* (make-hash-table :test #'equal))
(with-open-file (out *debugout-pathname*
: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.
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)
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))
(return-type (c-type-subtype (sod-message-type message)))
(msgargs (sod-message-argument-tail message))
(c-type va-list))
(butlast msgargs))
msgargs)))
- (setf (slot-value method 'next-method-type)
- (c-type (fun (lisp return-type)
- ("me" (* (class (sod-method-class method))))
- . arguments)))))
-
-(defmethod slot-unbound (class
- (method delegating-direct-method)
- (slot-name (eql 'function-type)))
- (declare (ignore class))
+ (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)
- (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))
(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
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.
(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.
(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-"))
(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)
(: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)
(:file "class-output" :depends-on
("classes" "class-layout-impl" "method-impl" "output-proto"))
- ;; Debugging and interactive testing.
- (:file "debug" :depends-on ("builtin" "module-output"))))
+ ;; Finishing touches of various kinds.
+ (:file "final" :depends-on ("builtin" "module-output"))))
;;;--------------------------------------------------------------------------
;;; Testing.
,(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)
POST_UNINSTALL = :
build_triplet = @build@
host_triplet = @host@
-DIST_COMMON = $(pkginclude_HEADERS) $(srcdir)/Makefile.am \
- $(srcdir)/Makefile.in $(top_srcdir)/vars.am
+DIST_COMMON = $(dist_man_MANS) $(pkginclude_HEADERS) \
+ $(srcdir)/Makefile.am $(srcdir)/Makefile.in \
+ $(top_srcdir)/vars.am
bin_PROGRAMS =
check_PROGRAMS = chimaera$(EXEEXT)
subdir = test
SUFFIXES = .c .h .sod
BUILT_SOURCES = $(nodist_chimaera_SOURCES)
pkginclude_HEADERS =
+dist_man_MANS =
###--------------------------------------------------------------------------
### Include and library path.
class Lion : Animal {
void bite() { puts("Munch!"); }
- void nml.tickle() { me->_vt->lion.bite(me); }
+ void nml.tickle() { Lion_bite(me); }
}
class Goat : Animal {
void butt() { puts("Bonk!"); }
- void nml.tickle() { me->_vt->goat.butt(me); }
+ void nml.tickle() { Goat_butt(me); }
}
class Serpent : Animal {
void hiss() { puts("Sssss!"); }
void bite() { puts("Nom!"); }
void nml.tickle() {
- if (SERPENT__CONV_NML(me)->nml.tickles > 2) me->_vt->serpent.bite(me);
- else me->_vt->serpent.hiss(me);
+ 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);
}
int main(void)
check_PROGRAMS =
pkginclude_HEADERS =
+dist_man_MANS =
+
CLEANFILES += $(BUILT_SOURCES)
###--------------------------------------------------------------------------
~mdw / sod / commitdiff