From: Mark Wooding Date: Mon, 14 Sep 2015 14:23:52 +0000 (+0100) Subject: Update automatically managed build utilities. X-Git-Url: https://git.distorted.org.uk/~mdw/sod/commitdiff_plain/dfdcf6ca08c0c619900fd7d81893121f80f02d9b?hp=031a15b2683b9971bb36ee16b94a142297c79ccd Update automatically managed build utilities. --- diff --git a/.gitignore b/.gitignore index 1abd9a1..0bf9e54 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ Makefile.in /autom4te.cache/ /config/ /configure +/doc/SYMBOLS diff --git a/Makefile.in b/Makefile.in index d289fe7..c4b6601 100644 --- a/Makefile.in +++ b/Makefile.in @@ -106,12 +106,12 @@ PRE_UNINSTALL = : 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 = . @@ -361,6 +361,7 @@ MAINTAINERCLEANFILES = SUFFIXES = .c .h .sod BUILT_SOURCES = pkginclude_HEADERS = +dist_man_MANS = ###-------------------------------------------------------------------------- ### Include and library path. diff --git a/configure b/configure index 9a8d7ad..d00f3a2 100755 --- a/configure +++ b/configure @@ -1,6 +1,6 @@ #! /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 . # @@ -590,8 +590,8 @@ MAKEFLAGS= # 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='' @@ -1319,7 +1319,7 @@ if test "$ac_init_help" = "long"; then # 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]... @@ -1389,7 +1389,7 @@ fi 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 @@ -1498,7 +1498,7 @@ fi 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. @@ -1776,7 +1776,7 @@ cat >config.log <<_ACEOF 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 $@ @@ -2592,7 +2592,7 @@ fi # Define the identity of the package. PACKAGE='sod' - VERSION='0.2.0' + VERSION='0.2.0-29-g54c0' cat >>confdefs.h <<_ACEOF @@ -11970,7 +11970,7 @@ cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 # 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 @@ -12027,7 +12027,7 @@ _ACEOF 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\\" diff --git a/doc/list-exports.lisp b/doc/list-exports.lisp new file mode 100644 index 0000000..abbf94a --- /dev/null +++ b/doc/list-exports.lisp @@ -0,0 +1,346 @@ +(defun symbolicate (&rest things) + (intern (apply #'concatenate 'string (mapcar #'string things)))) + +(defun incomprehensible-form (head tail) + (format *error-output* ";; incomprehensible: ~S~%" (cons head tail))) + +(defgeneric form-list-exports (head tail) + (:method (head tail) + (declare (ignore head tail)) + nil)) + +(defmethod form-list-exports ((head (eql 'export)) tail) + (let ((symbols (car tail))) + (if (and (consp symbols) + (eq (car symbols) 'quote)) + (let ((thing (cadr symbols))) + (if (atom thing) (list thing) thing)) + (incomprehensible-form head tail)))) + +(defmethod form-list-exports ((head (eql 'definst)) tail) + (destructuring-bind (code (streamvar &key export) args &body body) tail + (declare (ignore streamvar body)) + (and export + (list* (symbolicate code '-inst) + (symbolicate 'make- code '-inst) + (mapcar (lambda (arg) + (symbolicate 'inst- arg)) + args))))) + +(defmethod form-list-exports ((head (eql 'define-tagged-type)) tail) + (destructuring-bind (kind what) tail + (declare (ignore what)) + (list kind + (symbolicate 'c- kind '-type) + (symbolicate 'make- kind '-type)))) + +(defmethod form-list-exports ((head (eql 'macrolet)) tail) + (mapcan #'form-exports (cdr tail))) + +(defmethod form-list-exports ((head (eql 'eval-when)) tail) + (mapcan #'form-exports (cdr tail))) + +(defmethod form-list-exports ((head (eql 'progn)) tail) + (mapcan #'form-exports tail)) + +(defgeneric form-exports (form) + (:method (form) nil) + (:method ((form cons)) (form-list-exports (car form) (cdr form)))) + +(defgeneric list-exports (thing)) + +(defmethod list-exports ((stream stream)) + (loop with eof = '#:eof + for form = (read stream nil eof) + until (eq form eof) + when (consp form) nconc (form-exports form))) + +(defmethod list-exports ((path pathname)) + (mapcar (lambda (each) + (cons each (with-open-file (stream each) (list-exports stream)))) + (directory (merge-pathnames path #p"*.lisp")))) + +(defmethod list-exports ((path string)) + (list-exports (pathname path))) + +(defun list-exported-symbols (package) + (sort (loop for s being the external-symbols of package collect s) + #'string< :key #'symbol-name)) + +(defun find-symbol-homes (paths package) + (let* ((symbols (list-exported-symbols package)) + (exports-alist (mapcan #'list-exports paths)) + (homes (make-hash-table :test #'equal))) + (dolist (assoc exports-alist) + (let ((home (car assoc))) + (dolist (symbol (cdr assoc)) + (let ((name (symbol-name symbol))) + (unless (nth-value 1 (find-symbol name package)) + (format *error-output* ";; unexported: ~S~%" symbol)) + (setf (gethash name homes) home))))) + (dolist (symbol symbols) + (unless (gethash (symbol-name symbol) homes) + (format *error-output* ";; mysterious: ~S~%" symbol))) + exports-alist)) + +(defun boring-setf-expansion-p (symbol) + (multiple-value-bind (temps args stores store fetch) + (ignore-errors (get-setf-expansion (list symbol))) + (declare (ignore temps args stores fetch)) + (and (consp store) + (eq (car store) 'funcall) + (consp (cdr store)) (consp (cadr store)) + (eq (caadr store) 'function) + (let ((func (cadadr store))) + (and (consp func) (consp (cdr func)) + (eq (car func) 'setf)))))) + +(defun specialized-on-p (func arg what) + (some (lambda (method) + (let ((spec (nth arg (sb-mop:method-specializers method)))) + (and (typep spec 'sb-mop:eql-specializer) + (eql (sb-mop:eql-specializer-object spec) what)))) + (sb-mop:generic-function-methods func))) + +(defun categorize (symbol) + (let ((things nil)) + (when (boundp symbol) + (push (if (constantp symbol) :constant :variable) things)) + (when (fboundp symbol) + (push (cond ((macro-function symbol) :macro) + ((typep (fdefinition symbol) 'generic-function) + :generic) + (t :function)) + things) + (when (or ;;(not (boring-setf-expansion-p symbol)) + (ignore-errors (fdefinition (list 'setf symbol)))) + (push :setf things))) + (when (find-class symbol nil) + (push :class things)) + (when (or (specialized-on-p #'sod:expand-c-type-spec 0 symbol) + (specialized-on-p #'sod:expand-c-type-form 0 symbol)) + (push :c-type things)) + (when (or (specialized-on-p #'sod-parser:expand-parser-spec 1 symbol) + (specialized-on-p #'sod-parser:expand-parser-form 1 symbol)) + (push :parser things)) + (nreverse things))) + +(defun categorize-symbols (paths package) + (mapcar (lambda (assoc) + (let ((home (car assoc)) + (symbols (delete-duplicates + (sort (mapcan (lambda (sym) + (multiple-value-bind + (symbol foundp) + (find-symbol + (symbol-name sym) + package) + (and foundp (list symbol)))) + (cdr assoc)) + #'string< :key #'symbol-name)))) + (cons home (mapcar (lambda (symbol) + (cons symbol (categorize symbol))) + symbols)))) + + (find-symbol-homes paths package))) + +(defun best-package-name (package) + (car (sort (cons (package-name package) + (copy-list (package-nicknames package))) + #'< :key #'length))) + +(defvar charbuf-size 0) + +(defun pretty-symbol-name (symbol package) + (let* ((pkg (symbol-package symbol)) + (exportp (member symbol (list-exported-symbols pkg)))) + (format nil "~(~:[~A:~:[:~;~]~;~2*~]~A~)" + (and exportp (eq pkg package)) + (if (keywordp symbol) "" (best-package-name pkg)) + exportp (symbol-name symbol)))) + +(defun analyse-classes (package) + (setf package (find-package package)) + (let ((classes (mapcan (lambda (symbol) + (let ((class (find-class symbol nil))) + (and class + (typep class '(or standard-class + structure-class)) + (list class)))) + (list-exported-symbols package))) + (subs (make-hash-table))) + (let ((done (make-hash-table))) + (labels ((walk-up (class) + (unless (gethash class done) + (dolist (super (sb-mop:class-direct-superclasses class)) + (push class (gethash super subs)) + (walk-up super)) + (setf (gethash class done) t)))) + (dolist (class classes) + (walk-up class)))) + (labels ((walk-down (this super depth) + (format t "~v,0T~A~@[ [~{~A~^ ~}]~]~%" + (* 2 depth) + (pretty-symbol-name (class-name this) package) + (mapcar (lambda (class) + (pretty-symbol-name (class-name class) + package)) + (remove super + (sb-mop:class-direct-superclasses this)))) + (dolist (sub (sort (copy-list (gethash this subs)) + #'string< :key #'class-name)) + (walk-down sub this (1+ depth))))) + (walk-down (find-class t) nil 0)))) + +(defun analyse-generic-functions (package) + (setf package (find-package package)) + (flet ((function-name-core (name) + (etypecase name + (symbol name) + ((cons (eql setf) t) (cadr name))))) + (let ((methods (make-hash-table)) + (functions (make-hash-table)) + (externs (make-hash-table))) + (dolist (symbol (list-exported-symbols package)) + (setf (gethash symbol externs) t)) + (dolist (symbol (list-exported-symbols package)) + (flet ((dofunc (func) + (when (typep func 'generic-function) + (setf (gethash func functions) t) + (dolist (method (sb-mop:generic-function-methods func)) + (setf (gethash method methods) t))))) + (dofunc (and (fboundp symbol) (fdefinition symbol))) + (dofunc (ignore-errors (fdefinition (list 'setf symbol))))) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (when class + (dolist + (func (sb-mop:specializer-direct-generic-functions class)) + (let ((name (function-name-core + (sb-mop:generic-function-name func)))) + (when (or (not (eq (symbol-package name) package)) + (gethash name externs)) + (setf (gethash func functions) t) + (dolist (method (sb-mop:specializer-direct-methods class)) + (setf (gethash method methods) t))))))))) + (let ((funclist nil)) + (maphash (lambda (func value) + (declare (ignore value)) + (push func funclist)) + functions) + (setf funclist (sort funclist + (lambda (a b) + (let ((core-a (function-name-core a)) + (core-b (function-name-core b))) + (if (eq core-a core-b) + (and (atom a) (consp b)) + (string< core-a core-b)))) + :key #'sb-mop:generic-function-name)) + (dolist (function funclist) + (let ((name (sb-mop:generic-function-name function))) + (etypecase name + (symbol + (format t "~A~%" (pretty-symbol-name name package))) + ((cons (eql setf) t) + (format t "(setf ~A)~%" + (pretty-symbol-name (cadr name) package))))) + (dolist (method (sb-mop:generic-function-methods function)) + (when (gethash method methods) + (format t "~2T~{~A~^ ~}~%" + (mapcar + (lambda (spec) + (etypecase spec + (class + (let ((name (class-name spec))) + (if (eq name t) "t" + (pretty-symbol-name name package)))) + (sb-mop:eql-specializer + (let ((obj (sb-mop:eql-specializer-object spec))) + (format nil "(eql ~A)" + (if (symbolp obj) + (pretty-symbol-name obj package) + obj)))))) + (sb-mop:method-specializers method)))))))))) + +(defun check-slot-names (package) + (setf package (find-package package)) + (let* ((symbols (list-exported-symbols package)) + (classes (mapcan (lambda (symbol) + (when (eq (symbol-package symbol) package) + (let ((class (find-class symbol nil))) + (and class (list class))))) + symbols)) + (offenders (mapcan + (lambda (class) + (let* ((slot-names + (mapcar #'sb-mop:slot-definition-name + (sb-mop:class-direct-slots class))) + (exported (remove-if-not + (lambda (sym) + (or (and (symbol-package sym) + (not (eq (symbol-package + sym) + package))) + (member sym symbols))) + slot-names))) + (and exported + (list (cons (class-name class) + exported))))) + classes)) + (bad-words (remove-duplicates (mapcan (lambda (list) + (copy-list (cdr list))) + offenders)))) + (values offenders bad-words))) + +(defun report-symbols (paths package) + (setf package (find-package package)) + (format t "~A~%Package `~(~A~)'~2%" + (make-string 77 :initial-element #\-) + (package-name package)) + (dolist (assoc (categorize-symbols paths package)) + (when (cdr assoc) + (format t "~A~%" (file-namestring (car assoc))) + (dolist (def (cdr assoc)) + (let ((sym (car def))) + (format t " ~A~@[~48T~{~(~A~)~^ ~}~]~%" + (pretty-symbol-name sym package) + (cdr def)))) + (terpri))) + (multiple-value-bind (alist names) (check-slot-names package) + (when names + (format t "Leaked slot names: ~{~A~^, ~}~%" + (mapcar (lambda (name) (pretty-symbol-name name package)) + names)) + (dolist (assoc alist) + (format t "~2T~A: ~{~A~^, ~}~%" + (pretty-symbol-name (car assoc) package) + (mapcar (lambda (name) (pretty-symbol-name name package)) + (cdr assoc)))) + (terpri))) + (format t "Classes:~%") + (analyse-classes package) + (terpri) + (format t "Methods:~%") + (analyse-generic-functions package) + (terpri)) + +(defun report-project-symbols () + (labels ((components (comp) + (slot-value comp 'asdf::components)) + (files (comp) + (sort (remove-if-not (lambda (comp) + (typep comp 'asdf:cl-source-file)) + (components comp)) + #'string< :key #'asdf:component-name)) + (by-name (comp name) + (find name (components comp) + :test #'string= :key #'asdf:component-name)) + (file-name (file) + (slot-value file 'asdf::absolute-pathname))) + (let* ((sod (asdf:find-system "sod")) + (parser-files (files (by-name sod "parser"))) + (utilities (by-name sod "utilities")) + (sod-files (remove utilities (files sod)))) + (report-symbols (mapcar #'file-name sod-files) "SOD") + (report-symbols (mapcar #'file-name parser-files) "SOD-PARSER") + (report-symbols (mapcar #'file-name (list utilities)) "SOD-UTILITIES")))) diff --git a/lib/Makefile.am b/lib/Makefile.am index fa28adc..50473a9 100644 --- a/lib/Makefile.am +++ b/lib/Makefile.am @@ -53,4 +53,9 @@ BUILT_SOURCES += $(nodist_libsod_la_SOURCES) \ sod-base.c: $(SOD); $(V_SOD_c)$(SOD) -tc --builtin sod-base.h: $(SOD); $(V_SOD_h)$(SOD) -th --builtin +###-------------------------------------------------------------------------- +### Manual pages. + +dist_man_MANS += sod.3 sod-structs.3 + ###----- That's all, folks -------------------------------------------------- diff --git a/lib/Makefile.in b/lib/Makefile.in index 4febcc7..b6c62b8 100644 --- a/lib/Makefile.in +++ b/lib/Makefile.in @@ -106,8 +106,9 @@ PRE_UNINSTALL = : 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 @@ -146,7 +147,8 @@ am__uninstall_files_from_dir = { \ $(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 @@ -193,6 +195,9 @@ am__can_run_installinfo = \ 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 @@ -331,6 +336,10 @@ BUILT_SOURCES = $(nodist_libsod_la_SOURCES) \ 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 @@ -545,6 +554,49 @@ mostlyclean-libtool: 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=; \ @@ -641,6 +693,19 @@ distclean-tags: -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)'; \ @@ -674,11 +739,11 @@ check-am: all-am $(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) @@ -739,7 +804,7 @@ info: info-am info-am: -install-data-am: install-nodist_pkgincludeHEADERS \ +install-data-am: install-man install-nodist_pkgincludeHEADERS \ install-pkgincludeHEADERS install-dvi: install-dvi-am @@ -756,7 +821,7 @@ install-info: install-info-am install-info-am: -install-man: +install-man: install-man3 install-pdf: install-pdf-am @@ -787,7 +852,10 @@ ps: ps-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 @@ -799,15 +867,16 @@ uninstall-am: uninstall-binPROGRAMS uninstall-libLTLIBRARIES \ 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 $< diff --git a/lib/sod-structs.3 b/lib/sod-structs.3 new file mode 100644 index 0000000..6aefc9d --- /dev/null +++ b/lib/sod-structs.3 @@ -0,0 +1,1026 @@ +.\" -*-nroff-*- +.\" +.\" Description of the main Sod data structures +.\" +.\" (c) 2015 Straylight/Edgeware +.\" +. +.\"----- Licensing notice --------------------------------------------------- +.\" +.\" This file is part of the Sensble Object Design, an object system for C. +.\" +.\" SOD is free software; you can redistribute it and/or modify +.\" it under the terms of the GNU General Public License as published by +.\" the Free Software Foundation; either version 2 of the License, or +.\" (at your option) any later version. +.\" +.\" SOD is distributed in the hope that it will be useful, +.\" but WITHOUT ANY WARRANTY; without even the implied warranty of +.\" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +.\" GNU General Public License for more details. +.\" +.\" You should have received a copy of the GNU General Public License +.\" along with SOD; if not, write to the Free Software Foundation, +.\" Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +. +.\"\X'tty: sgr 1' +.\" String definitions and font selection. +.ie t \{\ +. ds o \(bu +. if \n(.g .fam P +.\} +.el \{\ +. ds o o +.\} +. +.\" .hP TEXT -- start an indented paragraph with TEXT hanging off to the left +.de hP +.IP +\h'-\w'\fB\\$1\ \fP'u'\fB\\$1\ \fP\c +.. +. +.\"-------------------------------------------------------------------------- +.TH sod-structs 3 "8 September 2015" "Straylight/Edgeware" "Sensible Object Design" +. +.SH NAME +sod-structs \- main Sod data structures +. +.\"-------------------------------------------------------------------------- +.SH SYNOPSIS +.nf +.ft B +#include + +typedef struct SodObject__ichain_obj SodObject; +typedef struct SodClass__ichain_obj SodClass; + +struct sod_instance { +\h'2n'const struct sod_vtable *_vt; +}; + +struct sod_vtable { +\h'2n'const SodClass *_class; +\h'2n'size_t _base; +}; + +struct SodObject__vt_obj { +\h'2n'const SodClass *_class; +\h'2n'size_t _base; +}; + +struct SodObject__ilayout { +\h'2n'union { +\h'4n'struct SodObject__ichain_obj { +\h'6n'const struct SodObject__vt_obj *_vt; +\h'4n'}; +\h'2n'} obj; +}; + +extern const struct SodClass__ilayout SodObject__classobj; +#define SodObject__class (&SodObject__classobj.obj.cls) + +struct SodClass__vt_obj { +\h'2n'const SodClass *_class; +\h'2n'size_t _base; +}; + +struct SodObject__ilayout { +\h'2n'union { +\h'4n'struct SodClass__ichain_obj { +\h'6n'const struct SodClass__vt_obj *_vt; +\h'6n'struct SodClass__islots { +\h'8n'const char *name; +\h'8n'const char *nick; +\h'8n'size_t initsz; +\h'8n'void *(*imprint)(void *\fIp\fB); +\h'8n'void *(*init)(void *\fIp\fB); +\h'8n'size_t n_supers; +\h'8n'const SodClass *const *supers; +\h'8n'size_t n_cpl; +\h'8n'const SodClass *const *cpl; +\h'8n'const SodClass *link; +\h'8n'const SodClass *head; +\h'8n'size_t level; +\h'8n'size_t n_chains; +\h'8n'const struct sod_chain *chains; +\h'8n'size_t off_islots; +\h'8n'size_t islotsz; +\h'6n'} cls; +\h'4n'}; +\h'4n'SodObject obj; +\h'2n'} obj; +}; + +struct sod_chain { +\h'2n'size_t n_classes; +\h'2n'const SodClass *const *classes; +\h'2n'size_t off_ichain; +\h'2n'const struct sod_vtable *vt; +\h'2n'size_t ichainsz; +}; + +extern const struct SodClass__ilayout SodClass__classobj; +#define SodClass__class (&SodClass__classobj.obj.cls) +.fi +.ft P +. +.\"-------------------------------------------------------------------------- +.SH DESCRIPTION +. +This page describes the structure and layout +of standard Sod objects, classes and associated metadata. +Note that Sod's object system is very flexible +and it's possible for an extension +to define a new root class +which works very differently from the standard +.B SodObject +described here. +. +.\"-------------------------------------------------------------------------- +.SH COMMON INSTANCE STRUCTURE +. +As described below, +a pointer to an instance actually points to an +.I "instance chain" +structure within the instances overall layout structure. +.PP +Instance chains contain slots and vtable pointers, +as described below. +All instances have the basic structure of a +.BR "struct sod_instance" , +which has the following members. +.TP +.B "const struct sod_vtable *_vt" +A pointer to a +.IR vtable , +which has the basic structure of a +.BR "struct sod_vtable" , +described below. +.PP +A vtable contains static metadata needed +for efficient conversions and +message dispatch, +and pointers to the instance's class. +Each chain points to a different vtable +All vtables have the basic structure of a +.BR "struct sod_vtable" , +which has the following members. +.TP +.B "const SodClass *_class" +A pointer to the instance's class object. +.TP +.B "size_t _base;" +The offset of this chain structure +above the start of the overall instance layout, in bytes. +Subtracting +.B _base +from the instance chain pointer +finds the layout base address. +. +.\"-------------------------------------------------------------------------- +.SH BUILT-IN ROOT OBJECTS +. +This section describes the built-in classes +.B SodObject +and +.BR SodClass , +which are the standard roots of the inheritance and metaclass graphs +respectively. +Specifically, +.B SodObject +has no direct superclasses, +and +.B SodClass +is its own metaclass. +It is not possible to define root classes because of circularities: +.B SodObject +has +.B SodClass +as its metaclass, and +.B SodClass +is a subclass of +.BR SodObject . +Extensions can define additional root classes, +but this is tricky, +and not really to be recommended. +. +.SS The SodObject class +The +.B SodObject +class defines no slots or messages. +Because +.B SodObject +has no direct superclasses, +there is only one chain, +and no inherited slots or messages, +so the single chain contains only a vtable pointer. +.PP +Since there are no messages, +and +.B SodClass +also has only one chain, +the vtable contains only the standard class pointer and offset-to-base +members. +In an actual instance of +.B SodObject +(why would you want one?) +the class pointer contains the address of +.B SodObject__class +and the offset is zero. +. +.SS The SodClass class +The +.B SodClass +class defines no messages, +but there are a number of slots. +Its only direct superclass is +.B SodObject +and so (like its superclass) its vtable is trivial. +.PP +The slots defined are as follows. +.TP +.B const char *name; +A pointer to the class's name. +.TP +.B const char *nick; +A pointer to the class's nickname. +.TP +.B size_t initsz; +The size in bytes required to store an instance of the class. +.TP +.BI "void *(*imprint)(void *" p ); +A pointer to a function: +given a pointer +.I p +to at least +.I initsz +bytes of appropriately aligned memory, +`imprint' this memory it so that it becomes a minimally functional +instance of the class: +all of the vtable and class pointers are properly initialized, +but the slots are left untouched. +The function returns its argument +.IR p . +.TP +.BI "void *(*init)(void *" p ); +A pointer to a function: +given a pointer +.I p +to at least +.I initsz +bytes of appropriately aligned memory, +initialize an instance of the class in it: +all of the vtable and class pointers are initialized, +as are slots for which initializers are defined. +Other slots are left untouched. +The function returns its argument +.IR p . +.TP +.B size_t n_supers; +The number of direct superclasses. +(This is zero exactly in the case of +.BR SodObject .) +.TP +.B const SodClass *const *supers; +A pointer to an array of +.I n_supers +pointers to class objects +listing the class's direct superclasses, +in the order in which they were listed in the class definition. +If +.I n_supers +is zero, +then this pointer is null. +.TP +.B size_t n_cpl; +The number of superclasses in the class's class precedence list. +.TP +.B const SodClass *const *cpl; +A pointer to an array of pointers to class objects +listing all of the class's superclasses, +from most- to least-specific, +starting with the class itself, +so +.IB c ->cls.cpl[0] += +.I c +for all class objects +.IR c . +.TP +.B const SodClass *link; +If the class is a chain head, then this is a null pointer; +otherwise it points to the class's distinguished link superclass +(which might or might not be a direct superclass). +.TP +.B const SodClass *head; +A pointer to the least-specific class in this class's chain; +so +.IB c ->cls.head->cls.link +is always null, +and either +.IB c ->cls.link +is null +(in which case +.IB c ->cls.head += +.IR c ) +or +.IB c ->cls.head += +.IB c ->cls.link->cls.head \fR. +.TP +.B size_t level; +The number of less specific superclasses in this class's chain. +If +.IB c ->cls.link +is null then +.IB c ->cls.level +is zero; +otherwise +.IB c ->cls.level += +.IB c ->cls.link->cls.level ++ 1. +.TP +.B size_t n_chains; +The number of chains formed by the class's superclasses. +.TP +.B const struct sod_chain *chains; +A pointer to an array of +.B struct sod_chain +structures (see below) describing the class's superclass chains, +in decreasing order of specificity of their most specific classes. +It is always the case that +.IB c ->cls.chains[0].classes[ c ->cls.level] += +.IR c . +.TP +.B size_t off_islots; +The offset of the class's +.B islots +structure relative to its containing +.B ichain +structure. +The class doesn't define any slots if and only if this is zero. +(The offset can't be zero because the vtable pointer is at offset zero.) +.TP +.B size_t islotsz; +The size required to store the class's direct slots, +i.e., the size of its +.B islots +structure. +The class doesn't define any slots if and only if this is zero. +.PP +The +.B struct sod_chain +structure describes an individual chain of superclasses. +It has the following members. +.TP +.B size_t n_classes; +The number of classes in the chain. +This is always at least one. +.TP +.B const SodClass *const *classes; +A pointer to an array of class pointers +listing the classes in the chain from least- to most-specific. +So +.IB classes [ i ]->cls.head += +.IB classes [0] +for all +0 \(<= +.I i +< +.IR n_classes , +.IB classes [0]->cls.link +is always null, +and +.IB classes [ i ]->cls.link += +.IB classes [ "i\fR \- 1" ] +if +1 \(<= +.I i +< +.IR n_classes . +.TP +.B size_t off_ichain; +The size of the +.B ichain +structure for this chain. +.TP +.B const struct sod_vtable *vt; +The vtable for this chain. +(It is possible, therefore, to duplicate the behaviour of the +.I imprint +function by walking the chain structure. +The +.I imprint +function is much faster, though.) +.TP +.B size_t ichainsz; +The size of the +.B ichain +structure for this chain. +. +.\"-------------------------------------------------------------------------- +.SH CLASS AND VTABLE LAYOUT +. +The layout algorithms for Sod instances and vtables are nontrivial. +They are defined here in full detail, +since they're effectively fixed by Sod's ABI compatibility guarantees, +so they might as well be documented for the sake of interoperating +programs. +.PP +Unfortunately, the descriptions are rather complicated, +and, for the most part not necessary to a working understanding of Sod. +The skeleton structure definitions shown should be more than enough +for readers attempting to make sense of the generated headers and tables. +.PP +In the description that follows, +uppercase letters vary over class names, +while the corresponding lowercase letters indicate the class nicknames. +Throughout, we consider a class +.I C +(therefore with nickname +.IR c ). +. +.SS Generic instance structure +The entire state of an instance of +.I C +is contained in a single structure of type +.B struct +.IB C __ilayout \fR. +.IP +.nf +.ft B +struct \fIC\fB__ilayout { +\h'2n'union \fIC\fB__ichainu_\fIh\fB { +\h'4n'struct \fIC\fB__ichain_\fIh\fB { +\h'6n'const struct \fIC\fB__vt_\fIh\fB *_vt; +\h'6n'struct \fIH\fB__islots \fIh\fB; +\h'6n'\fR...\fB +\h'6n'struct \fIC\fB__islots { +\h'8n'\fItype\fB \fIslota\fB; +\h'8n'\fR...\fB +\h'6n'} \fIc\fB; +\h'4n'} \fIc\fB; +\h'4n'\fR...\fB +\h'4n'struct \fIH\fB__ichain_\fIh\fB \fIh\fB; +\h'2n'} \fIh\fB; +\h'2n'union \fIB\fB__ichainu_\fIi\fB \fIi\fB; +\h'2n'\fR...\fB +}; + +typedef struct \fIC\fB__ichain_\fIh\fB \fIC\fB; +.ft P +.fi +.PP +The set of superclasses of +.IR C , +including itself, +can be partitioned into chains +by following their distinguished superclass links. +(Formally, the chains are the equivalence classes determined by +the reflexive, symmetric, transitive closure of +the `links to' relation.) +Chains are identified by naming their least specific classes; +the least specific class in a chain is called the +.IR "chain head" . +Suppose that the chain head of the chain containing +.I C +itself is named +.I H +(though keep in mind that it's possible that +.I H +is in fact +.I C +itself.) +.PP +The +.B ilayout +structure contains one member for each of +.IR C 's +superclass chains. +The first such member is +.IP +.B +.B union +.IB C __ichainu_ h +.IB h ; +.PP +described below; +this is followed by members +.IP +.B union +.IB B __ichainu_ i +.IB i ; +.PP +for each other chain, +where +.I I +is the head +and +.I B +the tail (most-specific) class of the chain. +The members are in decreasing order +of the specificity of the chains' most-specific classes. +(Note that all but the first of these unions +has already been defined as part of +the definition of the corresponding +.IR B .) +.PP +The +.B ichainu +union contains a member for each class in the chain. +The first is +.IP +.B struct +.IB C __ichain_ h +.IB c ; +.PP +and this is followed by corresponding members +.IP +.B struct +.IB A __ichain_ h +.IB a ; +.PP +for each of +.IR C 's superclasses +.IR A +in the same chain in some (unimportant) order. +A `pointer to +.IR C ' +is always assumed +(and, indeed, defined in C's type system) +to be a pointer to the +.B struct +.IB C __ichain_ h \fR. +.PP +The +.B ichain +structure contains (in order), a pointer +.IP +.B const +.B struct +.IB C __vt_ h +.B *_vt; +.PP +followed by a structure +.IP +.B struct +.IB A __islots +.IB a ; +.PP +for each superclass +.I A +of +.IR C +in the same chain which defines slots, +from least- to most-specific; +if +.I C +defines any slots, +then the last member is +.IP +.B struct +.IB C __islots +.IB c ; +.PP +Finally, the +.B islots +structure simply contains one member for each slot defined by +.I C +in the order they appear in the class definition. +. +.SS Generic vtable structure +As described above, +each +.B ichain +structure of an instance's storage +has a vtable pointer +.IP +.B const +.B struct +.IB C __vt_ h +.B *_vt; +.PP +In general, +the vtables for the different chains +will have +.I different +structures. +.PP +The instance layout split neatly into disjoint chains. +This is necessary because +each +.B ichain +must have as a prefix the +.B ichain +for each superclass in the same chain, and +each slot must be stored in exactly one place. +The layout of vtables doesn't have this second requirement: +it doesn't matter that there are +multiple method entry pointers +for the same effective method +as long as they all work correctly. +.PP +A vtable for a class +.I C +with chain head +.I H +has the following general structure. +.IP +.nf +.ft B +union \fIC\fB__vtu_\fIh\fB { +\h'2n'struct \fIC\fB__vt_\fIh\fB { +\h'4n'const \fIP\fB *_class; +\h'4n'size_t _base; +\h'4n'\fR...\fB +\h'4n'const \fIQ\fB *_cls_\fIj\fB; +\h'4n'\fR...\fB +\h'4n'ptrdiff_t _off_\fIi\fB; +\h'4n'\fR...\fB +\h'4n'struct \fIC\fB__vtmsgs_\fIa\fB { +\h'6n'\fItype\fB (*\fImsg\fB)(\fIC\fB *, \fR...\fB); +\h'6n'\fR...\fB +\h'4n'} \fIa\fB; +\h'4n'\fR...\fB +\h'2n'} \fIc\fB; +}; + +extern const union \fIC\fB__vtu_\fIh\fB \fIC\fB__vtable_\fIh\fB; +.ft P +.fi +.PP +The outer layer is a +.IP +.B union +.IB C __vtu_ h +.PP +containing a member +.IP +.B struct +.IB A __vt_ h +.IB a ; +.PP +for each of +.IR C 's +superclasses +.I A +in the same chain, +with +.I C +itself listed first. +This is mostly an irrelevant detail, +whose purpose is to defend against malicious compilers: +pointers are always to one of the inner +.B vt +structures. +It's important only because it's the outer +.B vtu +union which is exported by name. +Specifically, for each chain of +.IR C 's +superclasses +there is an external object +.IP +.B const union +.IB A __vtu_ i +.IB C __vtable_ i ; +.PP +where +.I A +and +.I I +are respectively the most and least specific classes in the chain. +.PP +The first member in the +.B vt +structure is the +.I root class pointer +.IP +.B const +.IR P +.B *_class; +.PP +Among the superclasses of +.I C +there must be exactly one class +.I O +which itself has no direct superclasses; +this is the +.I root superclass +of +.IR C . +(This is a rule enforced by the Sod translator.) +The metaclass +.I R +of +.IR O . +is then the +.I root metaclass +of +.IR C . +The +.B _class +member points to the +.B ichain +structure of most specific superclass +.I P +of +.I M +in the same chain as +.IR R . +.PP +This is followed by the +.I base offset +.IP +.B size_t +.B _base; +.PP +which is simply the offset of the +.B ichain +structure from the instance base. +.PP +The rest of the vtable structure is populated +by walking the superclass chain containing +.I C +as follows. +For each such superclass +.IR B , +in increasing order of specificity, +walk the class precedence list of +.IR B , +again starting with its least-specific superclass. +(This complex procedure guarantees that +the vtable structure for a class is a prefix of +the vtable structure for any of its subclasses in the same chain.) +.PP +So, let +.I A +be some superclass of +.I C +which has been encountered during this traversal. +.hP \*o +Let +.I N +be the metaclass of +.IR A . +Examine the superclass chains of +.I N +in order of decreasing specificity of their most-specific classes. +Let +.I J +be the chain head of such a chain, +and let +.I Q +be the most specific superclass of +.I M +in the same chain as +.IR J . +Then, if there is currently no class pointer of type +.I Q +then add a member +.RS +.IP +.B const +.I Q +.BI *_cls_ j ; +.PP +to the vtable +pointing to the appropriate +.B islots +structure within +.IR M 's +class object. +.RE +.hP \*o +Examine the superclass chains of +.I A +in order of decreasing specificity of their most-specific classes. +Let +.I I +be the chain head of such a chain. +If there is currently no member +.BI _off_ i +then add a member +.RS +.IP +.B ptrdiff_t +.BI _off_ i ; +.PP +to the vtable, +containing the (signed) offset from the +.B ichain +structure of the chain headed by +.I h +to that of the chain headed by +.I i +within the instance's layout. +.RE +.hP \*o +If class +.I A +defines any messages, +and there is currently no member +.I a +then add a member +.RS +.IP +.B struct +.IB C __vtmsgs_ a +.IB a ; +.PP +to the vtable. +See below. +.RE +.PP +Finally, the +.B vtmsgs +structures contain pointers to the effective method entry functions +for the messages defined by a superclass. +There may be more than one method entry for a message, +but all of the entry pointers for a message appear together, +and entry pointers for separate messages appear +in the order in which the messages are defined. +If the receiver class has no applicable primary method for a message +then it's usual for the method entry pointer to be null +(though, as with a lot of things in Sod, +extensions may do something different). +.PP +For a standard message which takes a fixed number of arguments, +defined as +.IP +.I tr +.IB m ( \c +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an ); +.PP +there is always a `main' entry point, +.IP +.I tr +.BI (* m )( \c +.I C +.BI * me , +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an ); +.PP +For a standard message which takes a variable number of arguments, +defined as +.IP +.I tr +.IB m ( \c +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an , +.B ...); +.PP +two entry points are defined: +the usual `main' entry point +which accepts a variable number of +arguments, +and a `valist' entry point +which accepts an argument of type +.B va_list +in place of the variable portion of the argument list. +.IP +.I tr +.BI (* m )( \c +.I C +.BI * me , +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an , +.B ...); +.br +.I tr +.BI (* m __v)( \c +.I C +.BI * me , +.I t1 +.IB a1 , +.RB ... , +.I tn +.IB an , +.B va_list +.IB sod__ap ); +. +.SS Additional definitions +In addition to the instance and vtable structures described above, +the following definitions are made for each class +.IR C . +.PP +For each message +.I m +directly defined by +.I C +there is a macro definition +.IP +.B #define +.IB C _ m ( me , +.RB ... ) +.IB me ->_vt-> c . m ( me , +.RB ... ) +.PP +which makes sending the message +.I m +to an instance of (any subclass of) +.I C +somewhat less ugly. +If +.I m +takes a variable number of arguments, +the macro is more complicated +and is only available in compilers advertising C99 support, +but the effect is the same. +For each variable-argument message, +there is also an additional macro +for calling the `valist' entry point. +.IP +.B #define +.IB C _ m __v( me , +.RB ..., +.IB sod__ap ) +.if !t \{\ +\e +.br +\h'4m'\c +.\} +.IB me ->_vt-> c . m __v( me , +.RB ..., +.IB sod__ap ) +.PP +For each proper superclass +.I A +of +.IR C , +there is a macro defined +.IP +.I A +.BI * C __CONV_ a ( C +.BI * _obj ); +.PP +(named in +.IR "upper case" ) +which converts a (static-type) pointer to +.I C +to a pointer to the same actual instance, +but statically typed as a pointer to +.IR A . +This is most useful when +.I A +is not in the same chain as +.I C +since in-chain upcasts are both trivial and rarely needed, +but the full set is defined for the sake of completeness. +.PP +Finally, the class object is defined as +.IP +.B extern const struct +.IB R __ilayout +.IB C __classobj; +.br +.B #define +.IB C __class +.BI (& C __classobj. j . r ) +.PP +The exported symbol +.IB C __classobj +contains the entire class instance. +This is usually rather unwieldy. +The macro +.IB C __class +is usable as a pointer of type +.B const +.I R +.BR * , +where +.I R +is the root metaclass of +.IR C , +i.e., the metaclass of the least specific superclass of +.IR C ; +usually this is +.BR "const SodClass *" . +. +.\"-------------------------------------------------------------------------- +.SH SEE ALSO +.BR sod (3). +. +.\"-------------------------------------------------------------------------- +.SH AUTHOR +Mark Wooding, +. +.\"----- That's all, folks -------------------------------------------------- diff --git a/lib/sod.3 b/lib/sod.3 new file mode 100644 index 0000000..83d004b --- /dev/null +++ b/lib/sod.3 @@ -0,0 +1,373 @@ +.\" -*-nroff-*- +.\" +.\" The Sod runtime library +.\" +.\" (c) 2015 Straylight/Edgeware +.\" +. +.\"----- Licensing notice --------------------------------------------------- +.\" +.\" This file is part of the Sensble Object Design, an object system for C. +.\" +.\" SOD is free software; you can redistribute it and/or modify +.\" it under the terms of the GNU General Public License as published by +.\" the Free Software Foundation; either version 2 of the License, or +.\" (at your option) any later version. +.\" +.\" SOD is distributed in the hope that it will be useful, +.\" but WITHOUT ANY WARRANTY; without even the implied warranty of +.\" MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +.\" GNU General Public License for more details. +.\" +.\" You should have received a copy of the GNU General Public License +.\" along with SOD; if not, write to the Free Software Foundation, +.\" Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. +. +.\"\X'tty: sgr 1' +.\" String definitions and font selection. +.ie t \{\ +. ds o \(bu +. if \n(.g .fam P +.\} +.el \{\ +. ds o o +.\} +. +.\" .hP TEXT -- start an indented paragraph with TEXT hanging off to the left +.de hP +.IP +\h'-\w'\fB\\$1\ \fP'u'\fB\\$1\ \fP\c +.. +. +.\"-------------------------------------------------------------------------- +.TH sod 3 "8 September 2015" "Straylight/Edgeware" "Sensible Object Design" +. +.SH NAME +sod \- Sensible Object Design runtime library +. +.\"-------------------------------------------------------------------------- +.SH SYNOPSIS +.B #include +.PP +.B void *\c +.B SOD_XCHAIN(\c +.IB chead , +.BI "const " cls " *" obj ); +.br +.B ptrdiff_t +.B SOD_OFFSETDIFF(\c +.IB type , +.IB mema , +.IB memb ); +.br +.IB cls "__ilayout *" \c +.B SOD_ILAYOUT(\c +.IB cls , +.IB chead , +.BI "const void *" obj ); +.br +.B SOD_CAR(\c +.IB arg , +.RB ... ); +.PP +.B const void *\c +.B SOD_CLASSOF(\c +.BI "const " cls " *" obj ); +.br +.B void *\c +.B SOD_INSTBASE(\c +.BI "const " cls " *" obj ); +.br +.IB cls " *" \c +.B SOD_CONVERT(\c +.IB cls , +.BI "const void *" obj ); +.br +.B SOD_DECL(\c +.IB cls , +.IB var ); +.PP +.B int +.B sod_subclassp(\c +.BI "const SodClass *" sub , +.BI "const SodClass *" super ); +.br +.B int +.B sod_convert(\c +.BI "const SodClass *" cls , +.BI "const void *" obj ); +. +.\"-------------------------------------------------------------------------- +.SH DESCRIPTION +. +The functions and macros defined here generally expect that +instances and classes inherit from the standard +.B SodObject +root object. +While the translator can (at some effort) support alternative roots, +they will require different run-time support machinery. +. +.SS Infrastructure macros +These macros are mostly intended for use in code +generated by the Sod translator. +Others may find them useful for special effects, +but they can be tricky to understand and use correctly +and can't really be recommended for general use. +.PP +The +.B SOD_XCHAIN +macro performs a `cross-chain upcast'. +Given a pointer +.I cls +.BI * obj +to an instance of a class of type +.I cls +and the nickname +.I chead +of the least specific class in one of +.IR cls 's +superclass chains which does not contain +.I cls +itself, +.B SOD_XCHAIN(\c +.IB chead , +.IB obj ) +returns the address of that chain's storage +within the instance layout as a raw +.B void * +pointer. +(Note that +.I cls +is not mentioned explicitly.) +This macro is used by the generated +.IB CLASS __CONV_ CLS +conversion macros, +which you are encouraged to use instead where possible. +.PP +The +.B SOD_OFFSETDIFF +macro returns the signed offset between +two members of a structure or union type. +Given a structure or union type +.IR type , +and two member names +.I mema +and +.IR memb , +then +.B SOD_OFFSETDIFF(\c +.IB type , +.IB mema , +.IB memb ) +gives the difference, in bytes, +between the objects +.IB x . mema +and +.IB x . memb +for any object +.I x +of type +.IR type . +This macro is used internally when generating vtables +and is not expected to be very useful elsewhere. +.PP +The +.B SOD_ILAYOUT +macro recovers the instance layout base address +from a pointer to one of its instance chains. +Specifically, given a class name +.IR cls , +the nickname +.I chead +of the least specific class in one of +.IR cls 's +superclass chains, +and a pointer +.I obj +to the instance storage for the chain containing +.I chead +within an exact instance of +.I cls +(i.e., not an instance of any proper subclass), +.B SOD_ILAYOUT(\c +.IB cls , +.IB chead , +.IB obj ) +returns the a pointer to the layout structure containing +.IB obj . +This macro is used internally in effective method bodies +and is not expected to be very useful elsewhere +since it's unusual to have such specific knowledge +about the dynamic type of an instance. +The +.B SOD_INSTBASE +macro (described below) is more suited to general use. +.PP +The +.B SOD_CAR +macro accepts one or more arguments +and expands to just its first argument, +discarding the others. +It is only defined if the C implementation +advertises support for C99. +It is used in the definitions of message convenience macros +for messages which accept a variable number of arguments +but no required arguments, +and is exported because the author has found such a thing useful in +other contexts. +. +.SS Utility macros +The following macros are expected to be useful +in Sod method definitions and client code. +.PP +The +.B SOD_CLASSOF +macro returns the class object describing an instance's dynamic class. +Given a pointer +.BI "const " cls " *" obj +to an instance, +.BI SOD_CLASSOF( obj ) +returns a pointer to +.IR obj 's +dynamic class, +which +(assuming +.I obj +is typed correctly in the first place) +will be a subclass of +.IR cls . +(If you wanted the class object for +.I cls +itself, +it's called +.IB cls __class \fR.) +.PP +The +.B SOD_INSTBASE +macro finds the base address of an instance's layout. +Given a pointer +.BI "const " cls " *" obj +to an instance, +.BI SOD_INSTBASE( obj ) +returns the base address of the storage allocated to +.IR obj . +This is useful if you want to free a dynamically allocated instance, +for example. +This macro needs to look up an offset in +.IR obj 's +vtable to do its work. +Compare +.B SOD_ILAYOUT +above, +which is faster but requires +precise knowledge of the instance's dynamic class. +.PP +The +.B SOD_CONVERT +macro performs general conversions +(up-, down-, and cross-casts) on instance pointers. +Given a class name +.I cls +and a pointer +.BI "const void *" obj +to an instance, +.B SOD_CONVERT(\c +.IB cls , +.IB obj ) +returns an appropriately converted pointer to +.I obj +if +.I obj +is indeed an instance of (some subclass of) +.IR cls ; +otherwise it returns a null pointer. +This macro is a simple wrapper around the +.B sod_convert +function described below, +which is useful in the common case that +the target class is known statically. +.PP +The +.B SOD_DECL +macro declares and initializes an instance +with automatic storage duration. +Given a class name +.I cls +and an identifier +.IR var , +.B SOD_DECL(\c +.IB cls , +.IB var ) +declares +.I var +to be a pointer to an instance of +.IR cls . +The instance is initialized in the sense that +its vtable and class pointers have been set up, +and slots for which initializers are defined +are set to the appropriate initial values. +The instance has automatic storage duration: +pointers to it will become invalid when control +exits the scope of the declaration. +. +.SS Functions +The following functions are provided. +.PP +The +.B sod_subclassp +function answers whether one class +.I sub +is actually a subclass of another class +.IR super . +.B sod_subclassp(\c +.IB sub , +.IB super ) +returns nonzero if and only if +.I sub +is a subclass of +.IR super . +This involves a run-time trawl through the class structures: +while some effort has been made to make it perform well +it's still not very fast. +.PP +The +.B sod_convert +function performs general conversions +(up-, down-, and cross-casts) on instance pointers. +Given a class pointer +.I cls +and an instance pointer +.IR obj , +.B sod_convert(\c +.IB cls , +.IB obj ) +returns an appropriately converted pointer to +.I obj +in the case that +.I obj +is an instance of (some subclass of) +.IR cls ; +otherwise it returns null. +This involves a run-time trawl through the class structures: +while some effort has been made to make it perform well +it's still not very fast. +For upcasts (where +.I cls +is a superclass of the static type of +.IR obj ) +the automatically defined conversion macros should be used instead, +because they're much faster and can't fail. +When the target class is known statically, +it's slightly more convenient to use the +.B SOD_CONVERT +macro instead. +. +.\"-------------------------------------------------------------------------- +.SH SEE ALSO +.BR sod-structs (3). +. +.\"-------------------------------------------------------------------------- +.SH AUTHOR +Mark Wooding, +. +.\"----- That's all, folks -------------------------------------------------- diff --git a/lib/sod.h b/lib/sod.h index cb6b046..efac06b 100644 --- a/lib/sod.h +++ b/lib/sod.h @@ -53,7 +53,7 @@ struct sod_vtable { * these. */ struct sod_instance { - struct sod_vtable *_vt; /* Pointer to (chain's) vtable */ + const struct sod_vtable *_vt; /* Pointer to (chain's) vtable */ }; /* Information about a particular chain of superclasses. In each class, @@ -76,14 +76,15 @@ struct sod_chain { * Arguments: @chead@ = nickname of target chain's head * @obj@ = pointer to an instance chain * - * Returns: Pointer to target chain, as a @char *@. + * Returns: Pointer to target chain, as a @void *@. * * Use: Utility for implementing cross-chain upcasts. It's probably * not that clever to use this macro directly; it's used to make * the automatically-generated upcast macros more palatable. */ -#define SOD_XCHAIN(chead, obj) ((char *)(obj) + (obj)->_vt->_off_##chead) +#define SOD_XCHAIN(chead, obj) \ + ((void *)((char *)(obj) + (obj)->_vt->_off_##chead)) /* --- @SOD_OFFSETDIFF@ --- * * @@ -124,7 +125,7 @@ struct sod_chain { ((struct cls##__ilayout *) \ ((char *)(obj) - offsetof(struct cls##__ilayout, chead))) -/* --- @SOD__CAR@ --- * +/* --- @SOD_CAR@ --- * * * Arguments: @...@ = a nonempty list of arguments * @@ -132,7 +133,7 @@ struct sod_chain { */ #if __STDC_VERSION__ >= 199901 -# define SOD__CAR(...) SOD__CARx(__VA_LIST__, _) +# define SOD_CAR(...) SOD__CARx(__VA_LIST__, _) # define SOD__CARx(a, ...) a #endif diff --git a/src/Makefile.am b/src/Makefile.am index 53880d8..c7779f9 100644 --- a/src/Makefile.am +++ b/src/Makefile.am @@ -90,8 +90,8 @@ LISP_SOURCES += method-aggregate.lisp 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. diff --git a/src/Makefile.in b/src/Makefile.in index 765212b..00da4c6 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -106,9 +106,9 @@ PRE_UNINSTALL = : 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 @@ -328,6 +328,7 @@ MAINTAINERCLEANFILES = SUFFIXES = .c .h .sod BUILT_SOURCES = pkginclude_HEADERS = +dist_man_MANS = ###-------------------------------------------------------------------------- ### Include and library path. @@ -393,7 +394,7 @@ LISP_SOURCES = sod.asd package.lisp utilities.lisp parser/package.lisp \ 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 diff --git a/src/builtin.lisp b/src/builtin.lisp index 8b4407b..5aad5f5 100644 --- a/src/builtin.lisp +++ b/src/builtin.lisp @@ -95,7 +95,7 @@ static void *~A__imprint(void *p) { struct ~A *sod__obj = p; - ~:{sod__obj->~A.~A._vt = &~A;~:^~% ~} + ~:{sod__obj->~A.~A._vt = &~A.~A;~:^~% ~} return (p); }~2%" class @@ -105,7 +105,8 @@ static void *~A__imprint(void *p) (tail (ichain-tail ichain))) (list (sod-class-nickname head) (sod-class-nickname tail) - (vtable-name class head)))) + (vtable-name class head) + (sod-class-nickname tail)))) (ilayout-ichains ilayout))))) (define-class-slot "init" (class stream) @@ -331,4 +332,7 @@ static const SodClass *const ~A__cpl[] = { (bootstrap-classes module)) (setf *builtin-module* module))) +(define-clear-the-decks builtin-module + (unless *builtin-module* (make-builtin-module))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/c-types-class-impl.lisp b/src/c-types-class-impl.lisp index 36e9c50..da16cd2 100644 --- a/src/c-types-class-impl.lisp +++ b/src/c-types-class-impl.lisp @@ -30,8 +30,8 @@ (export '(c-class-type c-type-class)) (defclass c-class-type (simple-c-type) - ((class :initarg :class :initform nil - :type (or null sod-class) :accessor c-type-class) + ((%class :initarg :class :initform nil + :type (or null sod-class) :accessor c-type-class) (tag :initarg :tag)) (:documentation "A SOD class, as a C type. diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index b4f02e1..4a0f6e2 100644 --- a/src/c-types-impl.lisp +++ b/src/c-types-impl.lisp @@ -485,7 +485,7 @@ (list (argument-name arg) (argument-type arg)))) (c-function-arguments type)))) -(export '(fun function func fn)) +(export '(fun function () func fn)) (define-c-type-syntax fun (ret &rest args) "Return the type of functions which returns RET and has arguments ARGS. diff --git a/src/c-types-proto.lisp b/src/c-types-proto.lisp index 9481a99..b9b61bf 100644 --- a/src/c-types-proto.lisp +++ b/src/c-types-proto.lisp @@ -149,7 +149,7 @@ This function is suitable for use in `format's ~/.../ command.")) -(export 'expand-c-type-spec) +(export '(expand-c-type-spec expand-c-type-form)) (eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric expand-c-type-spec (spec) (:documentation @@ -239,11 +239,13 @@ ;;; Function arguments. (export '(argument argumentp make-argument argument-name argument-type)) -(defstruct (argument (:constructor make-argument (name type)) +(defstruct (argument (:constructor make-argument (name type + &aux (%type type))) (:predicate argumentp)) "Simple structure representing a function argument." name - type) + %type) +(define-access-wrapper argument-type argument-%type) (export 'commentify-argument-name) (defgeneric commentify-argument-name (name) diff --git a/src/class-finalize-impl.lisp b/src/class-finalize-impl.lisp index 39ac234..9c34bd7 100644 --- a/src/class-finalize-impl.lisp +++ b/src/class-finalize-impl.lisp @@ -381,12 +381,6 @@ (with-slots (chain-head chain chains) class (setf (values chain-head chain chains) (compute-chains class))) - ;; FIXME: make these slots autovivifying. - (with-slots (ilayout effective-methods vtables) class - (setf ilayout (compute-ilayout class)) - (setf effective-methods (compute-effective-methods class)) - (setf vtables (compute-vtables class))) - ;; Done. (setf (sod-class-state class) :finalized) t) @@ -397,4 +391,18 @@ (:finalized t)))) +(macrolet ((define-layout-slot (slot (class) &body body) + `(define-on-demand-slot sod-class ,slot (,class) + (check-class-is-finalized ,class) + ,@body))) + (flet ((check-class-is-finalized (class) + (unless (eq (sod-class-state class) :finalized) + (error "Class ~S is not finalized" class)))) + (define-layout-slot %ilayout (class) + (compute-ilayout class)) + (define-layout-slot effective-methods (class) + (compute-effective-methods class)) + (define-layout-slot vtables (class) + (compute-vtables class)))) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-layout-impl.lisp b/src/class-layout-impl.lisp index 950db2b..7a2d9cc 100644 --- a/src/class-layout-impl.lisp +++ b/src/class-layout-impl.lisp @@ -129,12 +129,6 @@ (sod-class-messages super))) (sod-class-precedence-list class))) -(defmethod slot-unbound - (clos-class (class sod-class) (slot-name (eql 'effective-methods))) - (declare (ignore clos-class)) - (setf (slot-value class 'effective-methods) - (compute-effective-methods class))) - ;;;-------------------------------------------------------------------------- ;;; Instance layout. @@ -207,12 +201,6 @@ (reverse chain))) (sod-class-chains class)))) -(defmethod slot-unbound - (clos-class (class sod-class) (slot-name (eql 'ilayout))) - (declare (ignore clos-class)) - (setf (slot-value class 'ilayout) - (compute-ilayout class))) - ;;;-------------------------------------------------------------------------- ;;; Vtable layout. @@ -390,10 +378,4 @@ (compute-vtable class (reverse chain))) (sod-class-chains class))) -(defmethod slot-unbound - (clos-class (class sod-class) (slot-name (eql 'vtables))) - (declare (ignore clos-class)) - (setf (slot-value class 'vtables) - (compute-vtables class))) - ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/class-layout-proto.lisp b/src/class-layout-proto.lisp index 19bb897..684fb32 100644 --- a/src/class-layout-proto.lisp +++ b/src/class-layout-proto.lisp @@ -31,7 +31,7 @@ (export '(effective-slot effective-slot-class effective-slot-direct-slot effective-slot-initializer)) (defclass effective-slot () - ((class :initarg :class :type sod-slot :reader effective-slot-class) + ((%class :initarg :class :type sod-slot :reader effective-slot-class) (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot) (initializer :initarg :initializer :type (or sod-initializer null) :reader effective-slot-initializer)) @@ -65,7 +65,7 @@ (export '(islots islots-class islots-subclass islots-slots)) (defclass islots () - ((class :initarg :class :type sod-class :reader islots-class) + ((%class :initarg :class :type sod-class :reader islots-class) (subclass :initarg :subclass :type sod-class :reader islots-subclass) (slots :initarg :slots :type list :reader islots-slots)) (:documentation @@ -88,7 +88,7 @@ (export '(vtable-pointer vtable-pointer-class vtable-pointer-chain-head vtable-pointer-chain-tail)) (defclass vtable-pointer () - ((class :initarg :class :type sod-class :reader vtable-pointer-class) + ((%class :initarg :class :type sod-class :reader vtable-pointer-class) (chain-head :initarg :chain-head :type sod-class :reader vtable-pointer-chain-head) (chain-tail :initarg :chain-tail :type sod-class @@ -106,7 +106,7 @@ (export '(ichain ichain-class ichain-head ichain-tail ichain-body)) (defclass ichain () - ((class :initarg :class :type sod-class :reader ichain-class) + ((%class :initarg :class :type sod-class :reader ichain-class) (chain-head :initarg :chain-head :type sod-class :reader ichain-head) (chain-tail :initarg :chain-tail :type sod-class :reader ichain-tail) (body :initarg :body :type list :reader ichain-body)) @@ -133,7 +133,7 @@ (export '(ilayout ilayout-class ilayout-ichains)) (defclass ilayout () - ((class :initarg :class :type sod-class :reader ilayout-class) + ((%class :initarg :class :type sod-class :reader ilayout-class) (ichains :initarg :ichains :type list :reader ilayout-ichains)) (:documentation "All of the instance layout for a class. @@ -152,7 +152,7 @@ ;;; vtmsgs (defclass vtmsgs () - ((class :initarg :class :type sod-class :reader vtmsgs-class) + ((%class :initarg :class :type sod-class :reader vtmsgs-class) (subclass :initarg :subclass :type sod-class :reader vtmsgs-subclass) (chain-head :initarg :chain-head :type sod-class :reader vtmsgs-chain-head) @@ -169,7 +169,7 @@ 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. @@ -186,7 +186,7 @@ (export '(class-pointer class-pointer-class class-pointer-chain-head class-pointer-metaclass class-pointer-meta-chain-head)) (defclass class-pointer () - ((class :initarg :class :type sod-class :reader class-pointer-class) + ((%class :initarg :class :type sod-class :reader class-pointer-class) (chain-head :initarg :chain-head :type sod-class :reader class-pointer-chain-head) (metaclass :initarg :metaclass :type sod-class @@ -216,7 +216,7 @@ (export '(base-offset base-offset-class base-offset-chain-head)) (defclass base-offset () - ((class :initarg :class :type sod-class :reader base-offset-class) + ((%class :initarg :class :type sod-class :reader base-offset-class) (chain-head :initarg :chain-head :type sod-class :reader base-offset-chain-head)) (:documentation @@ -237,7 +237,7 @@ (export '(chain-offset chain-offset-class chain-offset-chain-head chain-offset-target-head)) (defclass chain-offset () - ((class :initarg :class :type sod-class :reader chain-offset-class) + ((%class :initarg :class :type sod-class :reader chain-offset-class) (chain-head :initarg :chain-head :type sod-class :reader chain-offset-chain-head) (target-head :initarg :target-head :type sod-class @@ -263,7 +263,7 @@ (export '(vtable vtable-class vtable-body vtable-chain-head vtable-chain-tail)) (defclass vtable () - ((class :initarg :class :type sod-class :reader vtable-class) + ((%class :initarg :class :type sod-class :reader vtable-class) (chain-head :initarg :chain-head :type sod-class :reader vtable-chain-head) (chain-tail :initarg :chain-tail :type sod-class diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index f9d5734..878f813 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -172,7 +172,7 @@ (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)) @@ -216,7 +216,7 @@ (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) @@ -226,7 +226,7 @@ (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 @@ -235,7 +235,7 @@ (defmethod check-method-type ((method sod-method) (message sod-message) (type c-function-type)) - (with-slots ((msgtype type)) message + (with-slots ((msgtype %type)) message (unless (c-type-equal-p (c-type-subtype msgtype) (c-type-subtype type)) (error "Method return type ~A doesn't match message ~A" diff --git a/src/class-output.lisp b/src/class-output.lisp index 2ab6363..35269a7 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -98,8 +98,8 @@ (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)))) @@ -138,7 +138,7 @@ 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)) @@ -165,7 +165,7 @@ 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)) @@ -192,7 +192,7 @@ (hook-output item reason sequencer))) (defmethod hook-output progn ((ilayout ilayout) (reason (eql :h)) sequencer) - (with-slots (class ichains) ilayout + (with-slots ((class %class) ichains) ilayout (sequence-output (stream sequencer) ((class :ilayout :start) (format stream "/* Instance layout. */~@ @@ -204,7 +204,7 @@ (hook-output ichain 'ilayout sequencer)))) (defmethod hook-output progn ((ichain ichain) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) ichain + (with-slots ((class %class) chain-head chain-tail) ichain (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :ichains :start) @@ -235,7 +235,7 @@ (defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout)) sequencer) - (with-slots (class chain-head chain-tail) ichain + (with-slots ((class %class) chain-head chain-tail) ichain (sequence-output (stream sequencer) ((class :ilayout :slots) (format stream " union ~A ~A;~%" @@ -245,7 +245,7 @@ (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtptr + (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) ((class :ichain chain-head :slots) (format stream " const struct ~A *_vt;~%" @@ -256,7 +256,7 @@ (hook-output slot reason sequencer))) (defmethod hook-output progn ((islots islots) (reason (eql :h)) sequencer) - (with-slots (class subclass slots) islots + (with-slots ((class %class) subclass slots) islots (sequence-output (stream sequencer) ((subclass :ichain (sod-class-chain-head class) :slots) (format stream " struct ~A ~A;~%" @@ -273,7 +273,7 @@ (defmethod hook-output progn ((method sod-method) (reason (eql :h)) sequencer) - (with-slots (class) method + (with-slots ((class %class)) method (sequence-output (stream sequencer) ((class :methods) (let ((type (sod-method-function-type method))) @@ -283,7 +283,7 @@ (format stream ";~%")))))) (defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (with-slots ((class %class) chain-head chain-tail) vtable (when (eq class chain-tail) (sequence-output (stream sequencer) :constraint ((class :vtables :start) @@ -296,15 +296,27 @@ struct ~A {~%" (vtable-struct-tag chain-tail chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%")))) + (format stream "};~2%") + (format stream "/* Union of equivalent superclass vtables. */~@ + union ~A {~@ + ~:{ struct ~A ~A;~%~}~ + };~2%" + (vtable-union-tag chain-tail chain-head) + + ;; As for the ichain union, make sure the most specific + ;; class is first. + (mapcar (lambda (super) + (list (vtable-struct-tag super chain-head) + (sod-class-nickname super))) + (sod-class-chain chain-tail)))))) (sequence-output (stream sequencer) ((class :vtable-externs) - (format stream "~@~%" - (vtable-struct-tag chain-tail chain-head) + (format stream "~@~%" + (vtable-union-tag chain-tail chain-head) class (sod-class-nickname chain-head)))))) (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h)) sequencer) - (with-slots (class subclass chain-head chain-tail) vtmsgs + (with-slots ((class %class) subclass chain-head chain-tail) vtmsgs (sequence-output (stream sequencer) ((subclass :vtable chain-head :slots) (format stream " struct ~A ~A;~%" @@ -315,7 +327,7 @@ (reason (eql 'vtmsgs)) sequencer) (when (vtmsgs-entries vtmsgs) - (with-slots (class subclass) vtmsgs + (with-slots ((class %class) subclass) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtmsgs :start) (subclass :vtmsgs class :start) @@ -352,7 +364,7 @@ (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~];~%" @@ -361,7 +373,7 @@ (sod-class-nickname meta-chain-head))))))) (defmethod hook-output progn ((boff base-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head) boff + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (write-line " size_t _base;" stream))))) @@ -369,7 +381,7 @@ (defmethod hook-output progn ((choff chain-offset) (reason (eql :h)) sequencer) - (with-slots (class chain-head target-head) choff + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) ((class :vtable chain-head :slots) (format stream " ptrdiff_t _off_~A;~%" @@ -415,7 +427,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c)) sequencer) - (with-slots (class body) method + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -430,7 +442,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method sod-method) (reason (eql :c)) sequencer) - (with-slots (class body) method + (with-slots ((class %class) body) method (unless body (return-from hook-output)) (sequence-output (stream sequencer) @@ -452,7 +464,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((method basic-effective-method) (reason (eql :c)) sequencer) - (with-slots (class functions) method + (with-slots ((class %class) functions) method (sequence-output (stream sequencer) ((class :effective-methods) (dolist (func functions) @@ -462,7 +474,7 @@ const struct ~A ~A__classobj = {~%" ;;; Vtables. (defmethod hook-output progn ((vtable vtable) (reason (eql :c)) sequencer) - (with-slots (class chain-head chain-tail) vtable + (with-slots ((class %class) chain-head chain-tail) vtable (sequence-output (stream sequencer) :constraint ((class :vtables :start) (class :vtable chain-head :start) @@ -470,17 +482,17 @@ const struct ~A ~A__classobj = {~%" (class :vtables :end)) ((class :vtable chain-head :start) (format stream "/* Vtable for ~A chain. */~@ - const struct ~A ~A = {~%" + const union ~A ~A = { {~%" chain-head - (vtable-struct-tag chain-tail chain-head) + (vtable-union-tag chain-tail chain-head) (vtable-name class chain-head))) ((class :vtable chain-head :end) - (format stream "};~2%"))))) + (format stream "} };~2%"))))) (defmethod hook-output progn ((cptr class-pointer) (reason (eql :c)) sequencer) - (with-slots (class chain-head metaclass meta-chain-head) cptr + (with-slots ((class %class) chain-head metaclass meta-chain-head) cptr (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :class-pointer metaclass) @@ -496,7 +508,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname metaclass)))))) (defmethod hook-output progn ((boff base-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head) boff + (with-slots ((class %class) chain-head) boff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :base-offset) @@ -510,7 +522,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((choff chain-offset) (reason (eql :c)) sequencer) - (with-slots (class chain-head target-head) choff + (with-slots ((class %class) chain-head target-head) choff (sequence-output (stream sequencer) :constraint ((class :vtable chain-head :start) (class :vtable chain-head :chain-offset target-head) @@ -523,7 +535,7 @@ const struct ~A ~A__classobj = {~%" (sod-class-nickname target-head)))))) (defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c)) sequencer) - (with-slots (class subclass chain-head) vtmsgs + (with-slots ((class %class) subclass chain-head) vtmsgs (sequence-output (stream sequencer) :constraint ((subclass :vtable chain-head :start) (subclass :vtable chain-head :vtmsgs class :start) @@ -539,7 +551,7 @@ const struct ~A ~A__classobj = {~%" (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))) @@ -555,7 +567,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((ichain ichain) (reason (eql 'class)) sequencer) - (with-slots (class chain-head) ichain + (with-slots ((class %class) chain-head) ichain (sequence-output (stream sequencer) :constraint ((*instance-class* :object :start) (*instance-class* :object chain-head :ichain :start) @@ -570,7 +582,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((islots islots) (reason (eql 'class)) sequencer) - (with-slots (class) islots + (with-slots ((class %class)) islots (let ((chain-head (sod-class-chain-head class))) (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) @@ -586,14 +598,16 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class)) sequencer) - (with-slots (class chain-head chain-tail) vtptr + (with-slots ((class %class) chain-head chain-tail) vtptr (sequence-output (stream sequencer) :constraint ((*instance-class* :object chain-head :ichain :start) (*instance-class* :object chain-head :vtable) (*instance-class* :object chain-head :ichain :end)) ((*instance-class* :object chain-head :vtable) - (format stream " &~A__vtable_~A,~%" - class (sod-class-nickname chain-head)))))) + (format stream " /* ~17@A = */ &~A.~A,~%" + "_vt" + (vtable-name class chain-head) + (sod-class-nickname chain-tail)))))) (defgeneric find-class-initializer (slot class) (:method ((slot effective-slot) (class sod-class)) @@ -637,7 +651,7 @@ const struct ~A ~A__classobj = {~%" (defmethod hook-output progn ((slot effective-slot) (reason (eql 'class)) sequencer) - (with-slots (class (dslot slot)) slot + (with-slots ((class %class) (dslot slot)) slot (let ((instance *instance-class*) (super (sod-slot-class dslot))) (sequence-output (stream sequencer) diff --git a/src/class-utilities.lisp b/src/class-utilities.lisp index f00bc64..0aec35a 100644 --- a/src/class-utilities.lisp +++ b/src/class-utilities.lisp @@ -189,6 +189,10 @@ (defun vtmsgs-struct-tag (class super) (format nil "~A__vtmsgs_~A" class (sod-class-nickname super))) +(export 'vtable-union-tag) +(defun vtable-union-tag (class chain-head) + (format nil "~A__vtu_~A" class (sod-class-nickname chain-head))) + (export 'vtable-struct-tag) (defun vtable-struct-tag (class chain-head) (format nil "~A__vt_~A" class (sod-class-nickname chain-head))) diff --git a/src/classes.lisp b/src/classes.lisp index a670b8e..afbb485 100644 --- a/src/classes.lisp +++ b/src/classes.lisp @@ -78,13 +78,13 @@ (class-precedence-list :type list :accessor sod-class-precedence-list) - (type :type c-class-type :accessor sod-class-type) + (%type :type c-class-type :accessor sod-class-type) (chain-head :type sod-class :accessor sod-class-chain-head) (chain :type list :accessor sod-class-chain) (chains :type list :accessor sod-class-chains) - (ilayout :type ilayout :accessor sod-class-ilayout) + (%ilayout :type ilayout :accessor sod-class-ilayout) (effective-methods :type list :accessor sod-class-effective-methods) (vtables :type list :accessor sod-class-vtables) @@ -194,7 +194,7 @@ 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 @@ -220,8 +220,8 @@ ((name :initarg :name :type string :reader sod-slot-name) (location :initarg :location :initform (file-location nil) :type file-location :reader file-location) - (class :initarg :class :type sod-class :reader sod-slot-class) - (type :initarg :type :type c-type :reader sod-slot-type)) + (%class :initarg :class :type sod-class :reader sod-slot-class) + (%type :initarg :type :type c-type :reader sod-slot-type)) (:documentation "Slots are units of information storage in instances. @@ -259,7 +259,7 @@ ((slot :initarg :slot :type sod-slot :reader sod-initializer-slot) (location :initarg :location :initform (file-location nil) :type file-location :reader file-location) - (class :initarg :class :type sod-class :reader sod-initializer-class) + (%class :initarg :class :type sod-class :reader sod-initializer-class) (value-kind :initarg :value-kind :type keyword :reader sod-initializer-value-kind) (value-form :initarg :value-form :type c-fragment @@ -338,8 +338,8 @@ ((name :initarg :name :type string :reader sod-message-name) (location :initarg :location :initform (file-location nil) :type file-location :reader file-location) - (class :initarg :class :type sod-class :reader sod-message-class) - (type :initarg :type :type c-function-type :reader sod-message-type)) + (%class :initarg :class :type sod-class :reader sod-message-class) + (%type :initarg :type :type c-function-type :reader sod-message-type)) (:documentation "Messages are the means for stimulating an object to behave. @@ -390,8 +390,8 @@ ((message :initarg :message :type sod-message :reader sod-method-message) (location :initarg :location :initform (file-location nil) :type file-location :reader file-location) - (class :initarg :class :type sod-class :reader sod-method-class) - (type :initarg :type :type c-function-type :reader sod-method-type) + (%class :initarg :class :type sod-class :reader sod-method-class) + (%type :initarg :type :type c-function-type :reader sod-method-type) (body :initarg :body :type (or c-fragment null) :reader sod-method-body)) (:documentation "(Direct) methods are units of behaviour. diff --git a/src/codegen-impl.lisp b/src/codegen-impl.lisp index acb0da1..170f4a8 100644 --- a/src/codegen-impl.lisp +++ b/src/codegen-impl.lisp @@ -40,7 +40,6 @@ (defmethod commentify-argument-name ((name temporary-name)) nil) -(export 'temporary-function) (defun temporary-function () "Return a temporary function name." (make-instance 'temporary-function @@ -66,21 +65,26 @@ ;; 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. @@ -95,8 +99,10 @@ ;; 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. diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index e947a72..535839c 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -49,7 +49,7 @@ ;; Root class. -(export 'temporary-name) +(export '(temporary-name temp-tag)) (defclass temporary-name () ((tag :initarg :tag :reader temp-tag)) (:documentation @@ -167,35 +167,42 @@ (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. diff --git a/src/debug.lisp b/src/final.lisp similarity index 59% rename from src/debug.lisp rename to src/final.lisp index af5f104..5df72f1 100644 --- a/src/debug.lisp +++ b/src/final.lisp @@ -1,6 +1,6 @@ ;;; -*-lisp-*- ;;; -;;; Debugging utilities for Sod +;;; Finishing touches for Sod ;;; ;;; (c) 2015 Straylight/Edgeware ;;; @@ -25,6 +25,9 @@ (cl:in-package #:sod) +;;;-------------------------------------------------------------------------- +;;; Debugging utilities. + (export '*debugout-pathname*) (defvar *debugout-pathname* #p"debugout.c") @@ -32,7 +35,6 @@ (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* @@ -41,4 +43,28 @@ :if-does-not-exist :create) (output-module (read-module path) reason out))) +;;;-------------------------------------------------------------------------- +;;; Calisthenics. + +(export 'exercise) +(defun exercise () + "Exercise the pieces of the metaobject protocol. + + In some Lisps, the compiler is run the first time methods are called, to + do fancy just-in-time optimization things. This is great, only the + program doesn't actually run for very long and a lot of that work is + wasted because we're going to have to do it again next time the program + starts. Only, if we exercise the various methods, or at least a large + fraction of them, before we dump an image, then everything will be fast. + + That's the theory anyway. Call this function before you dump an image and + see what happens." + + (clear-the-decks) + (dolist (reason '(:h :c)) + (with-output-to-string (bitbucket) + (output-module *builtin-module* reason bitbucket))) + + (clear-the-decks)) + ;;;----- That's all, folks -------------------------------------------------- diff --git a/src/frontend.lisp b/src/frontend.lisp index 9ed6f30..98652ec 100644 --- a/src/frontend.lisp +++ b/src/frontend.lisp @@ -30,6 +30,12 @@ (cl:in-package #:sod-frontend) ;;;-------------------------------------------------------------------------- +;;; Preparation for dumping. + +(clear-the-decks) +(exercise) + +;;;-------------------------------------------------------------------------- ;;; The main program. (eval-when (:compile-toplevel :load-toplevel :execute) @@ -85,7 +91,7 @@ :usage "SOURCES..." :options (options (help-options :short-version #\V) - "Crazy options" + "Translator options" (#\I "include" (:arg "DIR") ("Search DIR for module imports.") (list *module-dirs* 'string)) @@ -110,9 +116,6 @@ (or builtinsp args)) (die-usage)) - ;; Prepare the builtins. - (make-builtin-module) - ;; Do the main parsing job. (multiple-value-bind (hunoz nerror nwarn) (count-and-report-errors () @@ -169,12 +172,10 @@ ;; If we're writing the builtin module then now seems like a ;; good time to do that. (when builtinsp - (clear-the-decks) (hack-module *builtin-module*)) ;; Parse and write out the remaining modules. (dolist (arg args) - (clear-the-decks) (hack-module (read-module arg)))))) ;; Report on how well everything worked. diff --git a/src/method-impl.lisp b/src/method-impl.lisp index c5785a2..6c9b28d 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -40,33 +40,24 @@ inheriting its default behaviour. The function type protocol is implemented on `basic-message' using slot - reader methods. The actual values are computed on demand in methods - defined on `slot-unbound'.")) + reader methods. The actual values are computed on demand.")) -(defmethod slot-unbound (class - (message basic-message) - (slot-name (eql 'argument-tail))) - (declare (ignore class)) +(define-on-demand-slot basic-message argument-tail (message) (let ((seq 0)) - (setf (slot-value message 'argument-tail) - (mapcar (lambda (arg) - (if (or (eq arg :ellipsis) (argument-name arg)) arg - (make-argument (make-instance 'temporary-argument - :tag (prog1 seq - (incf seq))) - (argument-type arg)))) - (c-function-arguments (sod-message-type message)))))) - -(defmethod slot-unbound (class - (message basic-message) - (slot-name (eql 'no-varargs-tail))) - (declare (ignore class)) - (setf (slot-value message 'no-varargs-tail) - (mapcar (lambda (arg) - (if (eq arg :ellipsis) - (make-argument *sod-ap* (c-type va-list)) - arg)) - (sod-message-argument-tail message)))) + (mapcar (lambda (arg) + (if (or (eq arg :ellipsis) (argument-name arg)) arg + (make-argument (make-instance 'temporary-argument + :tag (prog1 seq + (incf seq))) + (argument-type arg)))) + (c-function-arguments (sod-message-type message))))) + +(define-on-demand-slot basic-message no-varargs-tail (message) + (mapcar (lambda (arg) + (if (eq arg :ellipsis) + (make-argument *sod-ap* (c-type va-list)) + arg)) + (sod-message-argument-tail message))) (defmethod sod-message-method-class ((message basic-message) (class sod-class) pset) @@ -120,25 +111,21 @@ categorization. The function type protocol is implemented on `basic-direct-method' using - slot reader methods. The actual values are computed on demand in methods - defined on `slot-unbound'.")) + slot reader methods.")) (defmethod shared-initialize :after ((method basic-direct-method) slot-names &key pset) (declare (ignore slot-names)) (default-slot (method 'role) (get-property pset :role :keyword nil))) -(defmethod slot-unbound - (class (method basic-direct-method) (slot-name (eql 'function-type))) - (declare (ignore class)) +(define-on-demand-slot basic-direct-method function-type (method) (let ((type (sod-method-type method))) - (setf (slot-value method 'function-type) - (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (sod-method-class method)))) - . (c-function-arguments type)))))) + (c-type (fun (lisp (c-type-subtype type)) + ("me" (* (class (sod-method-class method)))) + . (c-function-arguments type))))) (defmethod sod-method-function-name ((method basic-direct-method)) - (with-slots (class role message) method + (with-slots ((class %class) role message) method (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role (sod-class-nickname (sod-message-class message)) (sod-message-name message)))) @@ -159,7 +146,7 @@ (defmethod check-method-type ((method daemon-direct-method) (message sod-message) (type c-function-type)) - (with-slots ((msgtype type)) message + (with-slots ((msgtype %type)) message (unless (c-type-equal-p (c-type-subtype type) (c-type void)) (error "Method return type ~A must be `void'" (c-type-subtype type))) (unless (argument-lists-compatible-p (c-function-arguments msgtype) @@ -184,13 +171,9 @@ 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)) @@ -199,30 +182,25 @@ (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. @@ -246,17 +224,12 @@ correctly. The argument names protocol is implemented on `basic-effective-method' - using a slot reader method. The actual values are computed on demand in - methods defined on `slot-unbound'.")) + using a slot reader method.")) -(defmethod slot-unbound (class - (method basic-effective-method) - (slot-name (eql 'basic-argument-names))) - (declare (ignore class)) +(define-on-demand-slot basic-effective-method basic-argument-names (method) (let ((message (effective-method-message method))) - (setf (slot-value method 'basic-argument-names) - (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)) @@ -267,11 +240,8 @@ (sod-class-nickname message-class) (sod-message-name message)))) -(defmethod slot-unbound - (class (method basic-effective-method) (slot-name (eql 'functions))) - (declare (ignore class)) - (setf (slot-value method 'functions) - (compute-method-entry-functions method))) +(define-on-demand-slot basic-effective-method functions (method) + (compute-method-entry-functions method)) (export 'simple-effective-method) (defclass simple-effective-method (basic-effective-method) @@ -323,7 +293,8 @@ 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)) diff --git a/src/method-proto.lisp b/src/method-proto.lisp index 7fd08b8..b4b788d 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -32,7 +32,7 @@ (defclass effective-method () ((message :initarg :message :type sod-message :reader effective-method-message) - (class :initarg :class :type sod-class :reader effective-method-class)) + (%class :initarg :class :type sod-class :reader effective-method-class)) (:documentation "The behaviour invoked by sending a message to an instance of a class. @@ -80,8 +80,8 @@ (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 @@ -223,8 +223,8 @@ codegen-method codegen-target)) (defclass method-codegen (codegen) ((message :initarg :message :type sod-message :reader codegen-message) - (class :initarg :class :type sod-class :reader codegen-class) - (method :initarg :method :type effective-method :reader codegen-method) + (%class :initarg :class :type sod-class :reader codegen-class) + (%method :initarg :method :type effective-method :reader codegen-method) (target :initarg :target :reader codegen-target)) (:documentation "Augments CODEGEN with additional state regarding an effective method. @@ -257,10 +257,13 @@ ;;; Additional instructions. -(export 'convert-to-ilayout) -(definst convert-to-ilayout (stream) (class chain-head expr) +;; HACK: use gensyms for the `class' and `expr' slots to avoid leaking the +;; slot names, because `expr' is exported by our package, and `class' is +;; actually from the `common-lisp' package. +(definst convert-to-ilayout (stream :export t) + (#1=#:class chain-head #2=#:expr) (format stream "SOD_ILAYOUT(~@<~A, ~_~A, ~_~A~:>)" - class (sod-class-nickname chain-head) expr)) + #1# (sod-class-nickname chain-head) #2#)) ;;; Utilities. diff --git a/src/module-proto.lisp b/src/module-proto.lisp index acb1926..9c7fcaf 100644 --- a/src/module-proto.lisp +++ b/src/module-proto.lisp @@ -148,7 +148,8 @@ (export '(module module-name module-pset module-items module-dependencies)) (defclass module () ((name :initarg :name :type pathname :reader module-name) - (pset :initarg :pset :initform (make-pset) :type pset :reader module-pset) + (%pset :initarg :pset :initform (make-pset) + :type pset :reader module-pset) (items :initarg :items :initform nil :type list :accessor module-items) (dependencies :initarg :dependencies :initform nil :type list :accessor module-dependencies) diff --git a/src/output-proto.lisp b/src/output-proto.lisp index 3483daa..65068f3 100644 --- a/src/output-proto.lisp +++ b/src/output-proto.lisp @@ -119,6 +119,7 @@ ;;;-------------------------------------------------------------------------- ;;; Useful syntax. +(export 'sequence-output) (defmacro sequence-output ((streamvar sequencer) &body clauses) "Register output behaviour in a convenient manner. diff --git a/src/parser/floc-proto.lisp b/src/parser/floc-proto.lisp index ca5aaee..1c3c930 100644 --- a/src/parser/floc-proto.lisp +++ b/src/parser/floc-proto.lisp @@ -58,8 +58,8 @@ (export '(enclosing-condition enclosed-condition)) (define-condition enclosing-condition (condition) - ((enclosed-condition :initarg :condition :type condition - :reader enclosed-condition)) + ((%enclosed-condition :initarg :condition :type condition + :reader enclosed-condition)) (:documentation "A condition which encloses another condition diff --git a/src/parser/parser-expr-impl.lisp b/src/parser/parser-expr-impl.lisp index e0c681b..5ae4035 100644 --- a/src/parser/parser-expr-impl.lisp +++ b/src/parser/parser-expr-impl.lisp @@ -116,14 +116,14 @@ (defmethod apply-operator ((operator simple-unary-operator) (state expression-parse-state)) - (with-slots (function) operator + (with-slots ((function %function)) operator (with-slots (valstack) state (assert (not (null valstack))) (push (funcall function (pop valstack)) valstack)))) (defmethod apply-operator ((operator simple-binary-operator) (state expression-parse-state)) - (with-slots (function) operator + (with-slots ((function %function)) operator (with-slots (valstack) state (assert (not (or (null valstack) (null (cdr valstack))))) diff --git a/src/parser/parser-expr-proto.lisp b/src/parser/parser-expr-proto.lisp index 7fc2609..ec35445 100644 --- a/src/parser/parser-expr-proto.lisp +++ b/src/parser/parser-expr-proto.lisp @@ -154,7 +154,7 @@ (export 'simple-operator) (defclass simple-operator () - ((function :initarg :function :reader operator-function) + ((%function :initarg :function :reader operator-function) (name :initarg :name :initform "" :reader operator-name)) (:documentation diff --git a/src/parser/parser-impl.lisp b/src/parser/parser-impl.lisp index 0a7d667..352a725 100644 --- a/src/parser/parser-impl.lisp +++ b/src/parser/parser-impl.lisp @@ -129,12 +129,12 @@ (export 'string-parser) (defclass string-parser (character-parser-context) - ((string :initarg :string :reader parser-string) + ((%string :initarg :string :reader parser-string) (index :initarg :index :initform 0 :reader parser-index) - (length :initform (gensym "LEN-") :reader parser-length))) + (%length :initform (gensym "LEN-") :reader parser-length))) (defmethod wrap-parser ((context string-parser) form) - (with-slots (string index length) context + (with-slots ((string %string) index (length %length)) context `(let* (,@(unless (symbolp string) (let ((s string)) (setf string (gensym "STRING-")) diff --git a/src/parser/scanner-charbuf-impl.lisp b/src/parser/scanner-charbuf-impl.lisp index 65f6e1e..1919b69 100644 --- a/src/parser/scanner-charbuf-impl.lisp +++ b/src/parser/scanner-charbuf-impl.lisp @@ -65,7 +65,7 @@ (export 'charbuf-scanner) (defclass charbuf-scanner (character-scanner) - ((stream :initarg :stream :type stream) + ((%stream :initarg :stream :type stream) (buf :initform nil :type (or charbuf (member nil :eof))) (size :initform 0 :type (integer 0 #.charbuf-size)) (index :initform 0 :type (integer 0 #.charbuf-size)) @@ -143,7 +143,7 @@ (if we're currently rewound) or with a new buffer from the stream.")) (defmethod charbuf-scanner-fetch ((scanner charbuf-scanner)) - (with-slots (stream buf size index tail captures) scanner + (with-slots ((stream %stream) buf size index tail captures) scanner (loop (acond @@ -254,7 +254,7 @@ ;; Grab the filename from the underlying stream if we don't have a better ;; guess. (default-slot (scanner 'filename slot-names) - (with-slots (stream) scanner + (with-slots ((stream %stream)) scanner (aif (stream-pathname stream) (namestring it) nil))) ;; Get ready with the first character. diff --git a/src/parser/scanner-impl.lisp b/src/parser/scanner-impl.lisp index 0849648..2abdff4 100644 --- a/src/parser/scanner-impl.lisp +++ b/src/parser/scanner-impl.lisp @@ -62,12 +62,15 @@ (defstruct (string-scanner (:constructor make-string-scanner (string &key (start 0) end - &aux (index start) + &aux (%string string) + (index start) (limit (or end (length string)))))) "Scanner structure for a simple string scanner." - (string "" :type string :read-only t) + (%string "" :type string :read-only t) (index 0 :type (and fixnum unsigned-byte)) (limit nil :type (and fixnum unsigned-byte) :read-only t)) +(define-access-wrapper string-scanner-string string-scanner-%string + :read-only t) (defmethod scanner-at-eof-p ((scanner string-scanner)) (>= (string-scanner-index scanner) (string-scanner-limit scanner))) @@ -86,7 +89,7 @@ (defmethod scanner-interval ((scanner string-scanner) place-a &optional place-b) - (with-slots (string index) scanner + (with-slots ((string %string) index) scanner (subseq string place-a (or place-b index)))) ;;;-------------------------------------------------------------------------- @@ -94,13 +97,14 @@ (export 'list-scanner) (defstruct (list-scanner - (:constructor make-list-scanner (list))) + (:constructor make-list-scanner (list &aux (%list list)))) "Simple token scanner for lists. The list elements are the token semantic values; the token types are the names of the elements' classes. This is just about adequate for testing purposes, but is far from ideal for real use." - (list nil :type list)) + (%list nil :type list)) +(define-access-wrapper list-scanner-list list-scanner-%list) (defmethod scanner-step ((scanner list-scanner)) (pop (list-scanner-list scanner))) diff --git a/src/parser/scanner-proto.lisp b/src/parser/scanner-proto.lisp index d590d77..bd7e160 100644 --- a/src/parser/scanner-proto.lisp +++ b/src/parser/scanner-proto.lisp @@ -176,7 +176,7 @@ (export '(token-scanner token-type token-value)) (defclass token-scanner () - ((type :reader token-type) + ((%type :reader token-type) (value :reader token-value) (captures :initform 0 :type fixnum) (tail :initform nil :type (or token-scanner-place null)) @@ -206,7 +206,10 @@ ;; A place marker. (export '(token-scanner-place token-scanner-place-p)) -(defstruct token-scanner-place +(defstruct (token-scanner-place + (:constructor make-token-scanner-place + (&key scanner next type value line column + &aux (%type type)))) "A link in the chain of lookahead tokens; capturable as a place. If the scanner's place is captured, it starts to maintain a list of @@ -220,10 +223,12 @@ (scanner nil :type token-scanner :read-only t) (next nil :type (or token-scanner-place null)) - (type nil :read-only t) + (%type nil :read-only t) (value nil :read-only t) (line 1 :type (or fixnum null) :read-only t) (column 0 :type (or fixnum null) :read-only t)) +(define-access-wrapper token-scanner-place-type token-scanner-place-%type + :read-only t) ;; Protocol. diff --git a/src/parser/scanner-token-impl.lisp b/src/parser/scanner-token-impl.lisp index 8ab427a..7629b2d 100644 --- a/src/parser/scanner-token-impl.lisp +++ b/src/parser/scanner-token-impl.lisp @@ -39,11 +39,11 @@ (scanner-step scanner)) (defmethod scanner-at-eof-p ((scanner token-scanner)) - (with-slots (type) scanner + (with-slots ((type %type)) scanner (eq type :eof))) (defmethod scanner-step ((scanner token-scanner)) - (with-slots (type value tail captures line column) scanner + (with-slots ((type %type) value tail captures line column) scanner (acond ((and tail (token-scanner-place-next tail)) (setf type (token-scanner-place-type it) value (token-scanner-place-value it) @@ -64,7 +64,7 @@ (setf tail nil))))))) (defmethod scanner-capture-place ((scanner token-scanner)) - (with-slots (type value captures tail line column) scanner + (with-slots ((type %type) value captures tail line column) scanner (incf captures) (or tail (setf tail (make-token-scanner-place :scanner scanner @@ -72,7 +72,7 @@ :line line :column column))))) (defmethod scanner-restore-place ((scanner token-scanner) place) - (with-slots (type value tail line column) scanner + (with-slots ((type %type) value tail line column) scanner (setf type (token-scanner-place-type place) value (token-scanner-place-value place) line (token-scanner-place-line place) diff --git a/src/pset-proto.lisp b/src/pset-proto.lisp index 0c133d6..e58a928 100644 --- a/src/pset-proto.lisp +++ b/src/pset-proto.lisp @@ -45,7 +45,7 @@ (:constructor %make-property (name value &key type location seenp - &aux (key (property-key name))))) + &aux (key (property-key name)) (%type type)))) "A simple structure for holding a property in a property set. The main useful feature is the ability to tick off properties which have @@ -57,10 +57,11 @@ (name nil :type (or string symbol)) (value nil :type t) - (type nil :type symbol) + (%type nil :type symbol) (location (file-location nil) :type file-location) (key nil :type symbol) (seenp nil :type boolean)) +(define-access-wrapper p-type p-%type) (export 'decode-property) (defgeneric decode-property (raw) diff --git a/src/sod.asd b/src/sod.asd index aae3be1..f207df0 100644 --- a/src/sod.asd +++ b/src/sod.asd @@ -164,8 +164,8 @@ (: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. diff --git a/src/utilities.lisp b/src/utilities.lisp index be5ce56..98d314a 100644 --- a/src/utilities.lisp +++ b/src/utilities.lisp @@ -694,6 +694,38 @@ ,(loopguts indexvar t nil)))))))))) ;;;-------------------------------------------------------------------------- +;;; Structure accessor hacks. + +(export 'define-access-wrapper) +(defmacro define-access-wrapper (from to &key read-only) + "Make (FROM THING) work like (TO THING). + + If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like + (setf (TO THING) VALUE). + + This is mostly useful for structure slot accessors where the slot has to + be given an unpleasant name to avoid it being an external symbol." + `(progn + (declaim (inline ,from ,@(and (not read-only) `((setf ,from))))) + (defun ,from (object) + (,to object)) + ,@(and (not read-only) + `((defun (setf ,from) (value object) + (setf (,to object) value)))))) + +(export 'define-on-demand-slot) +(defmacro define-on-demand-slot (class slot (instance) &body body) + "Defines a slot which computes its initial value on demand. + + Sets up the named SLOT of CLASS to establish its value as the implicit + progn BODY, by defining an appropriate method on `slot-unbound'." + (with-gensyms (classvar slotvar) + `(defmethod slot-unbound + (,classvar (,instance ,class) (,slotvar (eql ',slot))) + (declare (ignore ,classvar)) + (setf (slot-value ,instance ',slot) (progn ,@body))))) + +;;;-------------------------------------------------------------------------- ;;; CLOS hacking. (export 'default-slot) diff --git a/test/Makefile.in b/test/Makefile.in index eecdc4a..a4fe227 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -105,8 +105,9 @@ PRE_UNINSTALL = : 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 @@ -321,6 +322,7 @@ MAINTAINERCLEANFILES = SUFFIXES = .c .h .sod BUILT_SOURCES = $(nodist_chimaera_SOURCES) pkginclude_HEADERS = +dist_man_MANS = ###-------------------------------------------------------------------------- ### Include and library path. diff --git a/test/chimaera.sod b/test/chimaera.sod index cc72a47..e9b9077 100644 --- a/test/chimaera.sod +++ b/test/chimaera.sod @@ -25,20 +25,20 @@ class Animal : SodObject { 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); } } @@ -55,26 +55,26 @@ static void tickle_animal(Animal *a) for (i = 0; i < 3; i++) { printf("tickle %s #%d...\n", a->_vt->_class->cls.name, i); - a->_vt->nml.tickle(a); + Animal_tickle(a); } } static void provoke_lion(Lion *l) { printf("provoking %s as a lion\n", l->_vt->_class->cls.name); - l->_vt->lion.bite(l); + Lion_bite(l); } static void provoke_goat(Goat *g) { printf("provoking %s as a goat\n", g->_vt->_class->cls.name); - g->_vt->goat.butt(g); + Goat_butt(g); } static void provoke_serpent(Serpent *s) { printf("provoking %s as a serpent\n", s->_vt->_class->cls.name); - s->_vt->serpent.bite(s); + Serpent_bite(s); } int main(void) diff --git a/vars.am b/vars.am index 5150203..1b360ee 100644 --- a/vars.am +++ b/vars.am @@ -43,6 +43,8 @@ bin_PROGRAMS = check_PROGRAMS = pkginclude_HEADERS = +dist_man_MANS = + CLEANFILES += $(BUILT_SOURCES) ###--------------------------------------------------------------------------