COPYING
COPYING.LIB
config/auto-version
+config/confsubst
SUBDIRS =
###--------------------------------------------------------------------------
+### Package-configuration file.
+
+pkgconfigdir = $(libdir)/pkgconfig
+pkgconfig_DATA = sod.pc
+CLEANFILES += sod.pc
+EXTRA_DIST += sod.pc.in
+
+sod.pc: sod.pc.in Makefile
+ $(SUBST) $(srcdir)/sod.pc.in >$@.new $(SUBSTITUTIONS) && mv $@.new $@
+
+###--------------------------------------------------------------------------
### Subdirectories to build
## The SOD translator.
## The runtime support library.
SUBDIRS += lib
+## The tests and examples.
+SUBDIRS += test
+
+###--------------------------------------------------------------------------
+### Distribution.
+
+## Release number.
+dist-hook:
+ echo $(VERSION) >$(distdir)/RELEASE
+
+## Additional build tools.
+EXTRA_DIST += config/auto-version
+EXTRA_DIST += config/confsubst
+
+###--------------------------------------------------------------------------
+### Debian.
+
+EXTRA_DIST += debian/rules debian/copyright
+EXTRA_DIST += debian/control debian/changelog
+EXTRA_DIST += debian/compat
+
+## libsod
+EXTRA_DIST += debian/libsod.install
+
+## libsod-dev
+EXTRA_DIST += debian/libsod-dev.install
+
+## sod
+EXTRA_DIST += debian/sod.install
+
+## sod-dev
+EXTRA_DIST += debian/sod-dev.install
+
###----- That's all, folks --------------------------------------------------
### Miscellaneous useful definitions.
+
VPATH = @srcdir@
am__make_dryrun = \
{ \
mkinstalldirs = $(install_sh) -d
CONFIG_CLEAN_FILES =
CONFIG_CLEAN_VPATH_FILES =
-am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgincludedir)"
+am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgconfigdir)" \
+ "$(DESTDIR)$(pkgincludedir)"
PROGRAMS = $(bin_PROGRAMS)
AM_V_GEN = $(am__v_GEN_@AM_V@)
am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
|| { echo " ( cd '$$dir' && rm -f" $$files ")"; \
$(am__cd) "$$dir" && rm -f $$files; }; \
}
+DATA = $(pkgconfig_DATA)
HEADERS = $(pkginclude_HEADERS)
RECURSIVE_CLEAN_TARGETS = mostlyclean-recursive clean-recursive \
distclean-recursive maintainer-clean-recursive
ECHO_T = @ECHO_T@
EGREP = @EGREP@
EXEEXT = @EXEEXT@
-FASL_TYPE = @FASL_TYPE@
FGREP = @FGREP@
GREP = @GREP@
INSTALL = @INSTALL@
docdir = @docdir@
dvidir = @dvidir@
exec_prefix = @exec_prefix@
+fasl = @fasl@
host = @host@
host_alias = @host_alias@
host_cpu = @host_cpu@
###--------------------------------------------------------------------------
### Initial values for common variables.
-EXTRA_DIST =
-CLEANFILES = $(BUILT_SOURCES)
+
+###--------------------------------------------------------------------------
+### Debian.
+EXTRA_DIST = sod.pc.in config/auto-version config/confsubst \
+ debian/rules debian/copyright debian/control debian/changelog \
+ debian/compat debian/libsod.install debian/libsod-dev.install \
+ debian/sod.install debian/sod-dev.install
+CLEANFILES = $(BUILT_SOURCES) sod.pc
DISTCLEANFILES =
MAINTAINERCLEANFILES =
SUFFIXES = .c .h .sod
LDADD = $(top_builddir)/lib/libsod.la
###--------------------------------------------------------------------------
+### Standard configuration substitutions.
+confsubst = $(top_srcdir)/config/confsubst
+SUBSTITUTIONS = \
+ prefix=$(prefix) exec_prefix=$(exec_prefix) \
+ libdir=$(libdir) includedir=$(includedir) \
+ bindir=$(bindir) sbindir=$(sbindir) \
+ PACKAGE=$(PACKAGE) VERSION=$(VERSION)
+
+V_SUBST = $(V_SUBST_$(V))
+V_SUBST_ = $(V_SUBST_$(AM_DEFAULT_VERBOSITY))
+V_SUBST_0 = @echo " SUBST $@";
+SUBST = $(V_SUBST)$(confsubst)
+
+###--------------------------------------------------------------------------
### Translating SOD input files.
SOD = $(top_builddir)/src/sod
+V_SOD_c = $(V_SOD_c_$(V))
+V_SOD_c_ = $(V_SOD_c_$(AM_DEFAULT_VERBOSITY))
+V_SOD_c_0 = @echo " SOD[c] $@";
+V_SOD_h = $(V_SOD_h_$(V))
+V_SOD_h_ = $(V_SOD_h_$(AM_DEFAULT_VERBOSITY))
+V_SOD_h_0 = @echo " SOD[h] $@";
+
+###--------------------------------------------------------------------------
+### Silent rules for Lisp.
+V_DUMP = $(V_DUMP_$(V))
+V_DUMP_ = $(V_DUMP_$(AM_DEFAULT_VERBOSITY))
+V_DUMP_0 = @echo " DUMP $@";
+V_TEST = $(V_TEST_$(V))
+V_TEST_ = $(V_TEST_$(AM_DEFAULT_VERBOSITY))
+V_TEST_0 = @echo " TEST $@";
###--------------------------------------------------------------------------
### Subdirectories to build
-SUBDIRS = src lib
+SUBDIRS = src lib test
+
+###--------------------------------------------------------------------------
+### Package-configuration file.
+pkgconfigdir = $(libdir)/pkgconfig
+pkgconfig_DATA = sod.pc
all: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) all-recursive
distclean-libtool:
-rm -f libtool config.lt
+install-pkgconfigDATA: $(pkgconfig_DATA)
+ @$(NORMAL_INSTALL)
+ @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \
+ if test -n "$$list"; then \
+ echo " $(MKDIR_P) '$(DESTDIR)$(pkgconfigdir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(pkgconfigdir)" || exit 1; \
+ fi; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkgconfigdir)'"; \
+ $(INSTALL_DATA) $$files "$(DESTDIR)$(pkgconfigdir)" || exit $$?; \
+ done
+
+uninstall-pkgconfigDATA:
+ @$(NORMAL_UNINSTALL)
+ @list='$(pkgconfig_DATA)'; test -n "$(pkgconfigdir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ dir='$(DESTDIR)$(pkgconfigdir)'; $(am__uninstall_files_from_dir)
install-pkgincludeHEADERS: $(pkginclude_HEADERS)
@$(NORMAL_INSTALL)
@list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
|| exit 1; \
fi; \
done
+ $(MAKE) $(AM_MAKEFLAGS) \
+ top_distdir="$(top_distdir)" distdir="$(distdir)" \
+ dist-hook
-test -n "$(am__skip_mode_fix)" \
|| find "$(distdir)" -type d ! -perm -755 \
-exec chmod u+rwx,go+rx {} \; -o \
$(MAKE) $(AM_MAKEFLAGS) $(check_PROGRAMS)
check: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) check-recursive
-all-am: Makefile $(PROGRAMS) $(HEADERS)
+all-am: Makefile $(PROGRAMS) $(DATA) $(HEADERS)
installdirs: installdirs-recursive
installdirs-am:
- for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgincludedir)"; do \
+ for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgconfigdir)" "$(DESTDIR)$(pkgincludedir)"; do \
test -z "$$dir" || $(MKDIR_P) "$$dir"; \
done
install: $(BUILT_SOURCES)
info-am:
-install-data-am: install-pkgincludeHEADERS
+install-data-am: install-pkgconfigDATA install-pkgincludeHEADERS
install-dvi: install-dvi-recursive
ps-am:
-uninstall-am: uninstall-binPROGRAMS uninstall-pkgincludeHEADERS
+uninstall-am: uninstall-binPROGRAMS uninstall-pkgconfigDATA \
+ uninstall-pkgincludeHEADERS
.MAKE: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) all check \
check-am ctags-recursive install install-am install-strip \
.PHONY: $(RECURSIVE_CLEAN_TARGETS) $(RECURSIVE_TARGETS) CTAGS GTAGS \
all all-am am--refresh check check-am clean clean-binPROGRAMS \
clean-checkPROGRAMS clean-generic clean-libtool ctags \
- ctags-recursive dist dist-all dist-bzip2 dist-gzip dist-lzip \
- dist-lzma dist-shar dist-tarZ dist-xz dist-zip distcheck \
- distclean distclean-generic distclean-libtool distclean-tags \
- distcleancheck distdir distuninstallcheck dvi dvi-am html \
- html-am info info-am install install-am 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-man install-pdf \
- install-pdf-am install-pkgincludeHEADERS install-ps \
- install-ps-am install-strip installcheck installcheck-am \
- installdirs installdirs-am maintainer-clean \
- maintainer-clean-generic mostlyclean mostlyclean-generic \
- mostlyclean-libtool pdf pdf-am ps ps-am tags tags-recursive \
- uninstall uninstall-am uninstall-binPROGRAMS \
+ ctags-recursive dist dist-all dist-bzip2 dist-gzip dist-hook \
+ dist-lzip dist-lzma dist-shar dist-tarZ dist-xz dist-zip \
+ distcheck distclean distclean-generic distclean-libtool \
+ distclean-tags distcleancheck distdir distuninstallcheck dvi \
+ dvi-am html html-am info info-am install install-am \
+ 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-man \
+ install-pdf install-pdf-am install-pkgconfigDATA \
+ install-pkgincludeHEADERS install-ps install-ps-am \
+ install-strip installcheck installcheck-am installdirs \
+ installdirs-am maintainer-clean maintainer-clean-generic \
+ mostlyclean mostlyclean-generic mostlyclean-libtool pdf pdf-am \
+ ps ps-am tags tags-recursive uninstall uninstall-am \
+ uninstall-binPROGRAMS uninstall-pkgconfigDATA \
uninstall-pkgincludeHEADERS
-.sod.c: $(SOD); $(SOD) -tc $<
-.sod.h: $(SOD); $(SOD) -th $<
+.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $<
+.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $<
###----- That's all, folks --------------------------------------------------
+sod.pc: sod.pc.in Makefile
+ $(SUBST) $(srcdir)/sod.pc.in >$@.new $(SUBSTITUTIONS) && mv $@.new $@
+
+###--------------------------------------------------------------------------
+### Distribution.
+
+dist-hook:
+ echo $(VERSION) >$(distdir)/RELEASE
+
###----- That's all, folks --------------------------------------------------
# Tell versions [3.59,3.63) of GNU make to not export all variables.
--- /dev/null
+#! /bin/sh
+### -*-sh-*-
+###
+### Make autoconf-like substitutions in files
+###
+### (c) 2008 Mark Wooding
+###
+
+###----- Licensing notice ---------------------------------------------------
+###
+### This file is part of the Common Files Distribution (`common').
+###
+### `Common' 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.
+###
+### `Common' 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 `common'; if not, write to the Free Software Foundation,
+### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+set -e
+VERSION="1.3.10.1"
+
+###--------------------------------------------------------------------------
+### Parse command line arguments.
+
+while [ $# -gt 0 ]; do
+ case $1 in
+ -h | --h | --he | --hel | --help)
+ cat <<EOF
+Usage: confsubst FILE TAG=VALUE...
+
+Replaces occurrences of @TAG@ in FILE with VALUE, and writes the result to
+standard output.
+EOF
+ exit 0
+ ;;
+ -v | --v | --ve | --ver | --vers | --versi | --versio | --version)
+ echo "confsubst: Common Files Distribution version $VERSION"
+ exit 0
+ ;;
+ --)
+ shift
+ break
+ ;;
+ -)
+ break
+ ;;
+ -*)
+ echo "confsubst: unknown option \`$1'" >&2
+ exit 1
+ ;;
+ *)
+ break
+ ;;
+ esac
+ shift
+done
+
+if [ $# -lt 1 ]; then
+ echo >&2 "Usage: confsubst FILE TAG=VALUE..."
+ exit 1
+fi
+file=$1; shift
+
+###--------------------------------------------------------------------------
+### Main code.
+
+subst=""
+for fixup; do
+ case "$fixup" in
+ *?=*) ;;
+ *) echo >&2 "$0: bad substitution: $fixup"; exit 1 ;;
+ esac
+ tag=$(echo "$fixup" | sed 's/=.*$//') && \
+ value=$(echo "$fixup" | sed 's/^[^=]*=//') && \
+ subst="$subst s\a@$tag@\a$value\ag;"
+done
+
+sed "$subst" $file || exit $?
+
+###----- That's all, folks --------------------------------------------------
#! /bin/sh
# Guess values for system-dependent variables and create Makefiles.
-# Generated by GNU Autoconf 2.69 for sod 0.1.0-19-gb5d0.
+# Generated by GNU Autoconf 2.69 for sod 0.2.0.
#
# Report bugs to <mdw@distorted.org.uk>.
#
# Identity of this package.
PACKAGE_NAME='sod'
PACKAGE_TARNAME='sod'
-PACKAGE_VERSION='0.1.0-19-gb5d0'
-PACKAGE_STRING='sod 0.1.0-19-gb5d0'
+PACKAGE_VERSION='0.2.0'
+PACKAGE_STRING='sod 0.2.0'
PACKAGE_BUGREPORT='mdw@distorted.org.uk'
PACKAGE_URL=''
LIBOBJS
lispsysdir
lispsrcdir
-FASL_TYPE
+fasl
LISPSYS
CL_LAUNCH
LIBTOOL_VERSION_INFO
# 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.1.0-19-gb5d0 to adapt to many kinds of systems.
+\`configure' configures sod 0.2.0 to adapt to many kinds of systems.
Usage: $0 [OPTION]... [VAR=VALUE]...
if test -n "$ac_init_help"; then
case $ac_init_help in
- short | recursive ) echo "Configuration of sod 0.1.0-19-gb5d0:";;
+ short | recursive ) echo "Configuration of sod 0.2.0:";;
esac
cat <<\_ACEOF
test -n "$ac_init_help" && exit $ac_status
if $ac_init_version; then
cat <<\_ACEOF
-sod configure 0.1.0-19-gb5d0
+sod configure 0.2.0
generated by GNU Autoconf 2.69
Copyright (C) 2012 Free Software Foundation, Inc.
This file contains any messages produced by compilers while
running configure, to aid debugging if configure makes a mistake.
-It was created by sod $as_me 0.1.0-19-gb5d0, which was
+It was created by sod $as_me 0.2.0, which was
generated by GNU Autoconf 2.69. Invocation command line was
$ $0 $@
# Define the identity of the package.
PACKAGE='sod'
- VERSION='0.1.0-19-gb5d0'
+ VERSION='0.2.0'
cat >>confdefs.h <<_ACEOF
{ $as_echo "$as_me:${as_lineno-$LINENO}: checking FASL file extension" >&5
$as_echo_n "checking FASL file extension... " >&6; }
-FASL_TYPE=$($CL_LAUNCH -l $LISPSYS -ip \
+fasl=$($CL_LAUNCH -l $LISPSYS -ip \
'(pathname-type (compile-file-pathname "foo.lisp"))')
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: .$FASL_TYPE" >&5
-$as_echo ".$FASL_TYPE" >&6; }
+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: .$fasl" >&5
+$as_echo ".$fasl" >&6; }
# Check whether --with-lisp-source-dir was given.
-ac_config_files="$ac_config_files Makefile src/Makefile lib/Makefile"
+ac_config_files="$ac_config_files Makefile src/Makefile lib/Makefile test/Makefile"
cat >confcache <<\_ACEOF
# This file is a shell script that caches the results of configure
# 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.1.0-19-gb5d0, which was
+This file was extended by sod $as_me 0.2.0, which was
generated by GNU Autoconf 2.69. Invocation command line was
CONFIG_FILES = $CONFIG_FILES
cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1
ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"
ac_cs_version="\\
-sod config.status 0.1.0-19-gb5d0
+sod config.status 0.2.0
configured by $0, generated by GNU Autoconf 2.69,
with options \\"\$ac_cs_config\\"
"Makefile") CONFIG_FILES="$CONFIG_FILES Makefile" ;;
"src/Makefile") CONFIG_FILES="$CONFIG_FILES src/Makefile" ;;
"lib/Makefile") CONFIG_FILES="$CONFIG_FILES lib/Makefile" ;;
+ "test/Makefile") CONFIG_FILES="$CONFIG_FILES test/Makefile" ;;
*) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;
esac
AC_MSG_RESULT([$LISPSYS])
AC_MSG_CHECKING([FASL file extension])
-FASL_TYPE=$($CL_LAUNCH -l $LISPSYS -ip \
+fasl=$($CL_LAUNCH -l $LISPSYS -ip \
'(pathname-type (compile-file-pathname "foo.lisp"))')
-AC_SUBST([FASL_TYPE])
-AC_MSG_RESULT([.$FASL_TYPE])
+AC_SUBST([fasl])
+AC_MSG_RESULT([.$fasl])
AC_ARG_WITH([lisp-source-dir],
[AS_HELP_STRING([--with-lisp-source-dir=DIR],
dnl--------------------------------------------------------------------------
dnl Output.
-AC_CONFIG_FILES([Makefile src/Makefile lib/Makefile])
+AC_CONFIG_FILES([Makefile src/Makefile lib/Makefile test/Makefile])
AC_OUTPUT
dnl----- That's all, folks --------------------------------------------------
--- /dev/null
+sod (0.2.0) experimental; urgency=low
+
+ * Initial Debian packaging.
+
+ -- Mark Wooding <mdw@distorted.org.uk> Sun, 06 Sep 2015 22:38:24 +0100
--- /dev/null
+Source: sod
+Section: devel
+Priority: extra
+Maintainer: Mark Wooding <mdw@distorted.org.uk>
+Build-Depends: debhelper (>= 8), cl-launch, sbcl | clisp, cl-asdf, cl-xlunit
+Standards-Version: 3.1.1
+
+Package: libsod
+Architecture: any
+Multi-Arch: same
+Pre-Depends: ${misc:Pre-Depends}
+Depends: ${shlibs:Depends}, ${misc:Depends}
+Description: An object system for C, runtime library
+ Sod is a `sensible object design' for C, supporting a number of fancy
+ features, including multiple inheritance, method combinations with daemon
+ methods, and a compile-time metaprotocol. The only downside is that the
+ translator is written in Common Lisp.
+ .
+ This package contains a dynamically linkable version of the runtime support
+ library for Sod programs, which is deliberately very small.
+
+Package: libsod-dev
+Architecture: any
+Depends: libsod (= ${Source-Version}), libc6-dev, ${misc:Depends}
+Suggests: sod
+Description: An object system for C, runtime library
+ Sod is a `sensible object design' for C, supporting a number of fancy
+ features, including multiple inheritance, method combinations with daemon
+ methods, and a compile-time metaprotocol. The only downside is that the
+ translator is written in Common Lisp.
+ .
+ This package contains the development files for the runtime support library,
+ which are useful for clients of other libraries which are themselves built
+ on Sod.
+
+Package: sod
+Architecture: any
+Depends: ${shlibs:Depends}
+Recommends: libsod-dev (= ${Source-Version})
+Description: An object system for C, translator
+ Sod is a `sensible object design' for C, supporting a number of fancy
+ features, including multiple inheritance, method combinations with daemon
+ methods, and a compile-time metaprotocol. The only downside is that the
+ translator is written in Common Lisp.
+ .
+ This package contains the Sod translator, which reads object definitions and
+ produces compilable C code.
+
+Package: sod-dev
+Architecture: any
+Recommends: sbcl | clisp, cl-asdf, cl-xlunit
+Description: An object system for C, Lisp source
+ Sod is a `sensible object design' for C, supporting a number of fancy
+ features, including multiple inheritance, method combinations with daemon
+ methods, and a compile-time metaprotocol. The only downside is that the
+ translator is written in Common Lisp.
+ .
+ This package contains the source and ASDF system definition for the Sod
+ translator which, while may be useful for developing extensions or doing
+ interesting things with the translator.
--- /dev/null
+Sod is copyright (c) 2015 Straylight/Edgeware
+
+
+The Sod runtime library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Library General Public License as
+published by the Free Software Foundation; either version 2 of the License,
+or (at your option) any later version.
+
+Sod is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
+License for more details.
+
+You should have a copy of the GNU Library General Public License in
+/usr/share/common-licenses/LGPL-2; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
+
+You should have a copy of the GNU General Public License in
+/usr/share/common-licenses/GPL; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
--- /dev/null
+/usr/include/sod
+/usr/lib/*/libsod.a
+/usr/lib/*/libsod.la
+/usr/lib/*/libsod.so
+/usr/lib/*/pkgconfig
--- /dev/null
+/usr/lib/*/libsod.so.*
--- /dev/null
+#! /usr/bin/make -f
+%:; dh $@ --parallel -Bdebian/build
--- /dev/null
+/usr/share/common-lisp
--- /dev/null
+/usr/bin/sod
BUILT_SOURCES += $(nodist_libsod_la_SOURCES) \
$(nodist_pkginclude_HEADERS)
-sod-base.c: $(SOD); $(SOD) -tc --builtin
-sod-base.h: $(SOD); $(SOD) -th --builtin
+sod-base.c: $(SOD); $(V_SOD_c)$(SOD) -tc --builtin
+sod-base.h: $(SOD); $(V_SOD_h)$(SOD) -th --builtin
###----- That's all, folks --------------------------------------------------
ECHO_T = @ECHO_T@
EGREP = @EGREP@
EXEEXT = @EXEEXT@
-FASL_TYPE = @FASL_TYPE@
FGREP = @FGREP@
GREP = @GREP@
INSTALL = @INSTALL@
docdir = @docdir@
dvidir = @dvidir@
exec_prefix = @exec_prefix@
+fasl = @fasl@
host = @host@
host_alias = @host_alias@
host_cpu = @host_cpu@
LDADD = $(top_builddir)/lib/libsod.la
###--------------------------------------------------------------------------
+### Standard configuration substitutions.
+confsubst = $(top_srcdir)/config/confsubst
+SUBSTITUTIONS = \
+ prefix=$(prefix) exec_prefix=$(exec_prefix) \
+ libdir=$(libdir) includedir=$(includedir) \
+ bindir=$(bindir) sbindir=$(sbindir) \
+ PACKAGE=$(PACKAGE) VERSION=$(VERSION)
+
+V_SUBST = $(V_SUBST_$(V))
+V_SUBST_ = $(V_SUBST_$(AM_DEFAULT_VERBOSITY))
+V_SUBST_0 = @echo " SUBST $@";
+SUBST = $(V_SUBST)$(confsubst)
+
+###--------------------------------------------------------------------------
### Translating SOD input files.
SOD = $(top_builddir)/src/sod
+V_SOD_c = $(V_SOD_c_$(V))
+V_SOD_c_ = $(V_SOD_c_$(AM_DEFAULT_VERBOSITY))
+V_SOD_c_0 = @echo " SOD[c] $@";
+V_SOD_h = $(V_SOD_h_$(V))
+V_SOD_h_ = $(V_SOD_h_$(AM_DEFAULT_VERBOSITY))
+V_SOD_h_0 = @echo " SOD[h] $@";
+
+###--------------------------------------------------------------------------
+### Silent rules for Lisp.
+V_DUMP = $(V_DUMP_$(V))
+V_DUMP_ = $(V_DUMP_$(AM_DEFAULT_VERBOSITY))
+V_DUMP_0 = @echo " DUMP $@";
+V_TEST = $(V_TEST_$(V))
+V_TEST_ = $(V_TEST_$(AM_DEFAULT_VERBOSITY))
+V_TEST_0 = @echo " TEST $@";
###--------------------------------------------------------------------------
### The library.
uninstall-binPROGRAMS uninstall-libLTLIBRARIES \
uninstall-nodist_pkgincludeHEADERS uninstall-pkgincludeHEADERS
-.sod.c: $(SOD); $(SOD) -tc $<
-.sod.h: $(SOD); $(SOD) -th $<
+.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $<
+.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $<
###----- That's all, folks --------------------------------------------------
-sod-base.c: $(SOD); $(SOD) -tc --builtin
-sod-base.h: $(SOD); $(SOD) -th --builtin
+sod-base.c: $(SOD); $(V_SOD_c)$(SOD) -tc --builtin
+sod-base.h: $(SOD); $(V_SOD_h)$(SOD) -th --builtin
###----- That's all, folks --------------------------------------------------
*
* This file is part of the Sensble Object Design, an object system for C.
*
- * SOD is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
+ * The SOD Runtime Library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
*
- * SOD is distributed in the hope that it will be useful,
+ * The SOD Runtime is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+ * GNU Library General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with SOD; if not, write to the Free Software Foundation,
- * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ * You should have received a copy of the GNU Library General Public
+ * License along with SOD; if not, write to the Free
+ * Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
*/
/*----- Header files ------------------------------------------------------*/
* to know what C or S actually are.
*/
-void *sod_convert(const SodClass *cls, void *p)
+void *sod_convert(const SodClass *cls, const void *obj)
{
- const struct sod_instance *inst = p;
+ const struct sod_instance *inst = obj;
const struct sod_vtable *vt = inst->_vt;
const SodClass *realcls = vt->_class;
const struct sod_chain *chain = find_chain(realcls, cls);
- if (!chain)
- return (0);
- return ((char *)p - vt->_base + chain->off_ichain);
+ if (!chain) return (0);
+ return ((char *)obj - vt->_base + chain->off_ichain);
}
/*----- That's all, folks -------------------------------------------------*/
*
* This file is part of the Sensble Object Design, an object system for C.
*
- * SOD is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2 of the License, or
- * (at your option) any later version.
+ * The SOD Runtime Library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Library General Public License as
+ * published by the Free Software Foundation; either version 2 of the
+ * License, or (at your option) any later version.
*
- * SOD is distributed in the hope that it will be useful,
+ * The SOD Runtime is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+ * GNU Library General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with SOD; if not, write to the Free Software Foundation,
- * Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ * You should have received a copy of the GNU Library General Public
+ * License along with SOD; if not, write to the Free
+ * Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
+ * MA 02111-1307, USA.
*/
#ifndef SOD_H
/* --- @SOD_XCHAIN@ --- *
*
* Arguments: @chead@ = nickname of target chain's head
- * @p@ = pointer to an instance chain
+ * @obj@ = pointer to an instance chain
*
* Returns: Pointer to target chain, as a @char *@.
*
* the automatically-generated upcast macros more palatable.
*/
-#define SOD_XCHAIN(chead, p) ((char *)(p) + (p)->_vt->_off_##chead)
+#define SOD_XCHAIN(chead, obj) ((char *)(obj) + (obj)->_vt->_off_##chead)
/* --- @SOD_OFFSETDIFF@ --- *
*
*
* Arguments: @cls@ = name of a class
* @chead@ = nickname of chain head of @cls@
- * @p@ = pointer to the @chead@ ichain of an (exact) instance of
- * @cls@
+ * @obj@ = pointer to the @chead@ ichain of an (exact) instance
+ * of @cls@
*
* Returns: A pointer to the instance's base, cast as a pointer to the
* ilayout structure.
* necessary to use it safely.
*/
-#define SOD_ILAYOUT(cls, chead, p) \
+#define SOD_ILAYOUT(cls, chead, obj) \
((struct cls##__ilayout *) \
- ((char *)(p) - offsetof(struct cls##__ilayout, chead)))
+ ((char *)(obj) - offsetof(struct cls##__ilayout, chead)))
+
+/* --- @SOD__CAR@ --- *
+ *
+ * Arguments: @...@ = a nonempty list of arguments
+ *
+ * Returns: The first argument only.
+ */
+
+#if __STDC_VERSION__ >= 199901
+# define SOD__CAR(...) SOD__CARx(__VA_LIST__, _)
+# define SOD__CARx(a, ...) a
+#endif
+
+/*----- Utility macros ----------------------------------------------------*/
+
+/* --- @SOD_CLASSOF@ --- *
+ *
+ * Arguments: @p@ = pointer to an instance chain
+ *
+ * Returns: A pointer to the instance's class, as a const SodClass.
+ */
+
+#define SOD_CLASSOF(obj) ((const SodClass *)(obj)->_vt->_class)
/* --- @SOD_INSTBASE@ --- *
*
- * Arguments: @p@ = pointer to an instance (i.e., the address of one of its
- * instance chains)
+ * Arguments: @obj@ = pointer to an instance (i.e., the address of one of
+ * its instance chains)
*
- * Returns: The base address of @p@'s instance layout.
+ * Returns: The base address of @obj@'s instance layout, as a @void *@.
*
* Use: Finds the base address of an instance. If you know the
* dynamic class of the object then @SOD_ILAYOUT@ is faster. If
* zeroizing the instance structure.
*/
-#define SOD_INSTBASE(p) ((void *)((char *)(p) - (p)->_vt->_base))
+#define SOD_INSTBASE(obj) ((void *)((char *)(obj) - (obj)->_vt->_base))
-/*----- Utility macros ----------------------------------------------------*/
+/* --- @SOD_CONVERT@ --- *
+ *
+ * Arguments: @cls@ = a class type name
+ * @const void *obj@ = a pointer to an instance
+ *
+ * Returns: Pointer to appropriate instance ichain, or null if the
+ * instance isn't of the specified class.
+ *
+ * Use: This is a simple wrapper around the @sod_convert@, which
+ * you should see for full details. It accepts a class type
+ * name rather than a pointer to a class object, and arranges to
+ * return a pointer of the correct type.
+ */
-/* --- @SOD_CLASSOF@ --- *
+#define SOD_CONVERT(cls, obj) ((cls *)sod_convert(cls##__class, (obj)))
+
+/* --- @SOD_DECL@ --- *
*
- * Arguments: @p@ = pointer to an instance chain
+ * Arguments: @cls_@ = a class type name
+ * @var_@ = a variable name
*
- * Returns: A pointer to the instance's class, as a const SodClass.
+ * Use: Declare @var_@ as a pointer to an initialized instance of
+ * @cls_@ with automatic lifetime.
*/
-#define SOD_CLASSOF(p) ((const SodClass *)(p)->_vt->_class)
+#define SOD_DECL(cls_, var_) \
+ struct cls_##__ilayout var_##__layout; \
+ cls_ *var_ = cls_##__class->cls.init(&var_##__layout)
/*----- Functions provided ------------------------------------------------*/
* to know what either C or S actually are.
*/
-extern void *sod_convert(const SodClass */*cls*/, void */*p*/);
+extern void *sod_convert(const SodClass */*cls*/, const void */*obj*/);
/*----- That's all, folks -------------------------------------------------*/
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Dealing with C types
-;;;
-;;; (c) 2008 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Plain old C types.
-
-;; Class definition.
-
-;; Important protocol.
-
-;; Utility functions and macros.
-
-;; S-expression syntax machinery.
-
-;; Basic definitions.
-
-;; A handy utility.
-
-;;;--------------------------------------------------------------------------
-;;; Simple C types (e.g., built-in arithmetic types).
-
-;; Basic definitions.
-
-(let ((cache (make-hash-table :test #'equal)))
-
-;;;--------------------------------------------------------------------------
-;;; Tag types (structs, unions and enums).
-
-;; Definitions.
-
-;;;--------------------------------------------------------------------------
-;;; Pointer types.
-
-;; Definitions.
-
-(let ((cache (make-hash-table :test #'eql)))
-
-;; S-expression syntax.
-
-;;;--------------------------------------------------------------------------
-;;; Array types.
-
-;; Definitions.
-
-
-;;;--------------------------------------------------------------------------
-;;; Function types.
-
-;; Arguments.
-
-;; Definitions.
-
-;; S-expression syntax.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Equipment for building classes and friends
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Finding things by name
-
-(defun find-superclass-by-nick (class nick)
- "Returns the superclass of CLASS with nickname NICK, or signals an error."
-
- ;; Slightly tricky. The class almost certainly hasn't been finalized, so
- ;; trundle through its superclasses and hope for the best.
- (if (string= nick (sod-class-nickname class))
- class
- (or (some (lambda (super)
- (find nick (sod-class-precedence-list super)
- :key #'sod-class-nickname
- :test #'string=))
- (sod-class-direct-superclasses class))
- (error "No superclass of `~A' with nickname `~A'" class nick))))
-
-(flet ((find-item-by-name (what class list name key)
- (or (find name list :key key :test #'string=)
- (error "No ~A in class `~A' with name `~A'" what class name))))
-
- (defun find-instance-slot-by-name (class super-nick slot-name)
- (let ((super (find-superclass-by-nick class super-nick)))
- (find-item-by-name "slot" super (sod-class-slots super)
- slot-name #'sod-slot-name)))
-
- (defun find-class-slot-by-name (class super-nick slot-name)
- (let* ((meta (sod-class-metaclass class))
- (super (find-superclass-by-nick meta super-nick)))
- (find-item-by-name "slot" super (sod-class-slots super)
- slot-name #'sod-slot-name)))
-
- (defun find-message-by-name (class super-nick message-name)
- (let ((super (find-superclass-by-nick class super-nick)))
- (find-item-by-name "message" super (sod-class-messages super)
- message-name #'sod-message-name))))
-
-;;;--------------------------------------------------------------------------
-;;; Class construction.
-
-(defun make-sod-class (name superclasses pset &optional location)
- "Construct and return a new SOD class with the given NAME and SUPERCLASSES.
-
- This is the main constructor function for classes. The protocol works as
- follows. The :LISP-CLASS property in PSET is checked: if it exists, it
- must be a symbol naming a (CLOS) class, which is used in place of
- SOD-CLASS. All of the arguments are then passed to MAKE-INSTANCE; further
- behaviour is left to the standard CLOS instance construction protocol; for
- example, SOD-CLASS defines an :AFTER-method on SHARED-INITIALIZE.
-
- Minimal sanity checking is done during class construction; most of it is
- left for FINALIZE-SOD-CLASS to do (via CHECK-SOD-CLASS).
-
- Unused properties in PSET are diagnosed as errors."
-
- (with-default-error-location (location)
- (let ((class (make-instance (get-property pset :lisp-class :symbol
- 'sod-class)
- :name name
- :superclasses superclasses
- :location (file-location location)
- :pset pset)))
- (check-unused-properties pset)
- class)))
-
-(defgeneric guess-metaclass (class)
- (:documentation
- "Determine a suitable metaclass for the CLASS.
-
- The default behaviour is to choose the most specific metaclass of any of
- the direct superclasses of CLASS, or to signal an error if that failed."))
-
-;;;--------------------------------------------------------------------------
-;;; Slot construction.
-
-(defgeneric make-sod-slot (class name type pset &optional location)
- (:documentation
- "Construct, add, and attach a new slot with given NAME and TYPE, to CLASS.
-
- This is the main constructor function for slots. This is a generic
- function primarily so that the CLASS can intervene in the construction
- process. The default method uses the :LISP-CLASS property (defaulting to
- SOD-SLOT) to choose a (CLOS) class to instantiate. The slot is then
- constructed by MAKE-INSTANCE passing the arguments as initargs; further
- behaviour is left to the standard CLOS instance construction protocol; for
- example, SOD-SLOT defines an :AFTER-method on SHARED-INITIALIZE.
-
- Unused properties on PSET are diagnosed as errors."))
-
-;;;--------------------------------------------------------------------------
-;;; Slot initializer construction.
-
-;;;--------------------------------------------------------------------------
-;;; Message construction.
-
-;;;--------------------------------------------------------------------------
-;;; Method construction.
-
-;;;--------------------------------------------------------------------------
-;;; Builder macros.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Basic definitions for classes, methods and suchlike
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Classes.
-
-(defclass sod-class ()
- ((name :initarg :name :type string :reader sod-class-name)
- (location :initarg :location :initform (file-location nil)
- :type file-location :reader file-location)
- (nickname :initarg :nick :type string :reader sod-class-nickname)
- (direct-superclasses :initarg :superclasses :type list
- :reader sod-class-direct-superclasses)
- (chain-link :initarg :link :type (or sod-class null)
- :reader sod-class-chain-link)
- (metaclass :initarg :metaclass :type sod-class
- :reader sod-class-metaclass)
- (slots :initarg :slots :initform nil
- :type list :accessor sod-class-slots)
- (instance-initializers :initarg :instance-initializers :initform nil
- :type list
- :accessor sod-class-instance-initializers)
- (class-initializers :initarg :class-initializers :initform nil
- :type list :accessor sod-class-class-initializers)
- (messages :initarg :messages :initform nil
- :type list :accessor sod-class-messages)
- (methods :initarg :methods :initform nil
- :type list :accessor sod-class-methods)
-
- (class-precedence-list :type list :accessor sod-class-precedence-list)
-
- (type :type c-class-type :accessor sod-class-type)
-
- (chain-head :type sod-class :accessor sod-class-chain-head)
- (chain :type list :accessor sod-class-chain)
- (chains :type list :accessor sod-class-chains)
-
- (ilayout :type ilayout :accessor sod-class-ilayout)
- (effective-methods :type list :accessor sod-class-effective-methods)
- (vtables :type list :accessor sod-class-vtables)
-
- (state :initform nil :type (member nil :finalized broken)
- :accessor sod-class-state))
- (:documentation
- "Classes describe the layout and behaviour of objects.
-
- The NAME, LOCATION, NICKNAME, DIRECT-SUPERCLASSES, CHAIN-LINK and
- METACLASS slots are intended to be initialized when the class object is
- constructed:
-
- * The NAME is the identifier associated with the class in the user's
- source file. It is used verbatim in the generated C code as a type
- name, and must be distinct from other file-scope names in any source
- file which includes the class definition. Furthermore, other names
- are derived from the class name (most notably the class object
- NAME__class), which have external linkage and must therefore be
- distinct from all other identifiers in the program. It is forbidden
- for a class NAME to begin with an underscore or to contain two
- consecutive underscores.
-
- * The LOCATION identifies where in the source the class was defined. It
- gets used in error messages.
-
- * The NICKNAME is a shorter identifier used to name the class in some
- circumstances. The uniqueness requirements on NICKNAME are less
- strict, which allows them to be shorter: no class may have two classes
- with the same nickname on its class precedence list. Nicknames are
- used (user-visibly) to distinguish slots and messages defined by
- different classes, and (invisibly) in the derived names of direct
- methods. It is forbidden for a nickname to begin with an underscore,
- or to contain two consecutive underscores.
-
- * The DIRECT-SUPERCLASSES are a list of the class's direct superclasses,
- in the order that they were declared in the source. The class
- precedence list is computed from the DIRECT-SUPERCLASSES lists of all
- of the superclasses involved.
-
- * The CHAIN-LINK is either NIL or one of the DIRECT-SUPERCLASSES. Class
- chains are a means for recovering most of the benefits of simple
- hierarchy lost by the introduction of multiple inheritance. A class's
- superclasses (including itself) are partitioned into chains,
- consisting of a class, its CHAIN-LINK superclass, that class's
- CHAIN-LINK, and so on. It is an error if two direct subclasses of any
- class appear in the same chain (a global property which requires
- global knowledge of an entire program's class hierarchy in order to
- determine sensibly). Slots of superclasses in the same chain can be
- accessed efficiently; there is an indirection needed to access slots
- of superclasses in other chains. Furthermore, an indirection is
- required to perform a cross-chain conversion (i.e., converting a
- pointer to an instance of some class into a pointer to an instance of
- one of its superclasses in a different chain), an operation which
- occurs implicitly in effective methods in order to call direct methods
- defined on cross-chain superclasses.
-
- * The METACLASS is the class of the class object. Classes are objects
- in their own right, and therefore must be instances of some class;
- this class is the metaclass. Metaclasses can define additional slots
- and methods to be provided by their instances; a class definition can
- provide (C constant expression) initial values for the metaclass
- instance.
-
- The next few slots can't usually be set at object-construction time, since
- the objects need to contain references to the class object itself.
-
- * The SLOTS are a list of the slots defined by the class (instances of
- SOD-SLOT). (The class will also define all of the slots defined by
- its superclasses.)
-
- * The INSTANCE-INITIALIZERS and CLASS-INITIALIZERS are lists of
- initializers for slots (see SOD-INITIALIZER and subclasses), providing
- initial values for instances of the class, and for the class's class
- object itself, respectively.
-
- * The MESSAGES are a list of the messages recognized by the class
- (instances of SOD-MESSAGE and subclasses). (Note that the message
- need not have any methods defined on it. The class will also
- recognize all of the messages defined by its superclasses.)
-
- * The METHODS are a list of (direct) methods defined on the class
- (instances of SOD-METHOD and subclasses). Each method provides
- behaviour to be invoked by a particular message recognized by the
- class.
-
- Other slots are computed from these in order to describe the class's
- layout and effective methods; this is done by FINALIZE-SOD-CLASS.
-
- * The CLASS-PRECEDENCE-LIST is a list of superclasses in a linear order.
- It is computed by the generic function COMPUTE-CLASS-PRECEDENCE-LIST,
- whose default implementation ensures that the order of superclasses is
- such that (a) subclasses appear before their superclasses; (b) the
- direct superclasses of a given class appear in the order in which they
- were declared by the programmer; and (c) classes always appear in the
- same relative order in all class precedence lists in the same
- superclass graph.
-
- * The CHAIN-HEAD is the least-specific class in the class's chain. If
- there is no link class then the CHAIN-HEAD is the class itself. This
- slot, like the next two, is computed by the generic function
- COMPUTE-CHAINS.
-
- * The CHAIN is the list of classes on the complete primary chain,
- starting from this class and ending with the CHAIN-HEAD.
-
- * The CHAINS are the complete collection of chains (most-to-least
- specific) for the class and all of its superclasses.
-
- * The ILAYOUT describes the layout for an instance of the class. It's
- quite complicated; see the documentation of the ILAYOUT class for
- detais.
-
- * The EFFECTIVE-METHODS are a list of effective methods, specialized for
- the class.
-
- * The VTABLES are a list of descriptions of vtables for the class. The
- individual elements are VTABLE objects, which are even more
- complicated than ILAYOUT structures. See the class documentation for
- details."))
-
-(defmethod print-object ((class sod-class) stream)
- (maybe-print-unreadable-object (class stream :type t)
- (princ (sod-class-name class) stream)))
-
-;;;--------------------------------------------------------------------------
-;;; Slots and initializers.
-
-(defclass sod-slot ()
- ((name :initarg :name :type string :reader sod-slot-name)
- (location :initarg :location :initform (file-location nil)
- :type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-slot-class)
- (type :initarg :type :type c-type :reader sod-slot-type))
- (:documentation
- "Slots are units of information storage in instances.
-
- Each class defines a number of slots, which function similarly to (data)
- members in structures. An instance contains all of the slots defined in
- its class and all of its superclasses.
-
- A slot carries the following information.
-
- * A NAME, which distinguishes it from other slots defined by the same
- class. Unlike most (all?) other object systems, slots defined in
- different classes are in distinct namespaces. There are no special
- restrictions on slot names.
-
- * A LOCATION, which states where in the user's source the slot was
- defined. This gets used in error messages.
-
- * A CLASS, which states which class defined the slot. The slot is
- available in instances of this class and all of its descendents.
-
- * A TYPE, which is the C type of the slot. This must be an object type
- (certainly not a function type, and it must be a complete type by the
- time that the user header code has been scanned)."))
-
-(defmethod print-object ((slot sod-slot) stream)
- (maybe-print-unreadable-object (slot stream :type t)
- (pprint-c-type (sod-slot-type slot) stream
- (format nil "~A.~A"
- (sod-class-nickname (sod-slot-class slot))
- (sod-slot-name slot)))))
-
-(defclass sod-initializer ()
- ((slot :initarg :slot :type sod-slot :reader sod-initializer-slot)
- (location :initarg :location :initform (file-location nil)
- :type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-initializer-class)
- (value-kind :initarg :value-kind :type keyword
- :reader sod-initializer-value-kind)
- (value-form :initarg :value-form :type c-fragment
- :reader sod-initializer-value-form))
- (:documentation
- "Provides an initial value for a slot.
-
- The slots of an initializer are as follows.
-
- * The SLOT specifies which slot this initializer is meant to initialize.
-
- * The LOCATION states the position in the user's source file where the
- initializer was found. This gets used in error messages. (Depending
- on the source layout style, this might differ from the location in the
- VALUE-FORM C fragment.)
-
- * The CLASS states which class defined this initializer. For instance
- slot initializers (SOD-INSTANCE-INITIALIZER), this will be the same as
- the SLOT's class, or be one of its descendants. For class slot
- initializers (SOD-CLASS-INITIALIZER), this will be an instance of the
- SLOT's class, or an instance of one of its descendants.
-
- * The VALUE-KIND states what manner of initializer we have. It can be
- either :SINGLE, indicating a standalone expression, or :COMPOUND,
- indicating a compound initializer which must be surrounded by braces
- on output.
-
- * The VALUE-FORM gives the text of the initializer, as a C fragment.
-
- Typically you'll see instances of subclasses of this class in the wild
- rather than instances of this class directly. See SOD-CLASS-INITIALIZER
- and SOD-INSTANCE-INITIALIZER."))
-
-(defmethod print-object ((initializer sod-initializer) stream)
- (if *print-escape*
- (print-unreadable-object (initializer stream :type t)
- (format stream "~A = ~A"
- (sod-initializer-slot initializer)
- initializer))
- (format stream "~:[{~A}~;~A~]"
- (eq (sod-initializer-value-kind initializer) :single)
- (sod-initializer-value-form initializer))))
-
-(defclass sod-class-initializer (sod-initializer)
- ()
- (:documentation
- "Provides an initial value for a class slot.
-
- A class slot initializer provides an initial value for a slot in the class
- object (i.e., one of the slots defined by the class's metaclass). Its
- VALUE-FORM must have the syntax of an initializer, and its consituent
- expressions must be constant expressions.
-
- See SOD-INITIALIZER for more details."))
-
-(defclass sod-instance-initializer (sod-initializer)
- ()
- (:documentation
- "Provides an initial value for a slot in all instances.
-
- An instance slot initializer provides an initial value for a slot in
- instances of the class. Its VALUE-FORM must have the syntax of an
- initializer. Furthermore, if the slot has aggregate type, then you'd
- better be sure that your compiler supports compound literals (6.5.2.5)
- because that's what the initializer gets turned into.
-
- See SOD-INITIALIZER for more details."))
-
-;;;--------------------------------------------------------------------------
-;;; Messages and methods.
-
-(defclass sod-message ()
- ((name :initarg :name :type string :reader sod-message-name)
- (location :initarg :location :initform (file-location nil)
- :type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-message-class)
- (type :initarg :type :type c-function-type :reader sod-message-type))
- (:documentation
- "Messages the means for stimulating an object to behave.
-
- SOD is a single-dispatch object system, like Smalltalk, C++, Python and so
- on, but unlike CLOS and Dylan. Behaviour is invoked by `sending messages'
- to objects. A message carries a name (distinguishing it from other
- messages recognized by the same class), and a number of arguments; the
- object may return a value in response. Sending a message therefore looks
- very much like calling a function; indeed, each message bears the static
- TYPE signature of a function.
-
- An object reacts to being sent a message by executing an `effective
- method', constructed from the direct methods defined on the recpient's
- (run-time, not necessarily statically-declared) class and its superclasses
- according to the message's `method combination'.
-
- Much interesting work is done by subclasses of SOD-MESSAGE, which (for
- example) specify method combinations.
-
- The slots are as follows.
-
- * The NAME distinguishes the message from others defined by the same
- class. Unlike most (all?) other object systems, messages defined in
- different classes are in distinct namespaces. It is forbidden for a
- message name to begin with an underscore, or to contain two
- consecutive underscores. (Final underscores are fine.)
-
- * The LOCATION states where in the user's source the slot was defined.
- It gets used in error messages.
-
- * The CLASS states which class defined the message.
-
- * The TYPE is a function type describing the message's arguments and
- return type.
-
- Subclasses can (and probably will) define additional slots."))
-
-(defmethod print-object ((message sod-message) stream)
- (maybe-print-unreadable-object (message stream :type t)
- (pprint-c-type (sod-message-type message) stream
- (format nil "~A.~A"
- (sod-class-nickname (sod-message-class message))
- (sod-message-name message)))))
-
-(defclass sod-method ()
- ((message :initarg :message :type sod-message :reader sod-method-message)
- (location :initarg :location :initform (file-location nil)
- :type file-location :reader file-location)
- (class :initarg :class :type sod-class :reader sod-method-class)
- (type :initarg :type :type c-function-type :reader sod-method-type)
- (body :initarg :body :type (or c-fragment null) :reader sod-method-body))
- (:documentation
- "(Direct) methods are units of behaviour.
-
- Methods are the unit of behaviour in SOD. Classes define direct methods
- for particular messages.
-
- When a message is received by an instance, all of the methods defined for
- that message on that instance's (run-time, not static) class and its
- superclasses are `applicable'. The applicable methods are gathered
- together and invoked in some way; the details of this are left to the
- `method combination', determined by the subclass of SOD-MESSAGE.
-
- The slots are as follows.
-
- * The MESSAGE describes which meessage invokes the method's behaviour.
- The method is combined with other methods on the same message
- according to the message's method combination, to form an `effective
- method'.
-
- * The LOCATION states where, in the user's source, the method was
- defined. This gets used in error messages. (Depending on the user's
- coding style, this location might be subtly different from the BODY's
- location.)
-
- * The CLASS specifies which class defined the method. This will be
- either the class of the message, or one of its descendents.
-
- * The TYPE gives the type of the method, including its arguments. This
- will, in general, differ from the type of the message for several
- reasons.
-
- -- Firstly, the method type must include names for all of the
- method's parameters. The message definition can omit the
- parameter names (in the same way as a function declaration can).
- Formally, the message definition can contain abstract
- declarators, whereas method definitions must not.
-
- -- Method combinations may require different parameter or return
- types. For example, `before' and `after' methods don't
- contribute to the message's return value, so they must be defined
- as returning `void'.
-
- -- Method combinations may permit methods whose parameter and/or
- return types don't exactly match the corresponding types of the
- message. For example, one might have methods with covariant
- return types and contravariant parameter types. (This sounds
- nice, but it doesn't actually seem like such a clever idea when
- you consider that the co-/contravariance must hold among all the
- applicable methods ordered according to the class precedence
- list. As a result, a user might have to work hard to build
- subclasses whose CPLs match the restrictions implied by the
- method types.)
-
- Method objects are fairly passive in the SOD translator. However,
- subclasses of SOD-MESSAGE may (and probably will) construct instances of
- subclasses of SOD-METHOD in order to carry the additional metadata they
- need to keep track of."))
-
-(defmethod print-object ((method sod-method) stream)
- (maybe-print-unreadable-object (method stream :type t)
- (format stream "~A ~@_~A"
- (sod-method-message method)
- (sod-method-class method))))
-
-;;;--------------------------------------------------------------------------
-;;; Classes as C types.
-
-(defclass c-class-type (simple-c-type)
- ((class :initarg :class :type (or null sod-class) :accessor c-type-class))
- (:documentation
- "A SOD class, as a C type.
-
- One usually handles classes as pointers, but the type refers to the actual
- instance structure itself. Or, in fact, just the primary chain of the
- instance (i.e., the one containing the class's own direct slots) -- which
- is why dealing with the instance structure directly doesn't make much
- sense.
-
- The CLASS slot will be NIL if the class isn't defined yet, i.e., this
- entry was constructed by a forward reference operation.
-
- The NAME slot inherited from SIMPLE-C-TYPE is here so that we can print
- the type even when it's a forward reference."))
-
-(defmethod c-type-equal-p and ((type-a c-class-type)
- (type-b c-class-type))
- (eql (c-type-class type-a) (c-type-class type-b)))
-
-(defmethod print-c-type (stream (type c-class-type) &optional colon atsign)
- (declare (ignore colon atsign))
- (format stream "~:@<CLASS ~@_~S~{ ~_~S~}~:>"
- (c-type-name type)
- (c-type-qualifiers type)))
-
-(defun find-class-type (name &optional floc)
- "Look up NAME and return the corresponding C-CLASS-TYPE.
-
- Returns two values: TYPE and WINP.
-
- * If the type was found, and was a class, returns TYPE.
-
- * If no type was found at all, returns NIL.
-
- * If a type was found, but it wasn't a class, signals an error at FLOC."
-
- (with-default-error-location (floc)
- (let ((type (gethash name *type-map*)))
- (typecase type
- (null nil)
- (c-class-type type)
- (t (error "Type `~A' (~A) is not a class" name type))))))
-
-(defun make-class-type (name &optional floc)
- "Return a class type for NAME, creating it if necessary.
-
- FLOC is the location to use in error reports."
- (let ((name (etypecase name
- (sod-class (sod-class-name name))
- (string name))))
- (or (find-class-type name floc)
- (setf (gethash name *type-map*)
- (make-instance 'c-class-type :name name :class nil)))))
-
-(defun find-sod-class (name &optional floc)
- "Return the SOD-CLASS object with the given NAME.
-
- FLOC is the location to use in error reports."
- (with-default-error-location (floc)
- (let ((type (find-class-type name floc)))
- (cond ((not type) (error "Type `~A' not known" name))
- (t (let ((class (c-type-class type)))
- (unless class
- (error "Class `~A' is incomplete" name))
- class))))))
-
-(defun record-sod-class (class &optional (floc class))
- "Record CLASS as being a class definition.
-
- FLOC is the location to use in error reports."
- (with-default-error-location (floc)
- (let* ((name (sod-class-name class))
- (type (make-class-type name floc)))
- (cond ((null type) nil)
- ((c-type-class type)
- (cerror* "Class `~A' already defined at ~A"
- name (file-location (c-type-class type))))
- (t
- (setf (c-type-class type) class))))))
-
-(define-c-type-syntax class (name &rest quals)
- "Returns a type object for the named class."
- (if quals
- `(qualify-type (make-class-type ,name) (list ,@quals))
- `(make-class-type ,name)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Class finalization
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Class finalization.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Layout for instances and vtables
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Effective slot objects.
-
-(defclass effective-slot ()
- ((class :initarg :class :type sod-slot :reader effective-slot-class)
- (slot :initarg :slot :type sod-slot :reader effective-slot-direct-slot)
- (initializer :initarg :initializer :type (or sod-initializer null)
- :reader effective-slot-initializer))
- (:documentation
- "Describes a slot and how it's meant to be initialized.
-
- Effective slot objects are usually attached to layouts."))
-
-(defgeneric find-slot-initializer (class slot)
- (:documentation
- "Return the most specific initializer for SLOT, starting from CLASS."))
-
-(defgeneric compute-effective-slot (class slot)
- (:documentation
- "Construct an effective slot from the supplied direct slot.
-
- SLOT is a direct slot defined on CLASS or one of its superclasses.
- (Metaclass initializers are handled using a different mechanism.)"))
-
-;;;--------------------------------------------------------------------------
-;;; Instance layout objects.
-
-(defclass islots ()
- ((class :initarg :class :type sod-class :reader islots-class)
- (subclass :initarg :subclass :type sod-class :reader islots-subclass)
- (slots :initarg :slots :type list :reader islots-slots))
- (:documentation
- "The collection of effective SLOTS defined by an instance of CLASS."))
-
-;;; Standard implementation.
-
-;;;--------------------------------------------------------------------------
-;;; Effective methods.
-
-;;;--------------------------------------------------------------------------
-;;; Vtable layout.
-
-;;; vtmsgs
-
-;;; base-offset
-
-;;; chain-offset
-
-;;; vtable
-
-;;; Implementation.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Output functions for classes
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Classes.
-
-(defmethod hook-output progn ((class sod-class) (reason (eql :h))
- sequencer)
-
- ;; Main output sequencing.
- (sequence-output (stream sequencer)
-
- :constraint
- ((:classes :start)
- (class :banner)
- (class :islots :start) (class :islots :slots) (class :islots :end)
- (class :vtmsgs :start) (class :vtmsgs :end)
- (class :vtables :start) (class :vtables :end)
- (class :vtable-externs) (class :vtable-externs-after)
- (class :methods :start) (class :methods) (class :methods :end)
- (class :ichains :start) (class :ichains :end)
- (class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
- (class :conversions)
- (class :object)
- (:classes :end))
-
- (:typedefs
- (format stream "typedef struct ~A ~A;~%"
- (ichain-struct-tag class (sod-class-chain-head class)) class))
-
- ((class :banner)
- (banner (format nil "Class ~A" class) stream))
- ((class :vtable-externs-after)
- (terpri stream))
-
- ((class :vtable-externs)
- (format stream "/* Vtable structures. */~%"))
-
- ((class :object)
- (let ((metaclass (sod-class-metaclass class))
- (metaroot (find-root-metaclass class)))
- (format stream "/* The class object. */~@
- extern const struct ~A ~A__classobj;~@
- #define ~:*~A__class (&~:*~A__classobj.~A.~A)~2%"
- (ilayout-struct-tag metaclass) class
- (sod-class-nickname (sod-class-chain-head metaroot))
- (sod-class-nickname metaroot)))))
-
- ;; Maybe generate an islots structure.
- (when (sod-class-slots class)
- (dolist (slot (sod-class-slots class))
- (hook-output slot 'islots sequencer))
- (sequence-output (stream sequencer)
- ((class :islots :start)
- (format stream "/* Instance slots. */~@
- struct ~A {~%"
- (islots-struct-tag class)))
- ((class :islots :end)
- (format stream "};~2%"))))
-
- ;; Declare the direct methods.
- (when (sod-class-methods class)
- (sequence-output (stream sequencer)
- ((class :methods :start)
- (format stream "/* Direct methods. */~%"))
- ((class :methods :end)
- (terpri stream))))
-
- ;; Provide upcast macros which do the right thing.
- (when (sod-class-direct-superclasses class)
- (sequence-output (stream sequencer)
- ((class :conversions)
- (let ((chain-head (sod-class-chain-head class)))
- (format stream "/* Conversion macros. */~%")
- (dolist (super (cdr (sod-class-precedence-list class)))
- (let ((super-head (sod-class-chain-head super)))
- (format stream "#define ~:@(~A__CONV_~A~)(p) ((~A *)~
- ~:[SOD_XCHAIN(~A, (p))~;(p)~])~%"
- class (sod-class-nickname super) super
- (eq chain-head super-head)
- (sod-class-nickname super-head))))
- (terpri stream)))))
-
- ;; Generate vtmsgs structure for all superclasses.
- (hook-output (car (sod-class-vtables class))
- 'vtmsgs
- sequencer))
-
-(defmethod hook-output progn ((class sod-class) reason sequencer)
- (with-slots (ilayout vtables methods effective-methods) class
- (hook-output ilayout reason sequencer)
- (dolist (method methods) (hook-output method reason sequencer))
- (dolist (method effective-methods)
- (hook-output method reason sequencer))
- (dolist (vtable vtables) (hook-output vtable reason sequencer))))
-
-;;;--------------------------------------------------------------------------
-;;; Instance structure.
-
-(defmethod hook-output progn ((slot sod-slot) (reason (eql 'islots))
- sequencer)
- (sequence-output (stream sequencer)
- (((sod-slot-class slot) :islots :slots)
- (pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type (sod-slot-type slot) stream (sod-slot-name slot)))
- (terpri stream))))
-
-(defmethod hook-output progn ((ilayout ilayout) reason sequencer)
- (with-slots (ichains) ilayout
- (dolist (ichain ichains) (hook-output ichain reason sequencer))))
-
-(defmethod hook-output progn ((ichain ichain) reason sequencer)
- (dolist (item (ichain-body ichain))
- (hook-output item reason sequencer)))
-
-(defmethod hook-output progn ((ilayout ilayout) (reason (eql :h))
- sequencer)
- (with-slots (class ichains) ilayout
- (sequence-output (stream sequencer)
- ((class :ilayout :start)
- (format stream "/* Instance layout. */~@
- struct ~A {~%"
- (ilayout-struct-tag class)))
- ((class :ilayout :end)
- (format stream "};~2%")))
- (dolist (ichain ichains)
- (hook-output ichain 'ilayout sequencer))))
-
-(defmethod hook-output progn ((ichain ichain) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head chain-tail) ichain
- (when (eq class chain-tail)
- (sequence-output (stream sequencer)
- :constraint ((class :ichains :start)
- (class :ichain chain-head :start)
- (class :ichain chain-head :slots)
- (class :ichain chain-head :end)
- (class :ichains :end))
- ((class :ichain chain-head :start)
- (format stream "/* Instance chain structure. */~@
- struct ~A {~%"
- (ichain-struct-tag chain-tail chain-head)))
- ((class :ichain chain-head :end)
- (format stream "};~2%")
- (format stream "/* Union of equivalent superclass chains. */~@
- union ~A {~@
- ~:{ struct ~A ~A;~%~}~
- };~2%"
- (ichain-union-tag chain-tail chain-head)
-
- ;; Make sure the most specific class is first: only the
- ;; first element of a union can be statically initialized in
- ;; C90.
- (mapcar (lambda (super)
- (list (ichain-struct-tag super chain-head)
- (sod-class-nickname super)))
- (sod-class-chain chain-tail))))))))
-
-(defmethod hook-output progn ((ichain ichain) (reason (eql 'ilayout))
- sequencer)
- (with-slots (class chain-head chain-tail) ichain
- (sequence-output (stream sequencer)
- ((class :ilayout :slots)
- (format stream " union ~A ~A;~%"
- (ichain-union-tag chain-tail chain-head)
- (sod-class-nickname chain-head))))))
-
-(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head chain-tail) vtptr
- (sequence-output (stream sequencer)
- ((class :ichain chain-head :slots)
- (format stream " const struct ~A *_vt;~%"
- (vtable-struct-tag chain-tail chain-head))))))
-
-(defmethod hook-output progn ((islots islots) reason sequencer)
- (dolist (slot (islots-slots islots))
- (hook-output slot reason sequencer)))
-
-(defmethod hook-output progn ((islots islots) (reason (eql :h))
- sequencer)
- (with-slots (class subclass slots) islots
- (sequence-output (stream sequencer)
- ((subclass :ichain (sod-class-chain-head class) :slots)
- (format stream " struct ~A ~A;~%"
- (islots-struct-tag class)
- (sod-class-nickname class))))))
-
-;;;--------------------------------------------------------------------------
-;;; Vtable structure.
-
-(defmethod hook-output progn ((vtable vtable) reason sequencer)
- (with-slots (body) vtable
- (dolist (item body) (hook-output item reason sequencer))))
-
-(defmethod hook-output progn ((method sod-method) (reason (eql :h))
- sequencer)
- (with-slots (class) method
- (sequence-output (stream sequencer)
- ((class :methods)
- (let ((type (sod-method-function-type method)))
- (princ "extern " stream)
- (pprint-c-type (commentify-function-type type) stream
- (sod-method-function-name method))
- (format stream ";~%"))))))
-
-(defmethod hook-output progn ((vtable vtable) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head chain-tail) vtable
- (when (eq class chain-tail)
- (sequence-output (stream sequencer)
- :constraint ((class :vtables :start)
- (class :vtable chain-head :start)
- (class :vtable chain-head :slots)
- (class :vtable chain-head :end)
- (class :vtables :end))
- ((class :vtable chain-head :start)
- (format stream "/* Vtable structure. */~@
- struct ~A {~%"
- (vtable-struct-tag chain-tail chain-head)))
- ((class :vtable chain-head :end)
- (format stream "};~2%"))))
- (sequence-output (stream sequencer)
- ((class :vtable-externs)
- (format stream "~@<extern struct ~A ~2I~_~A__vtable_~A;~:>~%"
- (vtable-struct-tag chain-tail chain-head)
- class (sod-class-nickname chain-head))))))
-
-(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :h))
- sequencer)
- (with-slots (class subclass chain-head chain-tail) vtmsgs
- (sequence-output (stream sequencer)
- ((subclass :vtable chain-head :slots)
- (format stream " struct ~A ~A;~%"
- (vtmsgs-struct-tag subclass class)
- (sod-class-nickname class))))))
-
-(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql 'vtmsgs))
- sequencer)
- (when (vtmsgs-entries vtmsgs)
- (with-slots (class subclass) vtmsgs
- (sequence-output (stream sequencer)
- :constraint ((subclass :vtmsgs :start)
- (subclass :vtmsgs class :start)
- (subclass :vtmsgs class :slots)
- (subclass :vtmsgs class :end)
- (subclass :vtmsgs :end))
- ((subclass :vtmsgs class :start)
- (format stream "/* Messages protocol from class ~A */~@
- struct ~A {~%"
- class
- (vtmsgs-struct-tag subclass class)))
- ((subclass :vtmsgs class :end)
- (format stream "};~2%"))))))
-
-(defmethod hook-output progn ((vtmsgs vtmsgs) reason sequencer)
- (with-slots (entries) vtmsgs
- (dolist (entry entries) (hook-output entry reason sequencer))))
-
-(defmethod hook-output progn ((entry method-entry) reason sequencer)
- (with-slots (method) entry
- (hook-output method reason sequencer)))
-
-(defmethod hook-output progn ((entry method-entry) (reason (eql 'vtmsgs))
- sequencer)
- (let* ((method (method-entry-effective-method entry))
- (message (effective-method-message method))
- (class (effective-method-class method))
- (type (method-entry-function-type entry))
- (commented-type (commentify-function-type type)))
- (sequence-output (stream sequencer)
- ((class :vtmsgs (sod-message-class message) :slots)
- (pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type commented-type stream (sod-message-name message)))
- (terpri stream)))))
-
-(defmethod hook-output progn ((cptr class-pointer) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head metaclass meta-chain-head) cptr
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :slots)
- (format stream " const ~A *~:[_class~;~:*_cls_~A~];~%"
- metaclass
- (if (sod-class-direct-superclasses meta-chain-head)
- (sod-class-nickname meta-chain-head)
- nil))))))
-
-(defmethod hook-output progn ((boff base-offset) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head) boff
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :slots)
- (write-line " size_t _base;" stream)))))
-
-(defmethod hook-output progn ((choff chain-offset) (reason (eql :h))
- sequencer)
- (with-slots (class chain-head target-head) choff
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :slots)
- (format stream " ptrdiff_t _off_~A;~%"
- (sod-class-nickname target-head))))))
-
-;;;--------------------------------------------------------------------------
-;;; Implementation output.
-
-(defvar *instance-class*)
-
-(defmethod hook-output progn ((class sod-class) (reason (eql :c))
- sequencer)
- (sequence-output (stream sequencer)
-
- :constraint
- ((:classes :start)
- (class :banner)
- (class :direct-methods :start) (class :direct-methods :end)
- (class :effective-methods)
- (class :vtables :start) (class :vtables :end)
- (class :object :prepare) (class :object :start) (class :object :end)
- (:classes :end))
-
- ((class :banner)
- (banner (format nil "Class ~A" class) stream))
-
- ((class :object :start)
- (format stream "~
-/* The class object. */
-const struct ~A ~A__classobj = {~%"
- (ilayout-struct-tag (sod-class-metaclass class))
- class))
- ((class :object :end)
- (format stream "};~2%")))
-
- (let ((*instance-class* class))
- (hook-output (sod-class-ilayout (sod-class-metaclass class))
- 'class
- sequencer)))
-
-;;;--------------------------------------------------------------------------
-;;; Direct methods.
-
-(defmethod hook-output progn ((method delegating-direct-method) (reason (eql :c))
- sequencer)
- (with-slots (class body) method
- (unless body
- (return-from hook-output))
- (sequence-output (stream sequencer)
- ((class :direct-method method :start)
- (format stream "#define CALL_NEXT_METHOD (next_method(~{~A~^, ~}))~%"
- (mapcar #'argument-name
- (c-function-arguments (sod-method-next-method-type
- method)))))
- ((class :direct-method method :end)
- (format stream "#undef CALL_NEXT_METHOD~%")))))
-
-(defmethod hook-output progn ((method sod-method) (reason (eql :c))
- sequencer)
- (with-slots (class body) method
- (unless body
- (return-from hook-output))
- (sequence-output (stream sequencer)
- :constraint ((class :direct-methods :start)
- (class :direct-method method :start)
- (class :direct-method method :body)
- (class :direct-method method :end)
- (class :direct-methods :end))
- ((class :direct-method method :body)
- (pprint-c-type (sod-method-function-type method)
- stream
- (sod-method-function-name method))
- (format stream "~&{~%")
- (write body :stream stream :pretty nil :escape nil)
- (format stream "~&}~%"))
- ((class :direct-method method :end)
- (terpri stream)))))
-
-;;;--------------------------------------------------------------------------
-;;; Vtables.
-
-(defmethod hook-output progn ((vtable vtable) (reason (eql :c))
- sequencer)
- (with-slots (class chain-head chain-tail) vtable
- (sequence-output (stream sequencer)
- :constraint ((class :vtables :start)
- (class :vtable chain-head :start)
- (class :vtable chain-head :end)
- (class :vtables :end))
- ((class :vtable chain-head :start)
- (format stream "/* Vtable for ~A chain. */~@
- static const struct ~A ~A = {~%"
- chain-head
- (vtable-struct-tag chain-tail chain-head)
- (vtable-name chain-tail chain-head)))
- ((class :vtable chain-head :end)
- (format stream "};~2%")))))
-
-(defmethod hook-output progn ((cptr class-pointer) (reason (eql :c))
- sequencer)
- (with-slots (class chain-head metaclass meta-chain-head) cptr
- (sequence-output (stream sequencer)
- :constraint ((class :vtable chain-head :start)
- (class :vtable chain-head :class-pointer metaclass)
- (class :vtable chain-head :end))
- ((class :vtable chain-head :class-pointer metaclass)
- (format stream " &~A__classobj.~A.~A,~%"
- (sod-class-metaclass class)
- (sod-class-nickname meta-chain-head)
- (sod-class-nickname metaclass))))))
-
-(defmethod hook-output progn ((boff base-offset) (reason (eql :c))
- sequencer)
- (with-slots (class chain-head) boff
- (sequence-output (stream sequencer)
- :constraint ((class :vtable chain-head :start)
- (class :vtable chain-head :base-offset)
- (class :vtable chain-head :end))
- ((class :vtable chain-head :base-offset)
- (format stream " offsetof(struct ~A, ~A),~%"
- (ilayout-struct-tag class)
- (sod-class-nickname chain-head))))))
-
-(defmethod hook-output progn ((choff chain-offset) (reason (eql :c))
- sequencer)
- (with-slots (class chain-head target-head) choff
- (sequence-output (stream sequencer)
- :constraint ((class :vtable chain-head :start)
- (class :vtable chain-head :chain-offset target-head)
- (class :vtable chain-head :end))
- ((class :vtable chain-head :chain-offset target-head)
- (format stream " SOD_OFFSETDIFF(struct ~A, ~A, ~A),~%"
- (ilayout-struct-tag class)
- (sod-class-nickname chain-head)
- (sod-class-nickname target-head))))))
-
-(defmethod hook-output progn ((vtmsgs vtmsgs) (reason (eql :c))
- sequencer)
- (with-slots (class subclass chain-head) vtmsgs
- (sequence-output (stream sequencer)
- :constraint ((subclass :vtable chain-head :start)
- (subclass :vtable chain-head :vtmsgs class :start)
- (subclass :vtable chain-head :vtmsgs class :slots)
- (subclass :vtable chain-head :vtmsgs class :end)
- (subclass :vtable chain-head :end))
- ((subclass :vtable chain-head :vtmsgs class :start)
- (format stream " { /* Method entries for ~A messages. */~%"
- class))
- ((subclass :vtable chain-head :vtmsgs class :end)
- (format stream " },~%")))))
-
-(defmethod hook-output progn ((entry method-entry) (reason (eql :c))
- sequencer)
- (with-slots (method chain-head chain-tail) entry
- (let* ((message (effective-method-message method))
- (class (effective-method-class method))
- (super (sod-message-class message)))
- (sequence-output (stream sequencer)
- ((class :vtable chain-head :vtmsgs super :slots)
- (format stream " ~A,~%"
- (method-entry-function-name method chain-head)))))))
-
-;;;--------------------------------------------------------------------------
-;;; Filling in the class object.
-
-(defmethod hook-output progn ((ichain ichain) (reason (eql 'class))
- sequencer)
- (with-slots (class chain-head) ichain
- (sequence-output (stream sequencer)
- :constraint ((*instance-class* :object :start)
- (*instance-class* :object chain-head :ichain :start)
- (*instance-class* :object chain-head :ichain :end)
- (*instance-class* :object :end))
- ((*instance-class* :object chain-head :ichain :start)
- (format stream " { { /* ~A ichain */~%"
- (sod-class-nickname chain-head)))
- ((*instance-class* :object chain-head :ichain :end)
- (format stream " } },~%")))))
-
-(defmethod hook-output progn ((islots islots) (reason (eql 'class))
- sequencer)
- (with-slots (class) islots
- (let ((chain-head (sod-class-chain-head class)))
- (sequence-output (stream sequencer)
- :constraint ((*instance-class* :object chain-head :ichain :start)
- (*instance-class* :object class :slots :start)
- (*instance-class* :object class :slots)
- (*instance-class* :object class :slots :end)
- (*instance-class* :object chain-head :ichain :end))
- ((*instance-class* :object class :slots :start)
- (format stream " { /* Class ~A */~%" class))
- ((*instance-class* :object class :slots :end)
- (format stream " },~%"))))))
-
-(defmethod hook-output progn ((vtptr vtable-pointer) (reason (eql 'class))
- sequencer)
- (with-slots (class chain-head chain-tail) vtptr
- (sequence-output (stream sequencer)
- :constraint ((*instance-class* :object chain-head :ichain :start)
- (*instance-class* :object chain-head :vtable)
- (*instance-class* :object chain-head :ichain :end))
- ((*instance-class* :object chain-head :vtable)
- (format stream " &~A__vtable_~A,~%"
- class (sod-class-nickname chain-head))))))
-
-(defgeneric find-class-initializer (slot class)
- (:method ((slot effective-slot) (class sod-class))
- (let ((dslot (effective-slot-direct-slot slot)))
- (or (some (lambda (super)
- (find dslot (sod-class-class-initializers super)
- :test #'sod-initializer-slot))
- (sod-class-precedence-list class))
- (effective-slot-initializer slot)))))
-
-(defgeneric output-class-initializer (slot instance stream)
- (:method ((slot sod-class-effective-slot) (instance sod-class) stream)
- (let ((func (effective-slot-initializer-function slot)))
- (if func
- (format stream " ~A,~%" (funcall func instance))
- (call-next-method))))
- (:method ((slot effective-slot) (instance sod-class) stream)
- (let ((init (find-class-initializer slot instance)))
- (ecase (sod-initializer-value-kind init)
- (:simple (format stream " ~A,~%"
- (sod-initializer-value-form init)))
- (:compound (format stream " ~@<{ ~;~A~; },~:>~%"
- (sod-initializer-value-form init)))))))
-
-(defmethod hook-output progn ((slot sod-class-effective-slot) (reason (eql 'class))
- sequencer)
- (let ((instance *instance-class*)
- (func (effective-slot-prepare-function slot)))
- (when func
- (sequence-output (stream sequencer)
- ((instance :object :prepare)
- (funcall func instance stream))))))
-
-(defmethod hook-output progn ((slot effective-slot) (reason (eql 'class))
- sequencer)
- (with-slots (class (dslot slot)) slot
- (let ((instance *instance-class*)
- (super (sod-slot-class dslot)))
- (sequence-output (stream sequencer)
- ((instance :object super :slots)
- (output-class-initializer slot instance stream))))))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(defun test (name)
- (let ((sequencer (make-instance 'sequencer))
- (class (find-sod-class name)))
- (hook-output class :h sequencer)
- (invoke-sequencer-items sequencer *standard-output*)
- sequencer))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Code generator for effective methods
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Temporary names.
-
-;;;--------------------------------------------------------------------------
-;;; Instructions.
-
-;;;--------------------------------------------------------------------------
-;;; Instruction types.
-;; Top level things.
-
-;;;--------------------------------------------------------------------------
-;;; Code generator objects.
-
-(defgeneric emit-inst (codegen inst)
- (:documentation
- "Add INST to the end of CODEGEN's list of instructions.")
- (:method ))
-
-(defgeneric emit-insts (codegen insts)
- (:documentation
- "Add a list of INSTS to the end of CODEGEN's list of instructions.")
- (:method))
-
-(defgeneric ensure-var (codegen name type &optional init)
- (:documentation
- "Add a variable to CODEGEN's list.
-
- The variable is called NAME (which should be comparable using EQUAL and
- print to an identifier) and has the given TYPE. If INIT is present and
- non-nil it is an expression INST used to provide the variable with an
- initial value.")
- (:method))
-
-(defgeneric codegen-push (codegen)
- (:documentation
- "Pushes the current code generation state onto a stack.
-
- The state consists of the accumulated variables and instructions, i.e.,
- what is representable by a BASIC-CODEGEN.")
- (:method))
-
-(defgeneric codegen-pop (codegen)
- (:documentation
- "Pops a saved state off of the CODEGEN's stack.
-
- Returns the newly accumulated variables and instructions as lists, as
- separate values.")
- (:method))
-
-(defgeneric codegen-add-function (codegen function)
- (:documentation
- "Adds a function to CODEGEN's list.
-
- Actually, we're not picky: FUNCTION can be any kind of object that you're
- willing to find in the list returned by CODEGEN-FUNCTIONS.")
- (:method ))
-
-
-;;;--------------------------------------------------------------------------
-;;; Code generation idioms.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Method combinations
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Common behaviour.
-
-;;;--------------------------------------------------------------------------
-;;; Standard method combination.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Computing class precedence lists
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Linearizations.
-
-;;;--------------------------------------------------------------------------
-;;; Class protocol.
-
-(defgeneric compute-cpl (class)
- (:documentation
- "Returns the class precedence list for CLASS."))
-
-;;;--------------------------------------------------------------------------
-;;; Testing.
-
-#+test
-(progn
- (defclass test-class ()
- ((name :initarg :name :accessor sod-class-name)
- (direct-superclasses :initarg :superclasses
- :accessor sod-class-direct-superclasses)
- (class-precedence-list)))
-
- (defmethod print-object ((class test-class) stream)
- (if *print-escape*
- (print-unreadable-object (class stream :type t :identity nil)
- (princ (sod-class-name class) stream))
- (princ (sod-class-name class) stream)))
-
- (defvar *test-linearization*)
-
- (defmethod sod-class-precedence-list ((class test-class))
- (if (slot-boundp class 'class-precedence-list)
- (slot-value class 'class-precedence-list)
- (setf (slot-value class 'class-precedence-list)
- (funcall *test-linearization* class)))))
-
-#+test
-(defun test-cpl (linearization heterarchy)
- (let* ((*test-linearization* linearization)
- (classes (make-hash-table :test #'equal)))
- (dolist (class heterarchy)
- (let ((name (car class)))
- (setf (gethash (car class) classes)
- (make-instance 'test-class :name name))))
- (dolist (class heterarchy)
- (setf (sod-class-direct-superclasses (gethash (car class) classes))
- (mapcar (lambda (super) (gethash super classes)) (cdr class))))
- (mapcar (lambda (class)
- (handler-case
- (mapcar #'sod-class-name
- (sod-class-precedence-list (gethash (car class)
- classes)))
- (inconsistent-merge-error ()
- (list (car class) :error))))
- heterarchy)))
-
-#+test
-(progn
- (defparameter *confused-heterarchy*
- '((object) (grid-layout object)
- (horizontal-grid grid-layout) (vertical-grid grid-layout)
- (hv-grid horizontal-grid vertical-grid)
- (vh-grid vertical-grid horizontal-grid)
- (confused-grid hv-grid vh-grid)))
- (defparameter *boat-heterarchy*
- '((object)
- (boat object)
- (day-boat boat)
- (wheel-boat boat)
- (engine-less day-boat)
- (small-multihull day-boat)
- (pedal-wheel-boat engine-less wheel-boat)
- (small-catamaran small-multihull)
- (pedalo pedal-wheel-boat small-catamaran)))
- (defparameter *menu-heterarchy*
- '((object)
- (choice-widget object)
- (menu choice-widget)
- (popup-mixin object)
- (popup-menu menu popup-mixin)
- (new-popup-menu menu popup-mixin choice-widget)))
- (defparameter *pane-heterarchy*
- '((pane) (scrolling-mixin) (editing-mixin)
- (scrollable-pane pane scrolling-mixin)
- (editable-pane pane editing-mixin)
- (editable-scrollable-pane scrollable-pane editable-pane)))
- (defparameter *baker-nonmonotonic-heterarchy*
- '((z) (x z) (y) (b y) (a b x) (c a b x y)))
- (defparameter *baker-nonassociative-heterarchy*
- '((a) (b) (c a) (ab a b) (ab-c ab c) (bc b c) (a-bc a bc)))
- (defparameter *distinguishing-heterarchy*
- '((object)
- (a object) (b object) (c object)
- (p a b) (q a c)
- (u p) (v q)
- (x u v)
- (y x b c)
- (z x c b)))
- (defparameter *python-heterarchy*
- '((object)
- (a object) (b object) (c object) (d object) (e object)
- (k1 a b c)
- (k2 d b e)
- (k3 d a)
- (z k1 k2 k3))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;;--------------------------------------------------------------------------
-;;; C types stuff.
-
-(cl:defpackage #:c-types
- (:use #:common-lisp
- #+sbcl #:sb-mop
- #+(or cmu clisp) #:mop
- #+ecl #:clos)
- (:export #:c-type
- #:c-declarator-priority #:maybe-parenthesize
- #:pprint-c-type
- #:c-type-subtype #:compount-type-declaration
- #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
- #:simple-c-type #:c-type-name
- #:c-pointer-type
- #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
- #:tagged-c-type-kind
- #:c-array-type #:c-array-dimensions
- #:make-argument #:argument-name #:argument-type
- #:c-function-type #:c-function-arguments
-
- #:define-c-type-syntax #:c-type-alias #:defctype
- #:print-c-type
- #:qualifier #:declare-qualifier
- #:define-simple-c-type
-
- #:const #:volatile #:static #:restrict
- #:char #:unsigned-char #:uchar #:signed-char #:schar
- #:int #:signed #:signed-int #:sint
- #:unsigned #:unsigned-int #:uint
- #:short #:signed-short #:short-int #:signed-short-int #:sshort
- #:unsigned-short #:unsigned-short-int #:ushort
- #:long #:signed-long #:long-int #:signed-long-int #:slong
- #:unsigned-long #:unsigned-long-int #:ulong
- #:float #:double #:long-double
- #:pointer #:ptr
- #:[] #:vec
- #:fun #:func #:fn))
-
-
-;;;--------------------------------------------------------------------------
-;;; Convenient syntax for C types.
-
-;; Basic machinery.
-
-;; Qualifiers. They have hairy syntax and need to be implemented by hand.
-
-;; Simple types.
-
-;; Pointers.
-
-;; Tagged types.
-
-;; Arrays.
-
-;; Functions.
-
-
-(progn
- (defconstant q-byte (byte 3 0))
- (defconstant q-const 1)
- (defconstant q-volatile 2)
- (defconstant q-restrict 4)
-
- (defconstant z-byte (byte 3 3))
- (defconstant z-unspec 0)
- (defconstant z-short 1)
- (defconstant z-long 2)
- (defconstant z-long-long 3)
- (defconstant z-double 4)
- (defconstant z-long-double 5)
-
- (defconstant s-byte (byte 2 6))
- (defconstant s-unspec 0)
- (defconstant s-signed 1)
- (defconstant s-unsigned 2)
-
- (defconstant t-byte (byte 3 8))
- (defconstant t-unspec 0)
- (defconstant t-int 1)
- (defconstant t-char 2)
- (defconstant t-float 3)
- (defconstant t-user 4))
-
-(defun make-type-flags (size sign type &rest quals)
- (let ((flags 0))
- (dolist (qual quals)
- (setf flags (logior flags qual)))
- (setf (ldb z-byte flags) size
- (ldb s-byte flags) sign
- (ldb t-byte flags) type)
- flags))
-
-
-(defun expand-c-type (spec)
- "Parse SPEC as a C type and return the result.
-
- The SPEC can be one of the following.
-
- * A C-TYPE object, which is returned immediately.
-
- * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
- function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
- or some other means is invoked on the ARGUMENTS, and the result is
- returned.
-
- * A symbol, which is treated the same way as a singleton list would be."
-
- (flet ((interp (sym)
- (or (get sym 'c-type)
- (error "Unknown C type operator ~S." sym))))
- (etypecase spec
- (c-type spec)
- (symbol (funcall (interp spec)))
- (list (apply (interp (car spec)) (cdr spec))))))
-
-(defmacro c-type (spec)
- "Evaluates to the type that EXPAND-C-TYPE would return.
-
- Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime. Maybe
- later it will do something more clever."
- `(expand-c-type ',spec))
-
-;; S-expression machinery. Qualifiers have hairy syntax and need to be
-;; implemented by hand.
-
-(defun qualifier (qual &rest args)
- "Parse a qualified C type.
-
- The ARGS consist of a number of qualifiers and exactly one C-type
- S-expression. The result is a qualified version of this type, with the
- given qualifiers attached."
- (if (null args)
- qual
- (let* ((things (mapcar #'expand-c-type args))
- (quals (delete-duplicates
- (sort (cons qual (remove-if-not #'keywordp things))
- #'string<)))
- (types (remove-if-not (lambda (thing) (typep thing 'c-type))
- things)))
- (when (or (null types)
- (not (null (cdr types))))
- (error "Only one proper type expected in ~S." args))
- (qualify-type (car types) quals))))
-(setf (get 'qualifier 'c-type) #'qualifier)
-
-(defun declare-qualifier (qual)
- "Defines QUAL as being a type qualifier.
-
- When used as a C-type operator, it applies that qualifier to the type that
- is its argument."
- (let ((kw (intern (string qual) :keyword)))
- (setf (get qual 'c-type)
- (lambda (&rest args)
- (apply #'qualifier kw args)))))
-
-;; Define some initial qualifiers.
-(dolist (qual '(const volatile restrict))
- (declare-qualifier qual))
-
-
-(define-c-type-syntax simple-c-type (name)
- "Constructs a simple C type called NAME (a string or symbol)."
- (make-simple-type (c-name-case name)))
-
-(defmethod print-c-type :around
- (stream (type qualifiable-c-type) &optional colon atsign)
- (if (c-type-qualifiers type)
- (pprint-logical-block (stream nil :prefix "(" :suffix ")")
- (format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
- (c-type-qualifiers type))
- (call-next-method stream type colon atsign))
- (call-next-method)))
-;; S-expression syntax.
-
-
-(define-c-type-syntax enum (tag)
- "Construct an enumeration type named TAG."
- (make-instance 'c-enum-type :tag (c-name-case tag)))
-(define-c-type-syntax struct (tag)
- "Construct a structure type named TAG."
- (make-instance 'c-struct-type :tag (c-name-case tag)))
-(define-c-type-syntax union (tag)
- "Construct a union type named TAG."
- (make-instance 'c-union-type :tag (c-name-case tag)))
-
-(defgeneric make-me-argument (message class)
- (:documentation
- "Return an ARGUMENT object for the `me' argument to MESSAGE, as
- specialized to CLASS."))
-
-(defmethod make-me-argument
- ((message basic-message) (class sod-class))
- (make-argument "me" (make-instance 'c-pointer-type
- :subtype (sod-class-type class))))
-
-;;;--------------------------------------------------------------------------
-;;; Keyword arguments and lambda lists.
-
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defun transform-otherkeys-lambda-list (bvl)
- "Process a simple lambda-list BVL which might contain &OTHER-KEYS.
-
- &OTHER-KEYS VAR, if it appears, must appear just after the &KEY arguments
- (which must also be present); &ALLOW-OTHER-KEYS must not be present.
-
- The behaviour is that
-
- * the presence of non-listed keyword arguments is permitted, as if
- &ALLOW-OTHER-KEYS had been provided, and
-
- * a list of the keyword arguments other than the ones explicitly listed
- is stored in the VAR.
-
- The return value is a replacement BVL which binds the &OTHER-KEYS variable
- as an &AUX parameter if necessary.
-
- At least for now, fancy things like destructuring lambda-lists aren't
- supported. I suspect you'll get away with a specializing lambda-list."
-
- (prog ((new-bvl nil)
- (rest-var nil)
- (keywords nil)
- (other-keys-var nil)
- (tail bvl))
-
- find-rest
- ;; Scan forwards until we find &REST or &KEY. If we find the former,
- ;; then remember the variable name. If we find the latter first then
- ;; there can't be a &REST argument, so we should invent one. If we
- ;; find neither then there's nothing to do.
- (when (endp tail)
- (go ignore))
- (let ((item (pop tail)))
- (push item new-bvl)
- (case item
- (&rest (when (endp tail)
- (error "Missing &REST argument name"))
- (setf rest-var (pop tail))
- (push rest-var new-bvl))
- (&aux (go ignore))
- (&key (unless rest-var
- (setf rest-var (gensym "REST"))
- (setf new-bvl (nconc (list '&key rest-var '&rest)
- (cdr new-bvl))))
- (go scan-keywords)))
- (go find-rest))
-
- scan-keywords
- ;; Read keyword argument specs one-by-one. For each one, stash it on
- ;; the NEW-BVL list, and also parse it to extract the keyword, which
- ;; we stash in KEYWORDS. If we don't find &OTHER-KEYS then there's
- ;; nothing for us to do.
- (when (endp tail)
- (go ignore))
- (let ((item (pop tail)))
- (push item new-bvl)
- (case item
- ((&aux &allow-other-keys) (go ignore))
- (&other-keys (go fix-tail)))
- (let ((keyword (if (symbolp item)
- (intern (symbol-name item) :keyword)
- (let ((var (car item)))
- (if (symbolp var)
- (intern (symbol-name var) :keyword)
- (car var))))))
- (push keyword keywords))
- (go scan-keywords))
-
- fix-tail
- ;; We found &OTHER-KEYS. Pick out the &OTHER-KEYS var.
- (pop new-bvl)
- (when (endp tail)
- (error "Missing &OTHER-KEYS argument name"))
- (setf other-keys-var (pop tail))
- (push '&allow-other-keys new-bvl)
-
- ;; There should be an &AUX next. If there isn't, assume there isn't
- ;; one and provide our own. (This is safe as long as nobody else is
- ;; expecting to plumb in lambda keywords too.)
- (when (and (not (endp tail)) (eq (car tail) '&aux))
- (pop tail))
- (push '&aux new-bvl)
-
- ;; Add our shiny new &AUX argument.
- (let ((keys-var (gensym "KEYS"))
- (list-var (gensym "LIST")))
- (push `(,other-keys-var (do ((,list-var nil)
- (,keys-var ,rest-var (cddr ,keys-var)))
- ((endp ,keys-var) (nreverse ,list-var))
- (unless (member (car ,keys-var)
- ',keywords)
- (setf ,list-var
- (cons (cadr ,keys-var)
- (cons (car ,keys-var)
- ,list-var))))))
- new-bvl))
-
- ;; Done.
- (return (nreconc new-bvl tail))
-
- ignore
- ;; Nothing to do. Return the unmolested lambda-list.
- (return bvl))))
-
-(defmacro lambda-otherkeys (bvl &body body)
- "Like LAMBDA, but with a new &OTHER-KEYS lambda-list keyword."
- `(lambda ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defun-otherkeys (name bvl &body body)
- "Like DEFUN, but with a new &OTHER-KEYS lambda-list keyword."
- `(defun ,name ,(transform-otherkeys-lambda-list bvl) ,@body))
-
-(defmacro defmethod-otherkeys (name &rest stuff)
- "Like DEFMETHOD, but with a new &OTHER-KEYS lambda-list keyword."
- (do ((quals nil)
- (stuff stuff (cdr stuff)))
- ((listp (car stuff))
- `(defmethod ,name ,@(nreverse quals)
- ,(transform-otherkeys-lambda-list (car stuff))
- ,@(cdr stuff)))
- (push (car stuff) quals)))
-
-
-(defparse many ((acc init update
- &key (new 'it) (final acc) (min nil minp) max (commitp t))
- parser &optional (sep nil sepp))
- "Parse a sequence of homogeneous items.
-
- The behaviour is similar to `do'. Initially an accumulator ACC is
- established, and bound to the value of INIT. The PARSER is then evaluated
- repeatedly. Each time it succeeds, UPDATE is evaluated with NEW (defaults
- to `it') bound to the result of the parse, and the value returned by
- UPDATE is stored back into ACC. If the PARSER fails, then the parse ends.
-
- If a SEP parser is provided, then the behaviour changes as follows.
- Before each attempt to parse a new item using PARSER, the parser SEP is
- invoked. If SEP fails then the parse ends; if SEP succeeds, then the
- PARSER must also succeed or the overall parse will fail.
-
- If MAX (which will be evaluated) is not nil, then it must be a number: the
- parse ends automatically after PARSER has succeeded MAX times. When the
- parse has ended, if the PARSER succeeded fewer than MIN (which will be
- evaluated) times then the parse fails. Otherwise, the FINAL form (which
- defaults to simply returning ACC) is evaluated and its value becomes the
- result of the parse. MAX defaults to nil -- i.e., no maximum; MIN
- defaults to 1 if a SEP parser is given, or 0 if not.
-
- Note that `many' cannot fail if MIN is zero."
-
- (unless minp (setf min (if sepp 1 0)))
- (with-gensyms (block value win consumedp cp i up done)
- (once-only (init min max commitp)
- (let ((counterp (or max (not (numberp min)) (> min (if sepp 1 0)))))
- `(block ,block
-
- ;; Keep track of variables. We only need an accumulator if it's
- ;; not nil, and we don't need a counter if (a) there's no maximum,
- ;; and either (b) the minimum is zero, or (c) the minimum is one
- ;; and there's a separator. In case (c), we can keep track of how
- ;; much has been seen using control flow.
- (let ((,consumedp nil)
- ,@(and acc `((,acc ,init)))
- ,@(and counterp `((,i 0))))
-
- ;; Some handy functions. `up' will update the accumulator.
- ;; `done' will return the necessary final value.
- (flet (,@(and acc `((,up (,new)
- (declare (ignorable ,new))
- (setf ,acc ,update))))
- (,done () (return-from ,block
- (values ,final t ,consumedp))))
-
- ;; If there's a separator, prime the pump by parsing a first
- ;; item. This makes the loop easy: it just parses a separator
- ;; and an item each time. And it means we don't need a
- ;; counter in the case of a minimum of 1.
- ,@(and sepp
- `((multiple-value-bind (,value ,win ,cp)
- (parse ,parser)
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(cond ((eql min 0)
- `(,done))
- ((and (numberp min) (plusp min))
- `(return-from ,block
- (values ,value nil ,consumedp)))
- (t
- `(if (< 0 ,min)
- (return-from ,block
- (values ,value nil, consumedp))
- (,done)))))
- ,@(and acc `((,up ,value))))
- ,@(and counterp `((incf ,i)))))
-
- ;; The main loop...
- (loop
-
- ;; If we've hit the maximum then stop. But, attention, if
- ;; we have a separator and we're not committing to parsing
- ;; items, then check after scanning the separator, not
- ;; before.
- ,@(and max commitp
- `((when (and ,@(and (not (constantp max))
- `(,max))
- ,@(and (not (constantp commitp))
- `(,commitp))
- (>= ,i ,max))
- (,done))))
-
- ,@(if sepp
- ;; We're expecting a separator. If this fails and
- ;; we're below minimum then we've failed altogether.
- ;; If it succeeds then we should go on to parse an
- ;; item.
- `((multiple-value-bind (,value ,win ,cp) (parse ,sep)
- ,@(and (numberp min) (<= min 1)
- `((declare (ignore ,value))))
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(if (and (numberp min) (<= min 1))
- `(,done)
- `(if (>= ,i ,min)
- (return ,final)
- (return-from ,block
- (values ,value nil ,consumedp))))))
-
- ;; If we're not committing then now is the time to
- ;; check for hitting the maximum number of
- ;; repetitions.
- ,@(and max (or (not commitp)
- (not (constantp commitp)))
- `((when (and ,@(and (not (constantp max))
- `(,max))
- ,@(and commitp
- `((not ,commitp)))
- (>= ,i ,max))
- (,done))))
-
- ;; Now parse an item. If this fails and we're
- ;; committed then we've blown the whole parse. If
- ;; it fails and we've not committed then we need to
- ;; check the minimum. It's getting very tempting to
- ;; write a compiler for optimizing these
- ;; conditionals. (If we don't do this, we get
- ;; annoying warnings.)
- (multiple-value-bind (,value ,win ,cp)
- (parse ,parser)
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(cond ((and (constantp commitp) commitp)
- `(return-from ,block
- (values ,value nil ,consumedp)))
- ((not commitp)
- (if (and (numberp min) (<= min 1))
- `(,done)
- `(if (>= ,i ,min)
- (,done)
- (return-from ,block
- (values ,value nil
- ,consumedp)))))
- ((and (numberp min) (<= min 1))
- `(if ,commitp
- (return-from ,block
- (values ,value nil ,consumedp))
- (,done)))
- (t
- `(if (or ,commitp (< ,i ,min))
- (return-from ,block
- (values ,value nil ,consumedp))
- (,done)))))
- ,@(and acc `((,up ,value)))))
-
- ;; No separator. Just parse the value. If it fails,
- ;; check that we've met the minimum.
- `((multiple-value-bind (,value ,win ,cp)
- (parse ,parser)
- ,@(and (eql min 0) (null acc)
- `((declare (ignore ,value))))
- (when ,cp (setf ,consumedp t))
- (unless ,win
- ,(if (eql min 0)
- `(,done)
- `(if (>= ,i ,min)
- (,done)
- (return-from ,block
- (values ,value nil ,consumedp)))))
- ,@(and acc `((,up ,value))))))
-
- ;; Done. Update the counter and go round again.
- ,@(and counterp `((incf ,i)))))))))))
\ No newline at end of file
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Error types and handling utilities
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Enclosing conditions.
-
-(define-condition enclosing-condition (condition)
- ((enclosed-condition :initarg :condition :type condition
- :reader enclosed-condition))
- (:documentation
- "A condition which encloses another condition
-
- This is useful if one wants to attach additional information to an
- existing condition. The enclosed condition can be obtained using the
- ENCLOSED-CONDITION function.")
- (:report (lambda (condition stream)
- (princ (enclosed-condition condition) stream))))
-
-;;;--------------------------------------------------------------------------
-;;; Conditions with location information.
-
-(define-condition condition-with-location (condition)
- ((location :initarg :location :reader file-location :type file-location))
- (:documentation
- "A condition which has some location information attached."))
-
-(define-condition enclosing-condition-with-location
- (condition-with-location enclosing-condition)
- ())
-
-(define-condition error-with-location (condition-with-location error)
- ())
-
-(define-condition warning-with-location (condition-with-location warning)
- ())
-
-(define-condition enclosing-error-with-location
- (enclosing-condition-with-location error)
- ())
-
-(define-condition enclosing-warning-with-location
- (enclosing-condition-with-location warning)
- ())
-
-(define-condition simple-condition-with-location
- (condition-with-location simple-condition)
- ())
-
-(define-condition simple-error-with-location
- (error-with-location simple-error)
- ())
-
-(define-condition simple-warning-with-location
- (warning-with-location simple-warning)
- ())
-
-;;;--------------------------------------------------------------------------
-;;; Error reporting functions.
-
-(defun make-condition-with-location (default-type floc datum &rest arguments)
- "Construct a CONDITION-WITH-LOCATION given a condition designator.
-
- The returned condition will always be a CONDITION-WITH-LOCATION. The
- process consists of two stages. In the first stage, a condition is
- constructed from the condition designator DATUM and ARGUMENTS with default
- type DEFAULT-TYPE (a symbol). The precise behaviour depends on DATUM:
-
- * If DATUM is a condition, then it is used as-is; ARGUMENTS should be an
- empty list.
-
- * If DATUM is a symbol, then it must name a condition type. An instance
- of this class is constructed using ARGUMENTS as initargs, i.e., as
- if (apply #'make-condition ARGUMENTS); if the type is a subtype of
- CONDITION-WITH-LOCATION then FLOC is attached as the location.
-
- * If DATUM is a format control (i.e., a string or function), then the
- condition is constructed as if, instead, DEFAULT-TYPE had been
- supplied as DATUM, and the list (:format-control DATUM
- :format-arguments ARGUMENTS) supplied as ARGUMENTS.
-
- In the second stage, the condition constructed by the first stage is
- converted into a CONDITION-WITH-LOCATION. If the condition already has
- type CONDITION-WITH-LOCATION then it is returned as is. Otherwise it is
- wrapped in an appropriate subtype of ENCLOSING-CONDITION-WITH-LOCATION:
- if the condition was a subtype of ERROR or WARNING then the resulting
- condition will also be subtype of ERROR or WARNING as appropriate."
-
- (labels ((wrap (condition)
- (make-condition
- (etypecase condition
- (error 'enclosing-error-with-location)
- (warning 'enclosing-warning-with-location)
- (condition 'enclosing-condition-with-location))
- :condition condition
- :location (file-location floc)))
- (make (type &rest initargs)
- (if (subtypep type 'condition-with-location)
- (apply #'make-condition type
- :location (file-location floc)
- initargs)
- (wrap (apply #'make-condition type initargs)))))
- (etypecase datum
- (condition-with-location datum)
- (condition (wrap datum))
- (symbol (apply #'make arguments))
- ((or string function) (make default-type
- :format-control datum
- :format-arguments arguments)))))
-
-(defun error-with-location (floc datum &rest arguments)
- "Report an error with attached location information."
- (error (apply #'make-condition-with-location
- 'simple-error-with-location
- floc datum arguments)))
-
-(defun warn-with-location (floc datum &rest arguments)
- "Report a warning with attached location information."
- (warn (apply #'make-condition-with-location
- 'simple-warning-with-location
- floc datum arguments)))
-
-(defun cerror-with-location (floc continue-string datum &rest arguments)
- "Report a continuable error with attached location information."
- (cerror continue-string
- (apply #'make-condition-with-location
- 'simple-error-with-location
- floc datum arguments)))
-
-(defun cerror* (datum &rest arguments)
- (apply #'cerror "Continue" datum arguments))
-
-(defun cerror*-with-location (floc datum &rest arguments)
- (apply #'cerror-with-location floc "Continue" datum arguments))
-
-(defun count-and-report-errors* (thunk)
- "Invoke THUNK in a dynamic environment which traps and reports errors.
-
- See the COUNT-AND-REPORT-ERRORS macro for more detais."
-
- (let ((errors 0)
- (warnings 0))
- (handler-bind
- ((error (lambda (error)
- (let ((fatal (not (find-restart 'continue error))))
- (format *error-output* "~&~A: ~:[~;Fatal error: ~]~A~%"
- (file-location error)
- fatal
- error)
- (incf errors)
- (if fatal
- (return-from count-and-report-errors*
- (values nil errors warnings))
- (invoke-restart 'continue)))))
- (warning (lambda (warning)
- (format *error-output* "~&~A: Warning: ~A~%"
- (file-location warning)
- warning)
- (incf warnings)
- (invoke-restart 'muffle-warning))))
- (values (funcall thunk)
- errors
- warnings))))
-
-(defmacro count-and-report-errors (() &body body)
- "Evaluate BODY in a dynamic environment which traps and reports errors.
-
- The BODY is evaluated. If an error or warning is signalled, it is
- reported (using its report function), and counted. Warnings are otherwise
- muffled; continuable errors (i.e., when a CONTINUE restart is defined) are
- continued; non-continuable errors cause an immediate exit from the BODY.
-
- The final value consists of three values: the primary value of the BODY
- (or NIL if a non-continuable error occurred), the number of errors
- reported, and the number of warnings reported."
- `(count-and-report-errors* (lambda () ,@body)))
-
-(defun with-default-error-location* (floc thunk)
- "Invoke THUNK in a dynamic environment which attaches FLOC to errors (and
- other conditions) which do not have file location information attached to
- them already.
-
- See the WITH-DEFAULT-ERROR-LOCATION macro for more details."
-
- (if floc
- (handler-bind
- ((condition-with-location (lambda (condition)
- (declare (ignore condition))
- :decline))
- (condition (lambda (condition)
- (signal (make-condition-with-location nil
- floc
- condition)))))
- (funcall thunk))
- (funcall thunk)))
-
-(defmacro with-default-error-location ((floc) &body body)
- "Evaluate BODY in a dynamic environment which attaches FLOC to errors (and
- other conditions) which do not have file location information attached to
- them already.
-
- If a condition other than a CONDITION-WITH-LOCATION is signalled during
- the evaluation of the BODY, then an instance of an appropriate subtype of
- ENCLOSING-CONDITION-WITH-LOCATION is constructed, enclosing the original
- condition, and signalled. If the original condition was a subtype of
- ERROR or WARNING, then the new condition will also be a subtype of ERROR
- or WARNING as appropriate.
-
- The FLOC argument is coerced to a FILE-LOCATION object each time a
- condition is signalled. For example, if FLOC is a lexical analyser object
- which reports its current position in response to FILE-LOCATION, then each
- condition will be reported as arising at the lexer's current position at
- that time, rather than all being reported at the same position.
-
- If the new enclosing condition is not handled, the handler established by
- this macro will decline to handle the original condition. Typically,
- however, the new condition will be handled by COUNT-AND-REPORT-ERRORS."
- `(with-default-error-location* ,floc (lambda () ,@body)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-(set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
-
-(defparameter *chimaera-module*
- (define-module ("chimaera.sod")
-
- (define-fragment (:c :includes) #{
- #include "chimaera.h"
- })
-
- (define-fragment (:h :includes) #{
- #include "sod.h"
- })
-
- (define-sod-class "Animal" ("SodObject")
- :nick 'nml
- :link '|SodObject|
- (slot "tickles" int)
- (instance-initializer "nml" "tickles" :single #{ 0 })
- (message "tickle" (fun void))
- (method "nml" "tickle" (fun void) #{
- me->tickles++;
- }
- :role :before)
- (method "nml" "tickle" (fun void) #{ }))
-
- (define-sod-class "Lion" ("Animal")
- :nick 'lion
- :link '|Animal|
- (message "bite" (fun void))
- (method "lion" "bite" (fun void) #{
- puts("Munch!");
- })
- (method "nml" "tickle" (fun void) #{
- me->_vt->lion.bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Goat" ("Animal")
- :nick 'goat
- (message "butt" (fun void))
- (method "goat" "butt" (fun void) #{
- puts("Whack!");
- })
- (method "nml" "tickle" (fun void) #{
- me->_vt->goat.bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Serpent" ("Animal")
- :nick 'serpent
- (message "bite" (fun void))
- (method "serpent" "bite" (fun void) #{
- puts("Nom!");
- })
- (message "hiss" (fun void))
- (method "serpent" "hiss" (fun void) #{
- puts("Ssss!");
- })
- (method "nml" "tickle" (fun void) #{
- if (me->tickles < 3) me->_vt->hiss(me);
- else me->_vt->bite(me);
- CALL_NEXT_METHOD;
- }))
-
- (define-sod-class "Chimaera" ("Lion" "Goat" "Serpent")
- :nick 'sir
- :link '|Lion|)
-
- (defparameter *chimaera* (find-sod-class "Chimaera"))
- (defparameter *emeth* (find "tickle"
- (sod-class-effective-methods *chimaera*)
- :key (lambda (method)
- (sod-message-name
- (effective-method-message method)))
- :test #'string=))))
+++ /dev/null
-;;;
-(write-line "stuff's a-goin' on")
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Lexical analysis of a vaguely C-like language
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Basic lexical analyser infrastructure.
-
-;; Class definition.
-
-(defclass lexer ()
- ((stream :initarg :stream :type stream :reader lexer-stream)
- (char :initform nil :type (or character null) :reader lexer-char)
- (pushback-chars :initform nil :type list)
- (token-type :initform nil :accessor token-type)
- (token-value :initform nil :accessor token-value)
- (pushback-tokens :initform nil :type list))
- (:documentation
- "Base class for lexical analysers.
-
- The lexer reads characters from STREAM, which, for best results, wants to
- be a POSITION-AWARE-INPUT-STREAM.
-
- The lexer provides one-character lookahead by default: the current
- lookahead character is available to subclasses in the slot CHAR. Before
- beginning lexical analysis, the lookahead character needs to be
- established with NEXT-CHAR. If one-character lookahead is insufficient,
- the analyser can push back an arbitrary number of characters using
- PUSHBACK-CHAR.
-
- The NEXT-TOKEN function scans and returns the next token from the STREAM,
- and makes it available as TOKEN-TYPE and TOKEN-VALUE, providing one-token
- lookahead. A parser using the lexical analyser can push back tokens using
- PUSHBACK-TOKENS.
-
- For convenience, the lexer implements a FILE-LOCATION method (delegated to
- the underlying stream)."))
-
-;; Lexer protocol.
-
-(defgeneric scan-token (lexer)
- (:documentation
- "Internal function for scanning tokens from an input stream.
-
- Implementing a method on this function is the main responsibility of LEXER
- subclasses; it is called by the user-facing NEXT-TOKEN function.
-
- The method should consume characters (using NEXT-CHAR) as necessary, and
- return two values: a token type and token value. These will be stored in
- the corresponding slots in the lexer object in order to provide the user
- with one-token lookahead."))
-
-(defgeneric next-token (lexer)
- (:documentation
- "Scan a token from an input stream.
-
- This function scans a token from an input stream. Two values are
- returned: a `token type' and a `token value'. These are opaque to the
- LEXER base class, but the intent is that the token type be significant to
- determining the syntax of the input, while the token value carries any
- additional information about the token's semantic content. The token type
- and token value are also made available for lookahead via accessors
- TOKEN-TYPE and TOKEN-NAME on the LEXER object.
-
- If tokens have been pushed back (see PUSHBACK-TOKEN) then they are
- returned one by one instead of scanning the stream.")
-
- (:method ((lexer lexer))
- (with-slots (pushback-tokens token-type token-value) lexer
- (setf (values token-type token-value)
- (if pushback-tokens
- (let ((pushback (pop pushback-tokens)))
- (values (car pushback) (cdr pushback)))
- (scan-token lexer))))))
-
-(defgeneric pushback-token (lexer token-type &optional token-value)
- (:documentation
- "Push a token back into the lexer.
-
- Make the given TOKEN-TYPE and TOKEN-VALUE be the current lookahead token.
- The previous lookahead token is pushed down, and will be made available
- agan once this new token is consumed by NEXT-TOKEN. The FILE-LOCATION is
- not affected by pushing tokens back. The TOKEN-TYPE and TOKEN-VALUE be
- anything at all: for instance, they need not be values which can actually
- be returned by NEXT-TOKEN.")
-
- (:method ((lexer lexer) new-token-type &optional new-token-value)
- (with-slots (pushback-tokens token-type token-value) lexer
- (push (cons token-type token-value) pushback-tokens)
- (setf token-type new-token-type
- token-value new-token-value))))
-
-(defgeneric next-char (lexer)
- (:documentation
- "Fetch the next character from the LEXER's input stream.
-
- Read a character from the input stream, and store it in the LEXER's CHAR
- slot. The character stored is returned. If characters have been pushed
- back then pushed-back characters are used instead of the input stream.
-
- (This function is primarily intended for the use of lexer subclasses.)")
-
- (:method ((lexer lexer))
- (with-slots (stream char pushback-chars) lexer
- (setf char (if pushback-chars
- (pop pushback-chars)
- (read-char stream nil))))))
-
-(defgeneric pushback-char (lexer char)
- (:documentation
- "Push the CHAR back into the lexer.
-
- Make CHAR be the current lookahead character (stored in the LEXER's CHAR
- slot). The previous lookahead character is pushed down, and will be made
- available again once this character is consumed by NEXT-CHAR.
-
- (This function is primarily intended for the use of lexer subclasses.)")
-
- (:method ((lexer lexer) new-char)
- (with-slots (char pushback-chars) lexer
- (push char pushback-chars)
- (setf char new-char))))
-
-(defgeneric fixup-stream* (lexer thunk)
- (:documentation
- "Helper function for WITH-LEXER-STREAM.
-
- This function does the main work for WITH-LEXER-STREAM. The THUNK is
- invoked on a single argument, the LEXER's underlying STREAM.")
-
- (:method ((lexer lexer) thunk)
- (with-slots (stream char pushback-chars) lexer
- (when pushback-chars
- (error "Lexer has pushed-back characters."))
- (unread-char char stream)
- (unwind-protect
- (funcall thunk stream)
- (setf char (read-char stream nil))))))
-
-(defmacro with-lexer-stream ((streamvar lexer) &body body)
- "Evaluate BODY with STREAMVAR bound to the LEXER's input stream.
-
- The STREAM is fixed up so that the next character read (e.g., using
- READ-CHAR) will be the lexer's current lookahead character. Once the BODY
- completes, the next character in the stream is read and set as the
- lookahead character. It is an error if the lexer has pushed-back
- characters (since these can't be pushed back into the input stream
- properly)."
-
- `(fixup-stream* ,lexer
- (lambda (,streamvar)
- ,@body)))
-
-(defmethod file-location ((lexer lexer))
- (with-slots (stream) lexer
- (file-location stream)))
-
-(defgeneric skip-spaces (lexer)
- (:documentation
- "Skip over whitespace characters in the LEXER."))
-
-;;;--------------------------------------------------------------------------
-;;; Lexer utilities.
-
-;;;--------------------------------------------------------------------------
-;;; Our main lexer.
-
-(defun make-keyword-table (&rest keywords)
- "Construct a keyword table for the lexical analyser.
-
- The KEYWORDS arguments are individual keywords, either as strings or as
- (WORD . VALUE) pairs. A string argument is equivalent to a pair listing
- the string itself as WORD and the corresponding keyword symbol (forced to
- uppercase) as the VALUE."
-
- (let ((table (make-hash-table :test #'equal)))
- (dolist (item keywords)
- (multiple-value-bind (word keyword)
- (if (consp item)
- (values (car item) (cdr item))
- (values item (intern (string-upcase item) :keyword)))
- (setf (gethash word table) keyword)))
- table))
-
-(defparameter *sod-keywords*
- (make-keyword-table
-
- ;; Words with a meaning to C's type system.
- "char" "int" "float" "void"
- "long" "short" "signed" "unsigned" "double"
- "const" "volatile" "restrict"
- "struct" "union" "enum"))
-
-(defclass sod-lexer (lexer)
- ()
- (:documentation
- "Lexical analyser for the SOD lanuage.
-
- See the LEXER class for the gory details about the lexer protocol."))
-
-(defun format-token (token-type &optional token-value)
- (when (typep token-type 'lexer)
- (let ((lexer token-type))
- (setf token-type (token-type lexer)
- token-value (token-value lexer))))
- (etypecase token-type
- ((eql :eof) "<end-of-file>")
- ((eql :string) "<string-literal>")
- ((eql :char) "<character-literal>")
- ((eql :id) (format nil "<identifier~@[ `~A'~]>" token-value))
- (keyword (format nil "`~(~A~)'" token-type))
- (character (format nil "~:[<~:C>~;`~C'~]"
- (and (graphic-char-p token-type)
- (char/= token-type #\space))
- token-type))))
-
-(defmethod scan-token ((lexer sod-lexer))
- (with-slots (stream char keywords) lexer
- (prog ((ch char))
-
- consider
- (cond
-
- ;; End-of-file brings its own peculiar joy.
- ((null ch) (return (values :eof t)))
-
- ;; Ignore whitespace and continue around for more.
- ((whitespace-char-p ch) (go scan))
-
- ;; Strings.
- ((or (char= ch #\") (char= ch #\'))
- (with-default-error-location ((file-location lexer))
- (let* ((quote ch)
- (string
- (with-output-to-string (out)
- (loop
- (flet ((getch ()
- (setf ch (next-char lexer))
- (when (null ch)
- (cerror*
- "Unexpected end of file in string/character constant")
- (return))))
- (getch)
- (cond ((char= ch quote) (return))
- ((char= ch #\\) (getch)))
- (write-char ch out))))))
- (setf ch (next-char lexer))
- (ecase quote
- (#\" (return (values :string string)))
- (#\' (case (length string)
- (0 (cerror* "Empty character constant")
- (return (values :char #\?)))
- (1 (return (values :char (char string 0))))
- (t (cerror*
- "Multiple characters in character constant")
- (return (values :char (char string 0))))))))))
-
- ;; Pick out identifiers and keywords.
- ((or (alpha-char-p ch) (char= ch #\_))
-
- ;; Scan a sequence of alphanumerics and underscores. We could
- ;; allow more interesting identifiers, but it would damage our C
- ;; lexical compatibility.
- (let ((id (with-output-to-string (out)
- (loop
- (write-char ch out)
- (setf ch (next-char lexer))
- (when (or (null ch)
- (not (or (alphanumericp ch)
- (char= ch #\_))))
- (return))))))
-
- ;; Done.
- (return (values :id id))))
-
- ;; Pick out numbers. Currently only integers, but we support
- ;; multiple bases.
- ((digit-char-p ch)
-
- ;; Sort out the prefix. If we're looking at `0b', `0o' or `0x'
- ;; (maybe uppercase) then we've got a funny radix to deal with.
- ;; Otherwise, a leading zero signifies octal (daft, I know), else
- ;; we're left with decimal.
- (multiple-value-bind (radix skip-char)
- (if (char/= ch #\0)
- (values 10 nil)
- (case (and (setf ch (next-char lexer))
- (char-downcase ch))
- (#\b (values 2 t))
- (#\o (values 8 t))
- (#\x (values 16 t))
- (t (values 8 nil))))
-
- ;; If we last munched an interesting letter, we need to skip over
- ;; it. That's what the SKIP-CHAR flag is for.
- ;;
- ;; Danger, Will Robinson! If we're' just about to eat a radix
- ;; letter, then the next thing must be a digit. For example,
- ;; `0xfatenning' parses as a hex number followed by an identifier
- ;; `0xfa ttening', but `0xturning' is an octal number followed
- ;; by an identifier `0 xturning'.
- (when skip-char
- (let ((peek (next-char lexer)))
- (unless (digit-char-p peek radix)
- (pushback-char lexer ch)
- (return-from scan-token (values :integer 0)))
- (setf ch peek)))
-
- ;; Scan an integer. While there are digits, feed them into the
- ;; accumulator.
- (do ((accum 0 (+ (* accum radix) digit))
- (digit (and ch (digit-char-p ch radix))
- (and ch (digit-char-p ch radix))))
- ((null digit) (return-from scan-token
- (values :integer accum)))
- (setf ch (next-char lexer)))))
-
- ;; A slash might be the start of a comment.
- ((char= ch #\/)
- (setf ch (next-char lexer))
- (case ch
-
- ;; Comment up to the end of the line.
- (#\/
- (loop
- (setf ch (next-char lexer))
- (when (or (null ch) (char= ch #\newline))
- (go scan))))
-
- ;; Comment up to the next `*/'.
- (#\*
- (tagbody
- top
- (case (setf ch (next-char lexer))
- (#\* (go star))
- ((nil) (go done))
- (t (go top)))
- star
- (case (setf ch (next-char lexer))
- (#\* (go star))
- (#\/ (setf ch (next-char lexer))
- (go done))
- ((nil) (go done))
- (t (go top)))
- done)
- (go consider))
-
- ;; False alarm. (The next character is already set up.)
- (t
- (return (values #\/ t)))))
-
- ;; A dot: might be `...'. Tread carefully! We need more lookahead
- ;; than is good for us.
- ((char= ch #\.)
- (setf ch (next-char lexer))
- (cond ((eql ch #\.)
- (setf ch (next-char lexer))
- (cond ((eql ch #\.) (return (values :ellpisis nil)))
- (t (pushback-char lexer #\.)
- (return (values #\. t)))))
- (t
- (return (values #\. t)))))
-
- ;; Anything else is a lone delimiter.
- (t
- (return (multiple-value-prog1
- (values ch t)
- (next-char lexer)))))
-
- scan
- ;; Scan a new character and try again.
- (setf ch (next-char lexer))
- (go consider))))
-
-;;;--------------------------------------------------------------------------
-;;; C fragments.
-
-(defun scan-c-fragment (lexer end-chars)
- "Snarfs a sequence of C tokens with balanced brackets.
-
- Reads and consumes characters from the LEXER's stream, and returns them as
- a string. The string will contain whole C tokens, up as far as an
- occurrence of one of the END-CHARS (a list) which (a) is not within a
- string or character literal or comment, and (b) appears at the outer level
- of nesting of brackets (whether round, curly or square -- again counting
- only brackets which aren't themselves within string/character literals or
- comments. The final END-CHAR is not consumed.
-
- An error is signalled if either the stream ends before an occurrence of
- one of the END-CHARS, or if mismatching brackets are encountered. No
- other attempt is made to ensure that the characters read are in fact a
- valid C fragment.
-
- Both original /*...*/ and new //... comments are recognized. Trigraphs
- and digraphs are currently not recognized."
-
- (let ((output (make-string-output-stream))
- (ch (lexer-char lexer))
- (start-floc (file-location lexer))
- (delim nil)
- (stack nil))
-
- ;; Main loop. At the top of this loop, we've already read a
- ;; character into CH. This is usually read at the end of processing
- ;; the individual character, though sometimes (following `/', for
- ;; example) it's read speculatively because we need one-character
- ;; lookahead.
- (block loop
- (labels ((getch ()
- "Read the next character into CH; complain if we hit EOF."
- (unless (setf ch (next-char lexer))
- (cerror*-with-location start-floc
- "Unexpected end-of-file in C fragment")
- (return-from loop))
- ch)
- (putch ()
- "Write the character to the output buffer."
- (write-char ch output))
- (push-delim (d)
- "Push a closing delimiter onto the stack."
- (push delim stack)
- (setf delim d)
- (getch)))
-
- ;; Hack: if the first character is a newline, discard it. Otherwise
- ;; (a) the output fragment will look funny, and (b) the location
- ;; information will be wrong.
- (when (eql ch #\newline)
- (getch))
-
- ;; And fetch characters.
- (loop
-
- ;; Here we're outside any string or character literal, though we
- ;; may be nested within brackets. So, if there's no delimiter, and
- ;; we've found the end character, we're done.
- (when (and (null delim) (member ch end-chars))
- (return))
-
- ;; Otherwise take a copy of the character, and work out what to do
- ;; next.
- (putch)
- (case ch
-
- ;; Starting a literal. Continue until we find a matching
- ;; character not preceded by a `\'.
- ((#\" #\')
- (let ((quote ch))
- (loop
- (getch)
- (putch)
- (when (eql ch quote)
- (return))
- (when (eql ch #\\)
- (getch)
- (putch)))
- (getch)))
-
- ;; Various kinds of opening bracket. Stash the current
- ;; delimiter, and note that we're looking for a new one.
- (#\( (push-delim #\)))
- (#\[ (push-delim #\]))
- (#\{ (push-delim #\}))
-
- ;; Various kinds of closing bracket. If it matches the current
- ;; delimeter then unstack the next one along. Otherwise
- ;; something's gone wrong: C syntax doesn't allow unmatched
- ;; brackets.
- ((#\) #\] #\})
- (if (eql ch delim)
- (setf delim (pop stack))
- (cerror* "Unmatched `~C'." ch))
- (getch))
-
- ;; A slash. Maybe a comment next. But maybe not...
- (#\/
-
- ;; Examine the next character to find out how to proceed.
- (getch)
- (case ch
-
- ;; A second slash -- eat until the end of the line.
- (#\/
- (putch)
- (loop
- (getch)
- (putch)
- (when (eql ch #\newline)
- (return)))
- (getch))
-
- ;; A star -- eat until we find a star-slash. Since the star
- ;; might be preceded by another star, we use a little state
- ;; machine.
- (#\*
- (putch)
- (tagbody
-
- main
- ;; Main state. If we read a star, switch to star state;
- ;; otherwise eat the character and try again.
- (getch)
- (putch)
- (case ch
- (#\* (go star))
- (t (go main)))
-
- star
- ;; Star state. If we read a slash, we're done; if we read
- ;; another star, stay in star state; otherwise go back to
- ;; main.
- (getch)
- (putch)
- (case ch
- (#\* (go star))
- (#\/ (go done))
- (t (go main)))
-
- done
- (getch)))))
-
- ;; Something else. Eat it and continue.
- (t (getch)))))
-
- (let* ((string (get-output-stream-string output))
- (end (position-if (lambda (char)
- (or (char= char #\newline)
- (not (whitespace-char-p char))))
- string
- :from-end t))
- (trimmed (if end
- (subseq string 0 (1+ end))
- "")))
-
- ;; Return the fragment we've collected.
- (make-instance 'c-fragment
- :location start-floc
- :text trimmed)))))
-
-(defun c-fragment-reader (stream char arg)
- "Reader for C-fragment syntax #{ ... stuff ... }."
- (declare (ignore char arg))
- (let ((lexer (make-instance 'sod-lexer
- :stream stream)))
- (next-char lexer)
- (scan-c-fragment lexer '(#\}))))
-
-#+interactive
-(set-dispatch-macro-character #\# #\{ 'c-fragment-reader)
-
-;;;--------------------------------------------------------------------------
-;;; Testing cruft.
-
-#+test
-(with-input-from-string (in "
-{ foo } 'x' /?/***/!
-123 0432 0b010123 0xc0ffee __burp_32 class
-
-0xturning 0xfattening
-...
-
-class integer : integral_domain {
- something here;
-}
-
-")
- (let* ((stream (make-instance 'position-aware-input-stream
- :stream in
- :file #p"magic"))
- (lexer (make-instance 'sod-lexer
- :stream stream
- :keywords *sod-keywords*))
- (list nil))
- (next-char lexer)
- (loop
- (multiple-value-bind (tokty tokval) (next-token lexer)
- (push (list tokty tokval) list)
- (when (eql tokty :eof)
- (return))))
- (nreverse list)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Infrastructure for effective method generation
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Direct method classes.
-
-;;;--------------------------------------------------------------------------
-;;; Effective method classes.
-
-;;;--------------------------------------------------------------------------
-;;; Code generation.
-
-;;;--------------------------------------------------------------------------
-;;; Effective method entry points.
-
-;;;--------------------------------------------------------------------------
-;;; Output.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Output handling for modules
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-;;;--------------------------------------------------------------------------
-;;; Main output protocol implementation.
-
-;;;--------------------------------------------------------------------------
-;;; Header output.
-
-;;;--------------------------------------------------------------------------
-;;; Source output.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Modules and module parser
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Module importing.
-
-(defun read-module (pathname &key (truename (truename pathname)) location)
- "Reads a module.
-
- The module is returned if all went well; nil is returned if an error
- occurred.
-
- The PATHNAME argument is the file to read. TRUENAME should be the file's
- truename, if known: often, the file will have been searched for using
- `probe-file' or similar, which drops the truename into your lap."
-
- ;; Deal with a module which is already in the map. If its state is a
- ;; FILE-LOCATION then it's in progress and we have a cyclic dependency.
- (let ((module (gethash truename *module-map*)))
- (cond ((null module))
- ((typep (module-state module) 'file-location)
- (error "Module ~A already being imported at ~A"
- pathname (module-state module)))
- (module
- (return-from read-module module))))
-
- ;; Make a new module. Be careful to remove the module from the map if we
- ;; didn't succeed in constructing it.
- (define-module (pathname :location location :truename truename)
- (let ((*readtable* (copy-readtable)))
- (with-open-file (f-stream pathname :direction :input)
- (let* ((pai-stream (make-instance 'position-aware-input-stream
- :stream f-stream
- :file pathname))
- (lexer (make-instance 'sod-lexer :stream pai-stream)))
- (with-default-error-location (lexer)
- (next-char lexer)
- (next-token lexer)
- (parse-module lexer)))))))
-
-;;;--------------------------------------------------------------------------
-;;; Module parsing protocol.
-
-(defgeneric parse-module-declaration (tag lexer pset)
- (:method (tag lexer pset)
- (error "Unexpected module declaration ~(~A~)" tag))
- (:method :before (tag lexer pset)
- (next-token lexer)))
-
-(defun parse-module (lexer)
- "Main dispatching for module parser.
-
- Calls PARSE-MODULE-DECLARATION for the identifiable declarations."
-
- (loop
- (restart-case
- (case (token-type lexer)
- (:eof (return))
- (#\; (next-token lexer))
- (t (let ((pset (parse-property-set lexer)))
- (case (token-type lexer)
- (:id (let ((tag (intern (frob-case (token-value lexer))
- :keyword)))
- (parse-module-declaration tag lexer pset)
- (check-unused-properties pset)))
- (t (error "Unexpected token ~A: ignoring"
- (format-token lexer)))))))
- (continue ()
- :report "Ignore the error and continue parsing."
- nil))))
-
-(defmethod parse-module-declaration ((tag (eql :typename)) lexer pset)
- "module-decl ::= `typename' id-list `;'"
- (loop (let ((name (require-token lexer :id)))
- (unless name (return))
- (if (gethash name *type-map*)
- (cerror* "Type `~A' already defined" name)
- (add-to-module *module* (make-instance 'type-item :name name)))
- (unless (require-token lexer #\, :errorp nil) (return))))
- (require-token lexer #\;))
-
-;;;--------------------------------------------------------------------------
-;;; Fragments.
-
-(defmethod parse-module-declaration ((tag (eql :code)) lexer pset)
- "module-decl ::= `code' id `:' id [constraint-list] `{' c-fragment `}'
- constraint ::= id*"
- (labels ((parse-constraint ()
- (let ((list nil))
- (loop (let ((id (require-token lexer :id
- :errorp (null list))))
- (unless id (return))
- (push id list)))
- (nreverse list)))
- (parse-constraints ()
- (let ((list nil))
- (when (require-token lexer #\[ :errorp nil)
- (loop (let ((constraint (parse-constraint)))
- (push constraint list)
- (unless (require-token lexer #\, :errorp nil)
- (return))))
- (require-token lexer #\]))
- (nreverse list)))
- (keywordify (id)
- (and id (intern (substitute #\- #\_ (frob-case id)) :keyword))))
- (let* ((reason (prog1 (keywordify (require-token lexer :id))
- (require-token lexer #\:)))
- (name (keywordify (require-token lexer :id)))
- (constraints (parse-constraints)))
- (when (require-token lexer #\{ :consumep nil)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (add-to-module *module*
- (make-instance 'code-fragment-item
- :name name
- :reason reason
- :constraints constraints
- :fragment frag)))))))
-
-;;;--------------------------------------------------------------------------
-;;; File searching.
-
-
-(defmethod parse-module-declaration ((tag (eql :import)) lexer pset)
- "module-decl ::= `import' string `;'"
- (let ((name (require-token lexer :string)))
- (when name
- (find-file lexer
- (merge-pathnames name
- (make-pathname :type "SOD" :case :common))
- "module"
- (lambda (path true)
- (handler-case
- (let ((module (read-module path :truename true)))
- (when module
- (module-import module)
- (pushnew module (module-dependencies *module*))))
- (file-error (error)
- (cerror* "Error reading module ~S: ~A"
- path error)))))
- (require-token lexer #\;))))
-
-(defmethod parse-module-declaration ((tag (eql :load)) lexer pset)
- "module-decl ::= `load' string `;'"
- (let ((name (require-token lexer :string)))
- (when name
- (find-file lexer
- (merge-pathnames name
- (make-pathname :type "LISP" :case :common))
- "Lisp file"
- (lambda (path true)
- (handler-case (load true :verbose nil :print nil)
- (error (error)
- (cerror* "Error loading Lisp file ~S: ~A"
- path error)))))
- (require-token lexer #\;))))
-
-;;;--------------------------------------------------------------------------
-;;; Lisp escapes.
-
-(defmethod parse-module-declaration :around ((tag (eql :lisp)) lexer pset)
- "module-decl ::= `lisp' s-expression `;'"
- (let ((form (with-lexer-stream (stream lexer) (read stream t))))
- (eval form))
- (next-token lexer)
- (require-token lexer #\;))
-
-;;;--------------------------------------------------------------------------
-;;; Class declarations.
-
-(defmethod parse-module-declaration ((tag (eql :class)) lexer pset)
- "module-decl ::= `class' id [`:' id-list] `{' class-item* `}'"
- (let* ((location (file-location lexer))
- (name (let ((name (require-token lexer :id)))
- (make-class-type name location)
- (when (require-token lexer #\; :errorp nil)
- (return-from parse-module-declaration))
- name))
- (supers (when (require-token lexer #\: :errorp nil)
- (let ((list nil))
- (loop (let ((id (require-token lexer :id)))
- (unless id (return))
- (push id list)
- (unless (require-token lexer #\, :errorp nil)
- (return))))
- (nreverse list))))
- (class (make-sod-class name (mapcar #'find-sod-class supers)
- pset location))
- (nick (sod-class-nickname class)))
- (require-token lexer #\{)
-
- (labels ((parse-item ()
- "Try to work out what kind of item this is. Messy."
- (let* ((pset (parse-property-set lexer))
- (location (file-location lexer)))
- (cond ((declaration-specifier-p lexer)
- (let ((declspec (parse-c-type lexer)))
- (multiple-value-bind (type name)
- (parse-c-declarator lexer declspec :dottedp t)
- (cond ((null type)
- nil)
- ((consp name)
- (parse-method type (car name) (cdr name)
- pset location))
- ((typep type 'c-function-type)
- (parse-message type name pset location))
- (t
- (parse-slots declspec type name
- pset location))))))
- ((not (eq (token-type lexer) :id))
- (cerror* "Expected <class-item>; found ~A (skipped)"
- (format-token lexer))
- (next-token lexer))
- ((string= (token-value lexer) "class")
- (next-token lexer)
- (parse-initializers #'make-sod-class-initializer
- pset location))
- (t
- (parse-initializers #'make-sod-instance-initializer
- pset location)))))
-
- (parse-method (type nick name pset location)
- "class-item ::= declspec+ dotted-declarator -!- method-body
-
- method-body ::= `{' c-fragment `}' | `extern' `;'
-
- The dotted-declarator must describe a function type."
- (let ((body (cond ((eq (token-type lexer) #\{)
- (prog1 (scan-c-fragment lexer '(#\}))
- (next-token lexer)
- (require-token lexer #\})))
- ((and (eq (token-type lexer) :id)
- (string= (token-value lexer)
- "extern"))
- (next-token lexer)
- (require-token lexer #\;)
- nil)
- (t
- (cerror* "Expected <method-body>; ~
- found ~A"
- (format-token lexer))))))
- (make-sod-method class nick name type body pset location)))
-
- (parse-message (type name pset location)
- "class-item ::= declspec+ declarator -!- (method-body | `;')
-
- The declarator must describe a function type."
- (make-sod-message class name type pset location)
- (unless (require-token lexer #\; :errorp nil)
- (parse-method type nick name nil location)))
-
- (parse-initializer-body ()
- "initializer ::= `=' `{' c-fragment `}' | `=' c-fragment"
- (let ((char (lexer-char lexer)))
- (loop
- (when (or (null char) (not (whitespace-char-p char)))
- (return))
- (setf char (next-char lexer)))
- (cond ((eql char #\{)
- (next-char lexer)
- (let ((frag (scan-c-fragment lexer '(#\}))))
- (next-token lexer)
- (require-token lexer #\})
- (values :compound frag)))
- (t
- (let ((frag (scan-c-fragment lexer '(#\, #\;))))
- (next-token lexer)
- (values :simple frag))))))
-
- (parse-slots (declspec type name pset location)
- "class-item ::=
- declspec+ init-declarator [`,' init-declarator-list] `;'
-
- init-declarator ::= declarator -!- [initializer]"
- (loop
- (make-sod-slot class name type pset location)
- (when (eql (token-type lexer) #\=)
- (multiple-value-bind (kind form) (parse-initializer-body)
- (make-sod-instance-initializer class nick name
- kind form nil
- location)))
- (unless (require-token lexer #\, :errorp nil)
- (return))
- (setf (values type name)
- (parse-c-declarator lexer declspec)
- location (file-location lexer)))
- (require-token lexer #\;))
-
- (parse-initializers (constructor pset location)
- "class-item ::= [`class'] -!- slot-initializer-list `;'
-
- slot-initializer ::= id `.' id initializer"
- (loop
- (let ((nick (prog1 (require-token lexer :id)
- (require-token lexer #\.)))
- (name (require-token lexer :id)))
- (require-token lexer #\=)
- (multiple-value-bind (kind form)
- (parse-initializer-body)
- (funcall constructor class nick name kind form
- pset location)))
- (unless (require-token lexer #\, :errorp nil)
- (return))
- (setf location (file-location lexer)))
- (require-token lexer #\;)))
-
- (loop
- (when (require-token lexer #\} :errorp nil)
- (return))
- (parse-item)))
-
- (finalize-sod-class class)
- (add-to-module *module* class)))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Output driver for SOD translator
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Sequencing machinery.
-
-(defclass sequencer-item ()
- ((name :initarg :name :reader sequencer-item-name)
- (functions :initarg :functions :initform nil
- :type list :accessor sequencer-item-functions))
- (:documentation
- "Represents a distinct item to be sequenced by a SEQUENCER.
-
- A SEQUENCER-ITEM maintains a list of FUNCTIONS which are invoked when the
- sequencer is invoked. This class is not intended to be subclassed."))
-
-;;;--------------------------------------------------------------------------
-;;; Output preparation.
-
-(defvar *seen-announcement*) ;Keep me unbound!
-#+hmm
-(defmethod add-output-hooks :around (object reason sequencer &rest stuff)
- "Arrange not to invoke any object more than once during a particular
- announcement."
- (declare (ignore stuff))
- (cond ((not (boundp '*seen-announcement*))
- (let ((*seen-announcement* (make-hash-table)))
- (setf (gethash object *seen-announcement*) t)
- (call-next-method)))
- ((gethash object *seen-announcement*)
- nil)
- (t
- (setf (gethash object *seen-announcement*) t)
- (call-next-method))))
-
-;;;--------------------------------------------------------------------------
-;;; Utility macro.
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Parser for C types
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Declaration specifiers.
-;;;
-;;; This is a little messy. The C rules, which we're largely following,
-;;; allow declaration specifiers to be written in any oreder, and allows an
-;;; arbitrary number of the things. This is mainly an exercise in
-;;; book-keeping, but we make an effort to categorize the various kinds of
-;;; specifiers rather better than the C standard.
-;;;
-;;; We consider four kinds of declaration specifiers:
-;;;
-;;; * Type qualifiers: `const', `restrict', and `volatile'.
-;;; * Sign specifiers: `signed' and `unsigned'.
-;;; * Size specifiers: `short' and `long'.
-;;; * Type specifiers: `void', `char', `int', `float', and `double',
-;;;
-;;; The C standard acknowledges the category of type qualifiers (6.7.3), but
-;;; groups the other three kinds together and calls them all `type
-;;; specifiers' (6.7.2).
-
-;; Let's not repeat ourselves.
-(macrolet ((define-declaration-specifiers (&rest defs)
- (let ((mappings nil)
- (deftypes nil)
- (hashvar (gensym "HASH"))
- (keyvar (gensym "KEY"))
- (valvar (gensym "VAL")))
- (dolist (def defs)
- (destructuring-bind (kind &rest clauses) def
- (let ((maps (mapcar (lambda (clause)
- (if (consp clause)
- clause
- (cons (string-downcase clause)
- clause)))
- clauses)))
- (push `(deftype ,(symbolicate 'decl- kind) ()
- '(member ,@(mapcar #'cdr maps)))
- deftypes)
- (setf mappings (nconc (remove-if-not #'car maps)
- mappings)))))
- `(progn
- ,@(nreverse deftypes)
- (defparameter *declspec-map*
- (let ((,hashvar (make-hash-table :test #'equal)))
- (mapc (lambda (,keyvar ,valvar)
- (setf (gethash ,keyvar ,hashvar) ,valvar))
- ',(mapcar #'car mappings)
- ',(mapcar #'cdr mappings))
- ,hashvar))))))
- (define-declaration-specifiers
- (type :char :int :float :double :void)
- (size :short :long (nil . :long-long))
- (sign :signed :unsigned)
- (qualifier :const :restrict :volatile)
- (tagged :enum :struct :union)))
-
-(defstruct (declspec
- (:predicate declspecp))
- "Represents a declaration specifier being built."
- (qualifiers nil :type list)
- (sign nil :type (or decl-sign null))
- (size nil :type (or decl-size null))
- (type nil :type (or decl-type c-type null)))
-
-(defun check-declspec (spec)
- "Check that the declaration specifiers in SPEC are a valid combination.
-
- This is surprisingly hairy.
-
- It could be even worse: at least validity is monotonic. Consider an
- alternate language where `double' is a size specifier like `long' rather
- than being a primary type specifier like `float' (so you'd be able to say
- things like `long double float'). Then `long float' would be invalid, but
- `long float double' would be OK. We'd therefore need an additional
- argument to know whether we were preparing a final set of specifiers (in
- which case we'd have to reject `long float') or whether this is an
- intermediate step (in which case we'd have to tentatively allow it in the
- hope that the user added the necessary `double' later)."
-
- (let ((sign (declspec-sign spec))
- (size (declspec-size spec))
- (type (declspec-type spec)))
-
- (and (loop for (good-type good-signs good-sizes) in
-
- ;; The entries in this table have the form (GOOD-TYPE
- ;; GOOD-SIGNS GOOD-SIZES). The GOOD-TYPE is either a keyword
- ;; or T (matches anything); the GOOD-SIZES and GOOD-SIGNS are
- ;; lists. The SPEC must match at least one entry, as follows:
- ;; the type must be NIL or match GOOD-TYPE; and the size and
- ;; sign must match one of the elements of the corresponding
- ;; GOOD list.
- '((:int (nil :signed :unsigned) (nil :short :long :long-long))
- (:char (nil :signed :unsigned) (nil))
- (:double (nil) (nil :long))
- (t (nil) (nil)))
-
- thereis (and (or (eq type nil)
- (eq good-type t)
- (eq type good-type))
- (member sign good-signs)
- (member size good-sizes)))
- spec)))
-
-(defun update-declspec-qualifiers (spec qual)
- "Update the qualifiers in SPEC by adding QUAL.
-
- The new declspec is returned if it's valid; otherwise NIL. SPEC is not
- modified."
-
- (let ((new (copy-declspec spec)))
- (pushnew qual (declspec-qualifiers new))
- (check-declspec new)))
-
-(defun update-declspec-sign (spec sign)
- "Update the signedness in SPEC to be SIGN.
-
- The new declspec is returned if it's valid; otherwise NIL. SPEC is not
- modified."
-
- (and (null (declspec-sign spec))
- (let ((new (copy-declspec spec)))
- (setf (declspec-sign new) sign)
- (check-declspec new))))
-
-(defun update-declspec-size (spec size)
- "Update the size in SPEC according to SIZE.
-
- The new declspec is returned if it's valid; otherwise NIL. (This is a
- little subtle because :LONG in particular can modify an existing size
- entry.) SPEC is not modified."
-
- (let ((new-size (case (declspec-size spec)
- ((nil) size)
- (:long (if (eq size :long) :long-long nil)))))
- (and new-size
- (let ((new (copy-declspec spec)))
- (setf (declspec-size new) new-size)
- (check-declspec new)))))
-
-(defun update-declspec-type (spec type)
- "Update the type in SPEC to be TYPE.
-
- The new declspec is returned if it's valid; otherwise NIL. SPEC is not
- modified."
-
- (and (null (declspec-type spec))
- (let ((new (copy-declspec spec)))
- (setf (declspec-type new) type)
- (check-declspec new))))
-
-(defun canonify-declspec (spec)
- "Transform the declaration specifiers SPEC into a canonical form.
-
- The idea is that, however grim the SPEC, we can turn it into something
- vaguely idiomatic, and pick precisely one of the possible synonyms.
-
- The rules are that we suppress `signed' when it's redundant, and suppress
- `int' if a size or signedness specifier is present. (Note that `signed
- char' is not the same as `char', so stripping `signed' is only correct
- when the type is `int'.)
-
- The qualifiers are sorted and uniquified here; the relative ordering of
- the sign/size/type specifiers will be determined by DECLSPEC-KEYWORDS."
-
- (let ((quals (declspec-qualifiers spec))
- (sign (declspec-sign spec))
- (size (declspec-size spec))
- (type (declspec-type spec)))
- (cond ((eq type :int)
- (when (eq sign :signed)
- (setf (declspec-sign spec) nil))
- (when (or sign size)
- (setf (declspec-type spec) nil)))
- ((not (or sign size type))
- (setf (declspec-type spec) :int)))
- (setf (declspec-qualifiers spec)
- (delete-duplicates (sort (copy-list quals) #'string<)))
- spec))
-
-(defun declspec-keywords (spec &optional qualsp)
- "Return a list of strings for the declaration specifiers SPEC.
-
- If QUALSP then return the type qualifiers as well."
-
- (let ((quals (declspec-qualifiers spec))
- (sign (declspec-sign spec))
- (size (declspec-size spec))
- (type (declspec-type spec)))
- (nconc (and qualsp (mapcar #'string-downcase quals))
- (and sign (list (string-downcase sign)))
- (case size
- ((nil) nil)
- (:long-long (list "long long"))
- (t (list (string-downcase size))))
- (etypecase type
- (null nil)
- (keyword (list (string-downcase type)))
- (simple-c-type (list (c-type-name type)))
- (tagged-c-type (list (string-downcase (c-tagged-type-kind type))
- (c-type-tag type)))))))
-
-(defun declspec-c-type (spec)
- "Return a C-TYPE object corresponding to SPEC."
- (canonify-declspec spec)
- (let* ((type (declspec-type spec))
- (base (etypecase type
- (symbol (make-simple-type
- (format nil "~{~A~^ ~}"
- (declspec-keywords spec))))
- (c-type type))))
- (qualify-type base (declspec-qualifiers spec))))
-
-(defun declaration-specifier-p (lexer)
- "Answer whether the current token might be a declaration specifier."
- (and (eq (token-type lexer) :id)
- (let ((id (token-value lexer)))
- (or (gethash id *declspec-map*)
- (gethash id *type-map*)))))
-
-(defun parse-c-type (lexer)
- "Parse declaration specifiers from LEXER and return a C-TYPE."
-
- (let ((spec (make-declspec))
- (found-any nil)
- tok)
- (flet ((token (&optional (ty (next-token lexer)))
- (setf tok
- (or (and (eq ty :id)
- (gethash (token-value lexer) *declspec-map*))
- ty)))
- (update (func value)
- (let ((new (funcall func spec value)))
- (cond (new (setf spec new))
- (t (cerror* "Invalid declaration specifier ~(~A~) ~
- following `~{~A~^ ~}' (ignored)"
- (format-token tok (token-value lexer))
- (declspec-keywords spec t))
- nil)))))
- (token (token-type lexer))
- (loop
- (typecase tok
- (decl-qualifier (update #'update-declspec-qualifiers tok))
- (decl-sign (when (update #'update-declspec-sign tok)
- (setf found-any t)))
- (decl-size (when (update #'update-declspec-size tok)
- (setf found-any t)))
- (decl-type (when (update #'update-declspec-type tok)
- (setf found-any t)))
- (decl-tagged (let ((class (ecase tok
- (:enum 'c-enum-type)
- (:struct 'c-struct-type)
- (:union 'c-union-type))))
- (let ((tag (require-token lexer :id)))
- (when tag
- (update #'update-declspec-type
- (make-instance class :tag tag))))))
- ((eql :id) (let ((ty (gethash (token-value lexer) *type-map*)))
- (when (or found-any (not ty))
- (return))
- (when (update #'update-declspec-type ty)
- (setf found-any t))))
- (t (return)))
- (token))
- (unless found-any
- (cerror* "Missing type name (guessing at `int')"))
- (declspec-c-type spec))))
-
-;;;--------------------------------------------------------------------------
-;;; Parsing declarators.
-;;;
-;;; This is a whole different ball game. The syntax is simple enough, but
-;;; the semantics is inside-out in a particularly unpleasant way.
-;;;
-;;; The basic idea is that declarator operators closer to the identifier (or
-;;; where the identifier would be) should be applied last (with postfix
-;;; operators being considered `closer' than prefix).
-;;;
-;;; One might thing that we can process prefix operators immediately. For
-;;; outer prefix operators, this is indeed correct, but in `int (*id)[]', for
-;;; example, we must wait to process the array before applying the pointer.
-;;;
-;;; We can translate each declarator operator into a function which, given a
-;;; type, returns the appropriate derived type. If we can arrange these
-;;; functions in the right order during the parse, we have only to compose
-;;; them together and apply them to the base type in order to finish the job.
-;;;
-;;; Consider the following skeletal declarator, with <> as a parenthesized
-;;; subdeclarator within.
-;;;
-;;; * * <> [] [] ---> a b d c z
-;;; a b z c d
-;;;
-;;; The algorithm is therefore as follows. We first read the prefix
-;;; operators, translate them into closures, and push them onto a list. Each
-;;; parenthesized subdeclarator gets its own list, and we push those into a
-;;; stack each time we encounter a `('. We then parse the middle bit, which
-;;; is a little messy (see the comment there), and start an empty final list
-;;; of operators. Finally, we scan postfix operators; these get pushed onto
-;;; the front of the operator list as we find them. Each time we find a `)',
-;;; we reverse the current prefix-operators list, and attach it to the front
-;;; of the operator list, and pop a new prefix list off the stack: at this
-;;; point, the operator list reflects the type of the subdeclarator we've
-;;; just finished. Eventually we should reach the end with an empty stack
-;;; and a prefix list, which again we reverse and attach to the front of the
-;;; list.
-;;;
-;;; Finally, we apply the operator functions in order.
-
-(defun parse-c-declarator (lexer type &key abstractp dottedp)
- "Parse a declarator. Return two values: the complete type, and the name.
-
- Parse a declarator from LEXER. The base type is given by TYPE. If
- ABSTRACTP is NIL, then require a name; if T then forbid a name; if :MAYBE
- then don't care either way. If no name is given, return NIL.
-
- If DOTTEDP then the name may be a dotted item name `NICK.NAME', returned
- as a cons (NICK . NAME)."
-
- (let ((ops nil)
- (item nil)
- (stack nil)
- (prefix nil))
-
- ;; Scan prefix operators.
- (loop
- (case (token-type lexer)
-
- ;; Star: a pointer type.
- (#\* (let ((quals nil)
- (tok (next-token lexer)))
-
- ;; Gather following qualifiers.
- (loop
- (case tok
- ((:const :volatile :restrict)
- (pushnew tok quals))
- (t
- (return))))
-
- ;; And stash the item.
- (setf quals (sort quals #'string<))
- (push (lambda (ty)
- (make-instance 'c-pointer-type
- :qualifiers quals
- :subtype ty))
- prefix)))
-
- ;; An open-paren: start a new level of nesting. Maybe. There's an
- ;; unpleasant ambiguity (DR9, DR249) between a parenthesized
- ;; subdeclarator and a postfix function argument list following an
- ;; omitted name. If the next thing looks like it might appear as a
- ;; declaration specifier then assume it is one, push the paren back,
- ;; and leave; do the same if the parens are empty, because that's not
- ;; allowed otherwise.
- (#\( (let ((tok (next-token lexer)))
- (when (and abstractp
- (or (eql tok #\))
- (declaration-specifier-p lexer)))
- (pushback-token lexer #\()
- (return))
- (push prefix stack)
- (setf prefix nil)))
-
- ;; Anything else: we're done.
- (t (return))))
-
- ;; We're now at the middle of the declarator. If there's an item name
- ;; here, we want to snarf it.
- (when (and (not (eq abstractp t))
- (eq (token-type lexer) :id))
- (let ((name (token-value lexer)))
- (next-token lexer)
- (cond ((and dottedp (require-token lexer #\. :errorp nil))
- (let ((sub (require-token lexer :id :default (gensym))))
- (setf item (cons name sub))))
- (t
- (setf item name)))))
-
- ;; If we were meant to have a name, but weren't given one, make one up.
- (when (and (null item)
- (not abstractp))
- (cerror* "Missing name; inventing one")
- (setf item (gensym)))
-
- ;; Finally scan the postfix operators.
- (loop
- (case (token-type lexer)
-
- ;; Open-bracket: an array. The dimensions are probably some
- ;; gods-awful C expressions which we'll just tuck away rather than
- ;; thinking about too carefully. Our representation of C types is
- ;; capable of thinking about multidimensional arrays, so we slurp up
- ;; as many dimensions as we can.
- (#\[ (let ((dims nil))
- (loop
- (let* ((frag (scan-c-fragment lexer '(#\])))
- (dim (c-fragment-text frag)))
- (push (if (plusp (length dim)) dim nil) dims))
- (next-token lexer)
- (unless (eq (next-token lexer) #\[)
- (return)))
- (setf dims (nreverse dims))
- (push (lambda (ty)
- (when (typep ty 'c-function-type)
- (error "Array element type cannot be ~
- a function type"))
- (make-instance 'c-array-type
- :dimensions dims
- :subtype ty))
- ops)))
-
- ;; Open-paren: a function with arguments.
- (#\( (let ((args nil))
- (unless (eql (next-token lexer) #\))
- (loop
-
- ;; Grab an argument and stash it.
- (cond ((eql (token-type lexer) :ellipsis)
- (push :ellipsis args))
- (t
- (let ((base-type (parse-c-type lexer)))
- (multiple-value-bind (type name)
- (parse-c-declarator lexer base-type
- :abstractp :maybe)
- (push (make-argument name type) args)))))
-
- ;; Decide whether to take another one.
- (case (token-type lexer)
- (#\) (return))
- (#\, (next-token lexer))
- (t (cerror* "Missing `)' inserted before ~A"
- (format-token lexer))
- (return)))))
- (next-token lexer)
-
- ;; Catch: if the only thing in the list is `void' (with no
- ;; identifier) then kill the whole thing.
- (setf args
- (if (and args
- (null (cdr args))
- (eq (argument-type (car args)) (c-type void))
- (not (argument-name (car args))))
- nil
- (nreverse args)))
-
- ;; Stash the operator.
- (push (lambda (ty)
- (when (typep ty '(or c-function-type c-array-type))
- (error "Function return type cannot be ~
- a function or array type"))
- (make-instance 'c-function-type
- :arguments args
- :subtype ty))
- ops)))
-
- ;; Close-paren: exit a level of nesting. Prepend the current prefix
- ;; list and pop a new level. If there isn't one, this isn't our
- ;; paren, so we're done.
- (#\) (unless stack
- (return))
- (setf ops (nreconc prefix ops)
- prefix (pop stack))
- (next-token lexer))
-
- ;; Anything else means we've finished.
- (t (return))))
-
- ;; If we still have operators stacked then something went wrong.
- (setf ops (nreconc prefix ops))
- (when stack
- (cerror* "Missing `)'(s) inserted before ~A"
- (format-token lexer))
- (dolist (prefix stack)
- (setf ops (nreconc prefix ops))))
-
- ;; Finally, grind through the list of operations.
- (do ((ops ops (cdr ops))
- (type type (funcall (car ops) type)))
- ((endp ops) (values type item)))))
-
-;;;--------------------------------------------------------------------------
-;;; Testing cruft.
-
-#+test
-(with-input-from-string (in "
-// int stat(struct stat *st)
-// void foo(void)
- int vsnprintf(size_t n, char *buf, va_list ap)
-// size_t size_t;
-// int (*signal(int sig, int (*handler)(int s)))(int t)
-")
- (let* ((stream (make-instance 'position-aware-input-stream
- :file "<string>"
- :stream in))
- (lex (make-instance 'sod-lexer :stream stream)))
- (next-char lex)
- (next-token lex)
- (let ((ty (parse-c-type lex)))
- (multiple-value-bind (type name) (parse-c-declarator lex ty)
- (list ty
- (list type name)
- (with-output-to-string (out)
- (pprint-c-type type out name)
- (format-token lex)))))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Position-aware stream type
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Compatibility hacking.
-
-;; ECL doesn't clobber the standard CLOSE and STREAM-ELEMENT-TYPE functions
-;; with the Gray generic versions.
-#-ecl
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (fdefinition 'stream-close) #'cl:close
- (fdefinition 'stream-elt-type) #'cl:stream-element-type))
-
-;;;--------------------------------------------------------------------------
-;;; File names.
-
-(defgeneric stream-pathname (stream)
- (:documentation
- "Returns the pathname of the file that STREAM is open on.
-
- If STREAM is open on a file, then return the pathname of that file.
- Otherwise return NIL.")
-
- ;; Provide some default methods. Most streams don't have a pathname.
- ;; File-based streams provide a pathname, but it's usually been TRUENAMEd,
- ;; which isn't ideal. We'll hack around this later.
- (:method ((stream stream))
- nil)
- (:method ((stream file-stream))
- (pathname stream)))
-
-;;;--------------------------------------------------------------------------
-;;; Locations.
-
-(defclass file-location ()
- ((pathname :initarg :pathname :type (or pathname null)
- :accessor file-location-pathname)
- (line :initarg :line :type (or fixnum null) :accessor file-location-line)
- (column :initarg :column :type (or fixnum null)
- :accessor file-location-column))
- (:documentation
- "A simple structure containing file location information.
-
- Construct using MAKE-FILE-LOCATION; the main useful function is
- ERROR-FILE-LOCATION."))
-
-(defun make-file-location (pathname line column)
- "Constructor for FILE-LOCATION objects.
-
- Returns a FILE-LOCATION object with the given contents."
- (make-instance 'file-location
- :pathname (and pathname (pathname pathname))
- :line line :column column))
-
-(defgeneric file-location (thing)
- (:documentation
- "Convert THING into a FILE-LOCATION, if possible.")
- (:method ((thing null)) (make-file-location nil nil nil))
- (:method ((thing file-location)) thing)
- (:method ((stream stream))
- (make-file-location (stream-pathname stream) nil nil)))
-
-(defmethod print-object ((object file-location) stream)
- (maybe-print-unreadable-object (object stream :type t)
- (with-slots (pathname line column) object
- (format stream "~:[<unnamed>~;~:*~A~]~@[:~D~]~@[:~D~]"
- pathname line column))))
-
-(defmethod make-load-form ((object file-location) &optional environment)
- (make-load-form-saving-slots object :environment environment))
-
-;;;--------------------------------------------------------------------------
-;;; Proxy streams.
-
-;; Base classes for proxy streams.
-
-(defclass proxy-stream (fundamental-stream)
- ((ustream :initarg :stream :type stream
- :reader position-aware-stream-underlying-stream))
- (:documentation
- "Base class for proxy streams.
-
- A proxy stream is one that works by passing most of its work to an
- underlying stream. We provide some basic functionality for the later
- classes."))
-
-(defmethod stream-close ((stream proxy-stream) &key abort)
- (with-slots (ustream) stream
- (close ustream :abort abort)))
-
-(defmethod stream-elt-type ((stream proxy-stream))
- (with-slots (ustream) stream
- (stream-elt-type ustream)))
-
-(defmethod stream-file-position
- ((stream proxy-stream) &optional (position nil posp))
- (with-slots (ustream) stream
- (if posp
- (file-position ustream position)
- (file-position ustream))))
-
-(defmethod stream-pathname ((stream proxy-stream))
- (with-slots (ustream) stream
- (stream-pathname ustream)))
-
-;; Base class for input streams.
-
-(defclass proxy-input-stream (proxy-stream fundamental-input-stream)
- ()
- (:documentation
- "Base class for proxy input streams."))
-
-(defmethod stream-clear-input ((stream proxy-input-stream))
- (with-slots (ustream) stream
- (clear-input ustream)))
-
-(defmethod stream-read-sequence
- ((stream proxy-input-stream) seq &optional (start 0) end)
- (with-slots (ustream) stream
- (read-sequence seq ustream :start start :end end)))
-
-;; Base class for output streams.
-
-(defclass proxy-output-stream (proxy-stream fundamental-output-stream)
- ()
- (:documentation
- "Base class for proxy output streams."))
-
-(defmethod stream-clear-output ((stream proxy-output-stream))
- (with-slots (ustream) stream
- (clear-output ustream)))
-
-(defmethod stream-finish-output ((stream proxy-output-stream))
- (with-slots (ustream) stream
- (finish-output ustream)))
-
-(defmethod stream-force-output ((stream proxy-output-stream))
- (with-slots (ustream) stream
- (force-output ustream)))
-
-(defmethod stream-write-sequence
- ((stream proxy-output-stream) seq &optional (start 0) end)
- (with-slots (ustream) stream
- (write-sequence seq ustream :start start :end end)))
-
-;; Character input streams.
-
-(defclass proxy-character-input-stream
- (proxy-input-stream fundamental-character-input-stream)
- ()
- (:documentation
- "A character-input-stream which is a proxy for an existing stream.
-
- This doesn't actually change the behaviour of the underlying stream very
- much, but it's a useful base to work on when writing more interesting
- classes."))
-
-(defmethod stream-read-char ((stream proxy-character-input-stream))
- (with-slots (ustream) stream
- (read-char ustream nil :eof nil)))
-
-(defmethod stream-read-line ((stream proxy-character-input-stream))
- (with-slots (ustream) stream
- (read-line ustream nil "" nil)))
-
-(defmethod stream-unread-char ((stream proxy-character-input-stream) char)
- (with-slots (ustream) stream
- (unread-char char ustream)))
-
-;; Character output streams.
-
-(defclass proxy-character-output-stream
- (proxy-stream fundamental-character-output-stream)
- ()
- (:documentation
- "A character-output-stream which is a proxy for an existing stream.
-
- This doesn't actually change the behaviour of the underlying stream very
- much, but it's a useful base to work on when writing more interesting
- classes."))
-
-(defmethod stream-line-column ((stream proxy-character-output-stream))
- nil)
-
-(defmethod stream-line-length ((stream proxy-character-output-stream))
- nil)
-
-(defmethod stream-terpri ((stream proxy-character-output-stream))
- (with-slots (ustream) stream
- (terpri ustream)))
-
-(defmethod stream-write-char ((stream proxy-character-output-stream) char)
- (with-slots (ustream) stream
- (write-char char ustream)))
-
-(defmethod stream-write-string
- ((stream proxy-character-output-stream) string &optional (start 0) end)
- (with-slots (ustream) stream
- (write-string string ustream :start start :end end)))
-
-;;;--------------------------------------------------------------------------
-;;; The position-aware stream.
-
-;; Base class.
-
-(defclass position-aware-stream (proxy-stream)
- ((file :initarg :file :initform nil
- :type pathname :accessor position-aware-stream-file)
- (line :initarg :line :initform 1
- :type fixnum :accessor position-aware-stream-line)
- (column :initarg :column :initform 0
- :type fixnum :accessor position-aware-stream-column))
- (:documentation
- "Character stream which keeps track of the line and column position.
-
- A position-aware-stream wraps an existing character stream and tracks the
- line and column position of the current stream position. A newline
- character increases the line number by one and resets the column number to
- zero; most characters advance the column number by one, but tab advances
- to the next multiple of eight. (This is consistent with Emacs, at least.)
- The position can be read using STREAM-LINE-AND-COLUMN.
-
- This is a base class; you probably want POSITION-AWARE-INPUT-STREAM or
- POSITION-AWARE-OUTPUT-STREAM."))
-
-(defgeneric stream-line-and-column (stream)
- (:documentation
- "Returns the current stream position of STREAM as line/column numbers.
-
- Returns two values: the line and column numbers of STREAM's input
- position.")
- (:method ((stream stream))
- (values nil nil))
- (:method ((stream position-aware-stream))
- (with-slots (line column) stream
- (values line column))))
-
-(defmethod stream-pathname ((stream position-aware-stream))
- "Return the pathname corresponding to a POSITION-AWARE-STREAM.
-
- A POSITION-AWARE-STREAM can be given an explicit pathname, which is
- returned in preference to the pathname of the underlying stream. This is
- useful in two circumstances. Firstly, the pathname associated with a file
- stream will have been subjected to TRUENAME, and may be less pleasant to
- present back to a user. Secondly, a name can be attached to a stream
- which doesn't actually have a file backing it."
-
- (with-slots (file) stream
- (or file (call-next-method))))
-
-(defmethod file-location ((stream position-aware-stream))
- (multiple-value-bind (line column) (stream-line-and-column stream)
- (make-file-location (stream-pathname stream) line column)))
-
-;; Utilities.
-
-(declaim (inline update-position))
-(defun update-position (char line column)
- "Updates LINE and COLUMN according to the character CHAR.
-
- Returns the new LINE and COLUMN numbers resulting from having read CHAR."
- (case char
- ((#\newline #\vt #\page)
- (values (1+ line) 0))
- ((#\tab)
- (values line (logandc2 (+ column 7) 7)))
- (t
- (values line (1+ column)))))
-
-(defmacro with-position ((stream) &body body)
- "Convenience macro for tracking the read position.
-
- Within the BODY, the macro (update CHAR) is defined to update the STREAM's
- position according to the character CHAR.
-
- The position is actually cached in local variables, but will be written
- back to the stream even in the case of non-local control transfer from the
- BODY. What won't work well is dynamically nesting WITH-POSITION forms."
-
- (let ((streamvar (gensym "STREAM"))
- (linevar (gensym "LINE"))
- (colvar (gensym "COLUMN"))
- (charvar (gensym "CHAR")))
- `(let* ((,streamvar ,stream)
- (,linevar (position-aware-stream-line ,streamvar))
- (,colvar (position-aware-stream-column ,streamvar)))
- (macrolet ((update (,charvar)
- ;; This gets a little hairy. Hold tight.
- `(multiple-value-setq (,',linevar ,',colvar)
- (update-position ,,charvar ,',linevar ,',colvar))))
- (unwind-protect
- (progn ,@body)
- (setf (position-aware-stream-line ,streamvar) ,linevar
- (position-aware-stream-column ,streamvar) ,colvar))))))
-
-;; Input stream.
-
-(defclass position-aware-input-stream
- (position-aware-stream proxy-character-input-stream)
- ()
- (:documentation
- "A character input stream which tracks the input position.
-
- This is particularly useful for parsers and suchlike, which want to
- produce accurate error-location information."))
-
-(defmethod stream-unread-char ((stream position-aware-input-stream) char)
-
- ;; Tweak the position so that the next time the character is read, it will
- ;; end up here. This isn't perfect: if the character doesn't actually
- ;; match what was really read then it might not actually be possible: for
- ;; example, if we push back a newline while in the middle of a line, or a
- ;; tab while not at a tab stop. In that case, we'll just lose, but
- ;; hopefully not too badly.
- (with-slots (line column) stream
- (case char
-
- ;; In the absence of better ideas, I'll set the column number to zero.
- ;; This is almost certainly wrong, but with a little luck nobody will
- ;; ask and it'll be all right soon.
- ((#\newline #\vt #\page)
- (decf line)
- (setf column 0))
-
- ;; Winding back a single space is sufficient. If the position is
- ;; currently on a tab stop then it'll advance back here next time. If
- ;; not, we're going to lose anyway.
- (#\tab
- (decf column))
-
- ;; Anything else: just decrement the column and cross fingers.
- (t
- (decf column))))
-
- ;; And actually do it. (I could have written this as a :before or :after
- ;; method, but I think this is the right answer. All of the other methods
- ;; have to be primary (or around) methods, so at least it's consistent.)
- (call-next-method))
-
-(defmethod stream-read-sequence
- ((stream position-aware-input-stream) seq &optional (start 0) end)
- (declare (ignore end))
- (let ((pos (call-next-method)))
- (with-position (stream)
- (dosequence (ch seq :start start :end pos)
- (update ch)))
- pos))
-
-(defmethod stream-read-char ((stream position-aware-input-stream))
- (let ((char (call-next-method)))
- (with-position (stream)
- (update char))
- char))
-
-(defmethod stream-read-line ((stream position-aware-input-stream))
- (multiple-value-bind (line eofp) (call-next-method)
- (if eofp
- (with-position (stream)
- (dotimes (i (length line))
- (update (char line i))))
- (with-slots (line column) stream
- (incf line)
- (setf column 0)))
- (values line eofp)))
-
-;; Output stream.
-
-(defclass position-aware-output-stream
- (position-aware-stream proxy-character-output-stream)
- ()
- (:documentation
- "A character output stream which tracks the output position.
-
- This is particularly useful when generating C code: the position can be
- used to generate `#line' directives referring to the generated code after
- insertion of some user code."))
-
-(defmethod stream-write-sequence
- ((stream position-aware-output-stream) seq &optional (start 0) end)
- (with-position (stream)
- (dosequence (ch seq :start start :end end)
- (update ch))
- (call-next-method)))
-
-(defmethod stream-line-column ((stream position-aware-output-stream))
- (with-slots (column) stream
- column))
-
-(defmethod stream-start-line-p ((stream position-aware-output-stream))
- (with-slots (column) stream
- (zerop column)))
-
-(defmethod stream-terpri ((stream position-aware-output-stream))
- (with-slots (line column) stream
- (incf line)
- (setf column 0))
- (call-next-method))
-
-(defmethod stream-write-char ((stream position-aware-output-stream) char)
- (with-position (stream)
- (update char))
- (call-next-method))
-
-(defmethod stream-write-string
- ((stream position-aware-output-stream) string &optional (start 0) end)
- (with-position (stream)
- (do ((i start (1+ i))
- (end (or end (length string))))
- ((>= i end))
- (update (char string i))))
- (call-next-method))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Collections of properties
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Expression parser.
-
-(defun parse-expression (lexer)
- "Parse an expression from the LEXER.
-
- The return values are the expression's VALUE and TYPE; currently the types
- are :ID, :INTEGER, :STRING, and :CHAR. If an error prevented a sane value
- being produced, the TYPE :INVALID is returned.
-
- Expression syntax is rather limited at the moment:
-
- expression : term | expression `+' term | expression `-' term
- term : factor | term `*' factor | term `/' factor
- factor : primary | `+' factor | `-' factor
- primary : integer | identifier | string
- | `(' expression `)'
- | `?' lisp-expression
-
- Identifiers are just standalone things. They don't name values. The
- operators only work on integer values at the moment. (Confusingly, you
- can manufacture rational numbers using the division operator, but they
- still get called integers.)"
-
- (let ((valstack nil)
- (opstack nil))
-
- ;; The following is a simple operator-precedence parser: the
- ;; recursive-descent parser I wrote the first time was about twice the
- ;; size and harder to extend.
- ;;
- ;; The parser flips between two states, OPERAND and OPERATOR. It starts
- ;; out in OPERAND state, and tries to parse a sequence of prefix
- ;; operators followed by a primary expression. Once it's found one, it
- ;; pushes the operand onto the value stack and flips to OPERATOR state;
- ;; if it fails, it reports a syntax error and exits. The OPERAND state
- ;; tries to read a sequence of postfix operators followed by an infix
- ;; operator; if it fails, it assumes that it hit the stuff following the
- ;; expression and stops.
- ;;
- ;; Each operator is pushed onto a stack consisting of lists of the form
- ;; (FUNC PREC TY*). The PREC is a precedence -- higher numbers mean
- ;; tighter binding. The TY* are operand types; operands are popped off
- ;; the operand stack, checked against the requested types, and passed to
- ;; the FUNC, which returns a new operand to be pushed in their place.
- ;;
- ;; Usually, when a binary operator is pushed, existing stacked operators
- ;; with higher precedence are applied. Whether operators with /equal/
- ;; precedence are also applied depends on the associativity of the
- ;; operator: apply equal precedence operators for left-associative
- ;; operators, don't apply for right-associative. When we reach the end
- ;; of the expression, all the remaining operators on the stack are
- ;; applied.
- ;;
- ;; Parenthesized subexpressions are implemented using a hack: when we
- ;; find an open paren in operand position, a fake operator is pushed with
- ;; an artificially low precedece, which protects the operators beneath
- ;; from premature application. The fake operator's function reports an
- ;; error -- this will be triggered only if we reach the end of the
- ;; expression before a matching close-paren, because the close-paren
- ;; handler will pop the fake operator before it does any harm.
-
- (restart-case
- (labels ((apply-op (op)
- ;; Apply the single operator list OP to the values on the
- ;; value stack.
- (let ((func (pop op))
- (args nil))
- (dolist (ty (reverse (cdr op)))
- (let ((arg (pop valstack)))
- (cond ((eq (car arg) :invalid)
- (setf func nil))
- ((eq (car arg) ty)
- (push (cdr arg) args))
- (t
- (cerror* "Type mismatch: wanted ~A; found ~A"
- ty (car arg))
- (setf func nil)))))
- (if func
- (multiple-value-bind (type value) (apply func args)
- (push (cons type value) valstack))
- (push '(:invalid . nil) valstack))))
-
- (apply-all (prec)
- ;; Apply all operators with precedence PREC or higher.
- (loop
- (when (or (null opstack) (< (cadar opstack) prec))
- (return))
- (apply-op (pop opstack)))))
-
- (tagbody
-
- operand
- ;; Operand state. Push prefix operators, and try to read a
- ;; primary operand.
- (case (token-type lexer)
-
- ;; Aha. A primary. Push it onto the stack, and see if
- ;; there's an infix operator.
- ((:integer :id :string :char)
- (push (cons (token-type lexer)
- (token-value lexer))
- valstack)
- (go operator))
-
- ;; Look for a Lisp S-expression.
- (#\?
- (with-lexer-stream (stream lexer)
- (let ((value (eval (read stream t))))
- (push (cons (property-type value) value) valstack)))
- (go operator))
-
- ;; Arithmetic unary operators. Push an operator for `+' for
- ;; the sake of type-checking.
- (#\+
- (push (list (lambda (x) (values :integer x))
- 10 :integer)
- opstack))
- (#\-
- (push (list (lambda (x) (values :integer (- x)))
- 10 :integer)
- opstack))
-
- ;; The open-paren hack. Push a magic marker which will
- ;; trigger an error if we hit the end of the expression.
- ;; Inside the paren, we're still looking for an operand.
- (#\(
- (push (list (lambda ()
- (error "Expected `)' but found ~A"
- (format-token lexer)))
- -1)
- opstack))
-
- ;; Failed to find anything. Report an error and give up.
- (t
- (error "Expected expression but found ~A"
- (format-token lexer))))
-
- ;; Assume prefix operators as the default, so go round for more.
- (next-token lexer)
- (go operand)
-
- operator
- ;; Operator state. Push postfix operators, and try to read an
- ;; infix operator. It turns out that we're always a token
- ;; behind here, so catch up.
- (next-token lexer)
- (case (token-type lexer)
-
- ;; Binary operators.
- (#\+ (apply-all 3)
- (push (list (lambda (x y) (values :integer (+ x y)))
- 3 :integer :integer)
- opstack))
- (#\- (apply-all 3)
- (push (list (lambda (x y) (values :integer (- x y)))
- 3 :integer :integer)
- opstack))
- (#\* (apply-all 5)
- (push (list (lambda (x y) (values :integer (* x y)))
- 5 :integer :integer)
- opstack))
- (#\/ (apply-all 5)
- (push (list (lambda (x y)
- (if (zerop y)
- (progn (cerror* "Division by zero")
- (values nil :invalid))
- (values (/ x y) :integer)))
- 5 :integer :integer)
- opstack))
-
- ;; The close-paren hack. Finish off the operators pushed
- ;; since the open-paren. If the operator stack is now empty,
- ;; this is someone else's paren, so exit. Otherwise pop our
- ;; magic marker, and continue looking for an operator.
- (#\) (apply-all 0)
- (when (null opstack)
- (go done))
- (pop opstack)
- (go operator))
-
- ;; Nothing useful. Must have hit the end, so leave.
- (t (go done)))
-
- ;; Assume we found the binary operator as a default, so snarf a
- ;; token and head back.
- (next-token lexer)
- (go operand)
-
- done)
-
- ;; Apply all the pending operators. If there's an unmatched
- ;; open paren, this will trigger the error message.
- (apply-all -99)
-
- ;; If everything worked out, we should have exactly one operand
- ;; left. This is the one we want.
- (assert (and (consp valstack)
- (null (cdr valstack))))
- (values (cdar valstack) (caar valstack)))
- (continue ()
- :report "Return an invalid value and continue."
- (values nil :invalid)))))
-
-;;;--------------------------------------------------------------------------
-;;; Property set parsing.
-
-(defun parse-property (lexer pset)
- "Parse a single property from LEXER; add it to PSET."
- (let ((name (require-token lexer :id)))
- (require-token lexer #\=)
- (multiple-value-bind (value type) (parse-expression lexer)
- (unless (eq type :invalid)
- (add-property pset name value :type type :location lexer)))))
-
-(defun parse-property-set (lexer)
- "Parse a property set from LEXER.
-
- If there wasn't one to parse, return nil; this isn't considered an error,
- and GET-PROPERTY will perfectly happily report defaults for all requested
- properties."
-
- (when (require-token lexer #\[ :errorp nil)
- (let ((pset (make-pset)))
- (loop
- (parse-property lexer pset)
- (unless (require-token lexer #\, :errorp nil)
- (return)))
- (require-token lexer #\])
- pset)))
-
-;;;--------------------------------------------------------------------------
-;;; Testing cruft.
-
-#+test
-(with-input-from-string (raw "[role = before, integer = 42 * (3 - 1)]")
- (let* ((in (make-instance 'position-aware-input-stream :stream raw))
- (lexer (make-instance 'sod-lexer :stream in)))
- (next-char lexer)
- (next-token lexer)
- (multiple-value-call #'values
- (parse-property-set lexer)
- (token-type lexer))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; sift through lists of classes and so on.
-
-(in-package #:cl-user)
-
-(defstruct (cset (:conc-name s-))
- members supers subs gfs)
-
-(defstruct (class-node (:conc-name c-))
- name class own-p supers subs visited-p sets)
-
-(defmacro pushnew-end (object place &rest keys &environment env)
- (multiple-value-bind (temps inits newtemps setform getform)
- (get-setf-expansion place env)
- (let ((objvar (gensym "OBJECT"))
- (listvar (gensym "LIST")))
- `(let* ((,objvar ,object)
- ,@(mapcar #'list temps inits)
- (,listvar ,getform))
- (cond ((member ,objvar ,listvar ,@keys)
- ,listvar)
- (t
- (multiple-value-bind ,newtemps
- (append ,listvar (list ,objvar))
- ,setform
- (values ,@newtemps))))))))
-
-(defun show-classes (classes)
- (let ((map (make-hash-table)))
-
- (labels ((getnode (class &optional own-p)
- (let ((found (gethash class map)))
- (if found
- (values found t)
- (values (setf (gethash class map)
- (make-class-node :name (class-name class)
- :class class
- :own-p own-p))
- nil))))
-
- (gather (class)
- (let ((node (getnode class)))
- (dolist (super (class-direct-superclasses class))
- (unless (member super (append (mapcar #'find-class
- '(t standard-object
- structure-object))
- (class-direct-superclasses
- (find-class 'condition))))
- (multiple-value-bind (supernode foundp)
- (getnode super)
- (pushnew-end supernode (c-supers node))
- (pushnew node (c-subs supernode))
- (unless foundp (gather super)))))))
-
- (walk (node &optional (level 0) super)
- (format *standard-output* "~v,0T~(~:[[~A]~;~A~]~)"
- (* 2 level)
- (c-own-p node)
- (c-name node))
- (cond ((null (cdr (c-supers node))))
- ((eq (car (c-supers node)) super)
- (format *standard-output* " ~:<~@{~(~A~)~^ ~_~}~:>"
- (mapcar #'c-name (c-supers node))))
- (t
- (format *standard-output* "*~%")
- (return-from walk)))
- (terpri *standard-output*)
- (dolist (sub (c-subs node))
- (walk sub (1+ level) node))))
-
- ;; make nodes for all of the official classes.
- (dolist (class classes)
- (getnode class t))
-
- ;; build the hierarchy, up and down. this may drag in classes from
- ;; other packages.
- (dolist (class classes)
- (gather class))
-
- ;; write the table.
- (dolist (node (sort (loop for node being the hash-values of map
- unless (c-supers node)
- collect node)
- #'string< :key #'c-name))
- (walk node)))))
-
-(defun check-sets (members)
- (let ((done (make-hash-table)))
- (labels ((check (s)
- (when (gethash s done)
- (return-from check))
- (setf (gethash s done) t)
-
- ;; subsets must be proper subsets
- (dolist (u (s-supers s))
- (assert (subsetp (s-members s) (s-members u)))
- (assert (not (subsetp (s-members u) (s-members s))))
- (assert (member s (s-subs u))))
-
- ;; supersets must be proper supersets
- (dolist (u (s-subs s))
- (assert (subsetp (s-members u) (s-members s)))
- (assert (not (subsetp (s-members s) (s-members u))))
- (assert (member s (s-supers u))))
-
- ;; supersets must be minimal
- (dolist (u (s-supers s))
- (dolist (v (s-supers s))
- (assert (or (eq u v)
- (not (subsetp (s-members u)
- (s-members v)))))))
-
- ;; subsets must be maximal
- (dolist (u (s-subs s))
- (dolist (v (s-subs s))
- (assert (or (eq u v)
- (not (subsetp (s-members u)
- (s-members v)))))))
-
- ;; members must link to us, directly or indirectly.
- (dolist (m (s-members s))
- (labels ((look (u)
- (or (eq u s) (some #'look (s-supers u)))))
- (assert (some #'look (c-sets m)))))
-
- ;; check supersets and subsets
- (dolist (u (s-supers s)) (check u))
- (dolist (u (s-subs s)) (check u))))
-
- (dolist (m members)
- (dolist (s (c-sets m))
-
- ;; sets must contain us
- (assert (member m (s-members s)))
-
- ;; sets must be minimal
- (dolist (u (c-sets m))
- (assert (or (eq u s)
- (not (subsetp (s-members u)
- (s-members s))))))
-
- ;; check set
- (check s))))))
-
-(defmethod print-object ((c class-node) stream)
- (format stream "#[~(~A~)]" (c-name c)))
-
-(defmethod print-object ((s cset) stream)
- (format stream "~<#{~;~@{~A~^ ~_~}~;}~:>" (s-members s)))
-
-(defun ensure-set (members)
-
- (setf members (remove-duplicates members))
- (check-sets members)
-
- (let ((subs nil) (supers nil))
-
- ;; find the maximal subsets and minimal supersets. if s is not a subset
- ;; then answer nil; otherwise answer t, and recursively process all the
- ;; supersets of s; if none of them answer t then is maximal, so add it to
- ;; the list.
- (labels ((up (s)
- (cond ((subsetp (s-members s) members)
- (unless (some #'up (s-supers s)) (pushnew s subs))
- t)
- ((subsetp members (s-members s))
- (pushnew s supers)
- nil)
- (t nil))))
- (dolist (m members)
- (mapc #'up (c-sets m))))
- (when (and subs (subsetp members (s-members (car subs))))
- (return-from ensure-set (car subs)))
- (let* ((new (make-cset :members members :supers supers :subs subs)))
-
- ;; now we have to interpolate ourselves properly. this is the tricky
- ;; part.
- (dolist (s supers)
- (setf (s-subs s)
- (cons new (set-difference (s-subs s) subs))))
- (dolist (s subs)
- (setf (s-supers s)
- (cons new (set-difference (s-supers s) supers))))
- (dolist (m members)
- (unless (some (lambda (s) (subsetp (s-members s) members))
- (c-sets m))
- (setf (c-sets m) (cons new
- (remove-if (lambda (s)
- (subsetp members
- (s-members s)))
- (c-sets m))))))
-
- ;; done
- (check-sets members)
- new)))
-
-(defun categorize-protocols (generics classes)
- (let ((cmap (make-hash-table)))
-
- (labels ((getnode (class &optional own-p)
- (let ((found (gethash class cmap)))
- (if found
- (values found t)
- (values (setf (gethash class cmap)
- (make-class-node :name (class-name class)
- :class class
- :own-p own-p))
- nil))))
-
- (gather (class)
- (let ((node (getnode class)))
- (dolist (super (class-direct-superclasses class))
- (unless (member super (append (mapcar #'find-class
- '(t standard-object
- structure-object))
- (class-direct-superclasses
- (find-class 'condition))))
- (multiple-value-bind (supernode foundp)
- (getnode super)
- (pushnew-end supernode (c-supers node))
- (pushnew node (c-subs supernode))
- (unless foundp (gather super))))))))
-
- ;; make nodes for all of the official classes.
- (dolist (class classes)
- (getnode class t))
-
- ;; build the hierarchy, up and down. this may drag in classes from
- ;; other packages.
- (dolist (class classes)
- (gather class))
-
- ;; go through the generic functions collecting sets of implementing
- ;; classes.
- (dolist (gf generics)
- (let* ((specs (reduce #'append
- (mapcar #'method-specializers
- (generic-function-methods gf))
- :from-end t))
- (members (labels ((down (c)
- (delete-duplicates
- (cons c (mapcan #'down (c-subs c)))))
- (gather (spec)
- (let ((c (gethash spec cmap)))
- (and c (down c)))))
- (delete-duplicates (mapcan #'gather specs))))
- (s (and members (ensure-set members))))
- (when s
- (push gf (s-gfs s)))))
-
- ;; finally dump the list of participating classes.
- (let ((tops nil))
-
- ;; find the top-level sets
- (let ((m (make-hash-table)))
- (labels ((ascend (s)
- (unless (gethash s m)
- (setf (gethash s m) t)
- (if (s-supers s)
- (mapc #'ascend (s-supers s))
- (push s tops)))))
- (dolist (c classes)
- (mapc #'ascend (c-sets (gethash c cmap))))))
-
- (let ((done (make-hash-table)))
- (labels ((walk (s &optional (level 0))
- (let ((seen (gethash s done)))
- (unless seen
- (setf (gethash s done) t)
- (dolist (gf (s-gfs s))
- (format *standard-output* "~v,0T~(~A~)~%"
- (* 2 level)
- (generic-function-name gf))))
- (dolist (c (set-difference
- (s-members s)
- (reduce #'union (mapcar #'s-members
- (s-subs s))
- :initial-value nil)))
- (format *standard-output* "~40T~(~A~)~:[~;*~]~%"
- (c-name c) seen))
- (dolist (u (s-subs s))
- (walk u (1+ level))))))
- (mapc #'walk tops)
- nil))))))
-
-(defun gather-stuff (package)
- (let ((classes nil)
- (functions nil)
- (generics nil)
- (structs nil)
- (macros nil)
- (methods nil)
- (package (find-package package)))
-
- ;; find all of the interesting things in the package.
- (do-symbols (sym package)
- (when (eq (symbol-package sym) package)
- (let ((class (find-class sym nil)))
- (typecase class
- ((or standard-class sb-pcl::condition-class)
- (push class classes))
- (structure-class (push class structs))))
- (when (fboundp sym)
- (let ((func (symbol-function sym)))
- (if (typep func 'generic-function)
- (push func generics)
- (push sym functions))))
- (let ((macro (macro-function sym)))
- (when macro (push sym macros)))))
-
- ;; sort the lists -- makes things look prettier.
- (macrolet ((frob (list key)
- `(setf ,list (sort ,list #'string< :key #',key))))
- (frob classes class-name)
- (frob functions identity)
- (frob structs class-name)
- (frob generics generic-function-name)
- (frob macros identity)
- (frob methods (lambda (m)
- (generic-function-name (method-generic-function m)))))
-
- ;; present the classes in a vaguely useful way
- (flet ((sep ()
- (format t "~%-------------------------~2%")))
- (show-classes classes)
- (sep)
- (show-classes structs)
- (sep)
- (categorize-protocols generics classes)
- (loop for title in '("Macros" "Functions")
- for list in (list macros functions) do
- (sep)
- (format t "~{~(~A~)~%~}" list)))))
-
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; System definition for SOD
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:defpackage #:sod-package
- (:use #:common-lisp #:asdf))
-
-(cl:in-package #:sod-package)
-
-;;;--------------------------------------------------------------------------
-;;; Definition.
-
-(defsystem sod
-
- ;; Boring copyright stuff.
- :version "1.0.0"
- :author "Mark Wooding"
- :license "GNU General Public License, version 2 or later"
-
- ;; Documentation.
- :description "A Sensible Object Definition for C."
-
- :long-description
- "This system implements a fairly simple, yet powerful object system for
- plain old C. Its main features are as follows.
-
- * Multiple inheritance, done properly (unlike C++, say), with a
- superclass linearlization algorithm, and exactly one copy of any
- superclass's slots.
-
- * Method combinations, and multiple flavours of methods, to make mixin
- classes more useful.
-
- * The default method combination doesn't depend on the programmer
- statically predicting which superclass's method to delegate to.
- Multiple inheritance makes this approach (taken by C++) fail: the
- right next method might be an unknown sibling, and two siblings might
- be in either order depending on descendents.
-
- * Minimal runtime support requirements, so that it's suitable for use
- wherever C is -- e.g., interfacing to other languages."
-
- ;; And now for how to build it.
- ;;
- ;; The big tables in parser.lisp need to be earlier. CLEAR-THE-DECKS ought
- ;; to do more stuff, including calling BOOTSTRAP-CLASSES. Generally, the
- ;; code isn't very well organized at the moment.
- :components
- ((:file "package")
- (:file "utilities" :depends-on ("package"))
- (:file "tables" :depends-on ("package"))
- (:file "c-types" :depends-on ("utilities"))
- (:file "codegen" :depends-on ("c-types"))
- (:file "posn-stream" :depends-on ("utilities"))
- (:file "errors" :depends-on ("posn-stream"))
- (:file "lex" :depends-on ("posn-stream" "errors"))
- (:file "pset" :depends-on ("lex"))
- (:file "parse-c-types" :depends-on ("lex" "c-types" "tables"))
- (:file "class-defs" :depends-on ("parse-c-types"))
- (:file "cpl" :depends-on ("class-defs"))
- (:file "class-finalize" :depends-on ("class-defs" "cpl"))
- (:file "class-builder" :depends-on ("class-finalize" "pset"))
- (:file "class-layout" :depends-on ("class-defs"))
- (:file "module" :depends-on ("parse-c-types" "class-defs" "tables"))
- (:file "builtin" :depends-on ("module" "class-layout"))
- (:file "output" :depends-on ("module"))
- (:file "methods" :depends-on ("class-layout" "codegen" "output"))
- (:file "class-output" :depends-on ("builtin" "class-builder"
- "methods" "output"))
- (:file "combination" :depends-on ("methods"))
- (:file "module-output" :depends-on ("combination" "class-output"))))
-
-;;;----- That's all, folks --------------------------------------------------
+++ /dev/null
-;;; -*-lisp-*-
-;;;
-;;; Main tables for the translator
-;;;
-;;; (c) 2009 Straylight/Edgeware
-;;;
-
-;;;----- Licensing notice ---------------------------------------------------
-;;;
-;;; This file is part of the Simple Object Definition system.
-;;;
-;;; SOD is free software; you can redistribute it and/or modify
-;;; it under the terms of the GNU General Public License as published by
-;;; the Free Software Foundation; either version 2 of the License, or
-;;; (at your option) any later version.
-;;;
-;;; SOD is distributed in the hope that it will be useful,
-;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;; GNU General Public License for more details.
-;;;
-;;; You should have received a copy of the GNU General Public License
-;;; along with SOD; if not, write to the Free Software Foundation,
-;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-(cl:in-package #:sod)
-
-;;;--------------------------------------------------------------------------
-;;; Main tables.
-
-(defvar *module-map* (make-hash-table :test #'equal)
- "A hash table mapping file truenames (pathnames) to modules.
-
- This is used to prevent multiple inclusion of a single module, which would
- be bad. Usually it maps pathnames to MODULE objects. As a special case,
- the truename a module which is being parsed maps to :IN-PROGRESS, which
- can be used to detect dependency cycles.")
-
-(defvar *type-map* (make-hash-table :test #'equal)
- "A hash table mapping type names to the C types they describe.
-
- Since a class is a C type, it gets its own entry in here as a C-CLASS-TYPE
- object. This is how we find classes by name: the C-CLASS-TYPE object has
- a reference to the underlying SOD-CLASS instance.")
-
-(defparameter *builtin-module* nil
- "Built-in module; populated later.")
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-(defparameter *clear-the-decks-functions*
- '(reset-type-and-module-map
- reset-builtin-module))
-
-(defun reset-type-and-module-map ()
- "Reset the main hash tables, clearing the translator's state.
-
- One of the *CLEAR-THE-DECKS-FUNCTIONS*."
-
- (setf *module-map* (make-hash-table :test #'equal)
- *type-map* (make-hash-table :test #'equal)))
-
-(defun populate-type-map ()
- "Store some important simple types in the type map."
- (dolist (name '("va_list" "size_t" "ptrdiff_t"))
- (setf (gethash name *type-map*)
- (make-simple-type name))))
-
-(defun clear-the-decks ()
- "Reinitialize the translator's state.
-
- This is mainly useful when testing the translator from a Lisp REPL."
- (dolist (func *clear-the-decks-functions*)
- (funcall func)))
-
-#+test
-(clear-the-decks)
-
-;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+prefix=@prefix@
+exec_prefix=@exec_prefix@
+libdir=@libdir@
+includedir=@includedir@
+
+Name: sod
+Description: Sensible object design, runtime library
+Version: @VERSION@
+Libs: -L${libdir} -lsod
+Cflags: -I${includedir}
include $(top_srcdir)/vars.am
-dist_pkglispsrc_DATA =
+nobase_dist_pkglispsrc_DATA = $(LISP_SOURCES)
+LISP_SOURCES =
###--------------------------------------------------------------------------
### The source files.
## The system definition file.
-dist_pkglispsrc_DATA += sod.asd
+LISP_SOURCES += sod.asd
## The package definition file.
-dist_pkglispsrc_DATA += package.lisp
+LISP_SOURCES += package.lisp
## General utilities.
-dist_pkglispsrc_DATA += utilities.lisp
+LISP_SOURCES += utilities.lisp
## The parser library.
-dist_pkglispsrc_DATA += parser/floc-proto.lisp parser/floc-impl.lisp
-dist_pkglispsrc_DATA += parser/streams-proto.lisp parser/streams-impl.lisp
-dist_pkglispsrc_DATA += parser/scanner-proto.lisp parser/scanner-impl.lisp
-dist_pkglispsrc_DATA += parser/scanner-charbuf-impl.lisp
-dist_pkglispsrc_DATA += parser/scanner-token-impl.lisp
-dist_pkglispsrc_DATA += parser/parser-proto.lisp parser/parser-impl.lisp
-dist_pkglispsrc_DATA += parser/parser-expr-proto.lisp \
+LISP_SOURCES += parser/package.lisp
+LISP_SOURCES += parser/floc-proto.lisp parser/floc-impl.lisp
+LISP_SOURCES += parser/streams-proto.lisp parser/streams-impl.lisp
+LISP_SOURCES += parser/scanner-proto.lisp parser/scanner-impl.lisp
+LISP_SOURCES += parser/scanner-charbuf-impl.lisp
+LISP_SOURCES += parser/scanner-token-impl.lisp
+LISP_SOURCES += parser/parser-proto.lisp parser/parser-impl.lisp
+LISP_SOURCES += parser/parser-expr-proto.lisp \
parser/parser-expr-impl.lisp
-dist_pkglispsrc_DATA += parser/scanner-context-impl.lisp
+LISP_SOURCES += parser/scanner-context-impl.lisp
## Lexical analysis and translator-specific parser utilities.
-dist_pkglispsrc_DATA += lexer-proto.lisp lexer-impl.lisp
-dist_pkglispsrc_DATA += fragment-parse.lisp
+LISP_SOURCES += lexer-proto.lisp lexer-impl.lisp
+LISP_SOURCES += fragment-parse.lisp
## C type representation.
-dist_pkglispsrc_DATA += c-types-proto.lisp c-types-impl.lisp \
+LISP_SOURCES += c-types-proto.lisp c-types-impl.lisp \
c-types-parse.lisp
## Property sets.
-dist_pkglispsrc_DATA += pset-proto.lisp pset-impl.lisp pset-parse.lisp
+LISP_SOURCES += pset-proto.lisp pset-impl.lisp pset-parse.lisp
## Code generation.
-dist_pkglispsrc_DATA += codegen-proto.lisp codegen-impl.lisp
+LISP_SOURCES += codegen-proto.lisp codegen-impl.lisp
## Output machinery.
-dist_pkglispsrc_DATA += output-proto.lisp output-impl.lisp
+LISP_SOURCES += output-proto.lisp output-impl.lisp
## Modules.
-dist_pkglispsrc_DATA += module-proto.lisp module-impl.lisp
-dist_pkglispsrc_DATA += module-parse.lisp module-output.lisp
-dist_pkglispsrc_DATA += builtin.lisp
+LISP_SOURCES += module-proto.lisp module-impl.lisp
+LISP_SOURCES += module-parse.lisp module-output.lisp
+LISP_SOURCES += builtin.lisp
## Class representation and layout.
-dist_pkglispsrc_DATA += classes.lisp c-types-class-impl.lisp
-dist_pkglispsrc_DATA += class-utilities.lisp
-dist_pkglispsrc_DATA += class-make-proto.lisp class-make-impl.lisp
-dist_pkglispsrc_DATA += class-layout-proto.lisp class-layout-impl.lisp
-dist_pkglispsrc_DATA += class-finalize-proto.lisp class-finalize-impl.lisp
-dist_pkglispsrc_DATA += class-output.lisp
+LISP_SOURCES += classes.lisp c-types-class-impl.lisp
+LISP_SOURCES += class-utilities.lisp
+LISP_SOURCES += class-make-proto.lisp class-make-impl.lisp
+LISP_SOURCES += class-layout-proto.lisp class-layout-impl.lisp
+LISP_SOURCES += class-finalize-proto.lisp class-finalize-impl.lisp
+LISP_SOURCES += class-output.lisp
## Method generation.
-dist_pkglispsrc_DATA += method-proto.lisp method-impl.lisp
+LISP_SOURCES += method-proto.lisp method-impl.lisp
+LISP_SOURCES += method-aggregate.lisp
## User interface.
-dist_pkglispsrc_DATA += sod-frontend.asd
-dist_pkglispsrc_DATA += frontend.lisp optparse.lisp
+LISP_SOURCES += sod-frontend.asd
+LISP_SOURCES += frontend.lisp optparse.lisp
+
+## Interactive testing.
+LISP_SOURCES += debug.lisp
###--------------------------------------------------------------------------
### Constructing an output image.
-CLEANFILES += *.$(FASL_TYPE)
+CLEANFILES += *.$(fasl) parser/*.$(fasl)
## Building the executable image.
bin_PROGRAMS += sod
sod_SOURCES =
-sod: $(dist_pkglispsrc_DATA)
- set -ex; true_srcdir=$$(cd $(srcdir); pwd); \
+sod: $(LISP_SOURCES)
+ $(V_DUMP)true_srcdir=$$(cd $(srcdir); pwd); \
ASDF_OUTPUT_TRANSLATIONS=$$true_srcdir:$(abs_builddir): \
- $(CL_LAUNCH) -o sod -d ! -l $(LISPSYS) +I -S $$true_srcdir/ \
+ $(CL_LAUNCH) -o sod -d ! -l $(LISPSYS) +I -S $$true_srcdir/: \
-s sod-frontend -r sod-frontend:main
###--------------------------------------------------------------------------
+### Unit testing.
+
+## The system definition.
+EXTRA_DIST += sod-test.asd
+
+## Basic utilities.
+EXTRA_DIST += test-base.lisp
+
+## Parser tests.
+EXTRA_DIST += parser/parser-test.lisp
+EXTRA_DIST += parser/scanner-charbuf-test.lisp
+
+## Translator tests.
+EXTRA_DIST += c-types-test.lisp
+EXTRA_DIST += codegen-test.lisp
+EXTRA_DIST += lexer-test.lisp
+
+## Running the Lisp tests.
+check-local:
+ $(V_TEST)true_srcdir=$$(cd $(srcdir); pwd); \
+ ASDF_OUTPUT_TRANSLATIONS=$$true_srcdir:$(abs_builddir): \
+ $(CL_LAUNCH) -l $(LISPSYS) -s sod-test +I -S $$true_srcdir/: \
+ -i '(handler-case ;\
+ (progn ;\
+ (setf sod-test:*build-version* "$(VERSION)") ;\
+ (asdf:test-system "sod")) ;\
+ (error (cond) ;\
+ (format *error-output* "ERR: ~A~%" cond) ;\
+ (cl-launch:quit 1)))'
+
+###--------------------------------------------------------------------------
### Installation.
## We want a symlink $(lispsysdir)/sod.asd -> $(lispsrcdir)/sod/sod.asd. It
dots=$$(echo $$fwd | sed 's/[^ ][^ ]*/../g'); \
rel=$$(echo $$dots $$twd | tr " " "/"); \
echo >&2 "ln -s $$rel $$to"; \
- ln -s $$rel $(DESTDIR)$$from.new; \
- mv $(DESTDIR)$$from.new $(DESTDIR)$$from
+ ln -s $$rel $(DESTDIR)$$from/sod.asd.new; \
+ mv $(DESTDIR)$$from/sod.asd.new $(DESTDIR)$$from/sod.asd
###----- That's all, folks --------------------------------------------------
POST_UNINSTALL = :
build_triplet = @build@
host_triplet = @host@
-DIST_COMMON = $(dist_pkglispsrc_DATA) $(pkginclude_HEADERS) \
+DIST_COMMON = $(nobase_dist_pkglispsrc_DATA) $(pkginclude_HEADERS) \
$(srcdir)/Makefile.am $(srcdir)/Makefile.in \
$(top_srcdir)/vars.am
bin_PROGRAMS = sod$(EXEEXT)
|| { echo " ( cd '$$dir' && rm -f" $$files ")"; \
$(am__cd) "$$dir" && rm -f $$files; }; \
}
-DATA = $(dist_pkglispsrc_DATA)
+DATA = $(nobase_dist_pkglispsrc_DATA)
HEADERS = $(pkginclude_HEADERS)
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
ACLOCAL = @ACLOCAL@
ECHO_T = @ECHO_T@
EGREP = @EGREP@
EXEEXT = @EXEEXT@
-FASL_TYPE = @FASL_TYPE@
FGREP = @FGREP@
GREP = @GREP@
INSTALL = @INSTALL@
docdir = @docdir@
dvidir = @dvidir@
exec_prefix = @exec_prefix@
+fasl = @fasl@
host = @host@
host_alias = @host_alias@
host_cpu = @host_cpu@
###--------------------------------------------------------------------------
### Initial values for common variables.
-EXTRA_DIST =
+
+###--------------------------------------------------------------------------
+### Unit testing.
+EXTRA_DIST = sod-test.asd test-base.lisp parser/parser-test.lisp \
+ parser/scanner-charbuf-test.lisp c-types-test.lisp \
+ codegen-test.lisp lexer-test.lisp
###--------------------------------------------------------------------------
### Constructing an output image.
-CLEANFILES = $(BUILT_SOURCES) *.$(FASL_TYPE)
+CLEANFILES = $(BUILT_SOURCES) *.$(fasl) parser/*.$(fasl)
DISTCLEANFILES =
MAINTAINERCLEANFILES =
SUFFIXES = .c .h .sod
LDADD = $(top_builddir)/lib/libsod.la
###--------------------------------------------------------------------------
+### Standard configuration substitutions.
+confsubst = $(top_srcdir)/config/confsubst
+SUBSTITUTIONS = \
+ prefix=$(prefix) exec_prefix=$(exec_prefix) \
+ libdir=$(libdir) includedir=$(includedir) \
+ bindir=$(bindir) sbindir=$(sbindir) \
+ PACKAGE=$(PACKAGE) VERSION=$(VERSION)
+
+V_SUBST = $(V_SUBST_$(V))
+V_SUBST_ = $(V_SUBST_$(AM_DEFAULT_VERBOSITY))
+V_SUBST_0 = @echo " SUBST $@";
+SUBST = $(V_SUBST)$(confsubst)
+
+###--------------------------------------------------------------------------
### Translating SOD input files.
SOD = $(top_builddir)/src/sod
+V_SOD_c = $(V_SOD_c_$(V))
+V_SOD_c_ = $(V_SOD_c_$(AM_DEFAULT_VERBOSITY))
+V_SOD_c_0 = @echo " SOD[c] $@";
+V_SOD_h = $(V_SOD_h_$(V))
+V_SOD_h_ = $(V_SOD_h_$(AM_DEFAULT_VERBOSITY))
+V_SOD_h_0 = @echo " SOD[h] $@";
+
+###--------------------------------------------------------------------------
+### Silent rules for Lisp.
+V_DUMP = $(V_DUMP_$(V))
+V_DUMP_ = $(V_DUMP_$(AM_DEFAULT_VERBOSITY))
+V_DUMP_0 = @echo " DUMP $@";
+V_TEST = $(V_TEST_$(V))
+V_TEST_ = $(V_TEST_$(AM_DEFAULT_VERBOSITY))
+V_TEST_0 = @echo " TEST $@";
+nobase_dist_pkglispsrc_DATA = $(LISP_SOURCES)
###--------------------------------------------------------------------------
### The source files.
-dist_pkglispsrc_DATA = sod.asd package.lisp utilities.lisp \
+LISP_SOURCES = sod.asd package.lisp utilities.lisp parser/package.lisp \
parser/floc-proto.lisp parser/floc-impl.lisp \
parser/streams-proto.lisp parser/streams-impl.lisp \
parser/scanner-proto.lisp parser/scanner-impl.lisp \
class-layout-proto.lisp class-layout-impl.lisp \
class-finalize-proto.lisp class-finalize-impl.lisp \
class-output.lisp method-proto.lisp method-impl.lisp \
- sod-frontend.asd frontend.lisp optparse.lisp
+ method-aggregate.lisp sod-frontend.asd frontend.lisp \
+ optparse.lisp debug.lisp
sod_SOURCES =
all: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) all-am
clean-libtool:
-rm -rf .libs _libs
-install-dist_pkglispsrcDATA: $(dist_pkglispsrc_DATA)
+install-nobase_dist_pkglispsrcDATA: $(nobase_dist_pkglispsrc_DATA)
@$(NORMAL_INSTALL)
- @list='$(dist_pkglispsrc_DATA)'; test -n "$(pkglispsrcdir)" || list=; \
+ @list='$(nobase_dist_pkglispsrc_DATA)'; test -n "$(pkglispsrcdir)" || list=; \
if test -n "$$list"; then \
echo " $(MKDIR_P) '$(DESTDIR)$(pkglispsrcdir)'"; \
$(MKDIR_P) "$(DESTDIR)$(pkglispsrcdir)" || exit 1; \
fi; \
- for p in $$list; do \
- if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
- echo "$$d$$p"; \
- done | $(am__base_list) | \
- while read files; do \
- echo " $(INSTALL_DATA) $$files '$(DESTDIR)$(pkglispsrcdir)'"; \
- $(INSTALL_DATA) $$files "$(DESTDIR)$(pkglispsrcdir)" || exit $$?; \
+ $(am__nobase_list) | while read dir files; do \
+ xfiles=; for file in $$files; do \
+ if test -f "$$file"; then xfiles="$$xfiles $$file"; \
+ else xfiles="$$xfiles $(srcdir)/$$file"; fi; done; \
+ test -z "$$xfiles" || { \
+ test "x$$dir" = x. || { \
+ echo " $(MKDIR_P) '$(DESTDIR)$(pkglispsrcdir)/$$dir'"; \
+ $(MKDIR_P) "$(DESTDIR)$(pkglispsrcdir)/$$dir"; }; \
+ echo " $(INSTALL_DATA) $$xfiles '$(DESTDIR)$(pkglispsrcdir)/$$dir'"; \
+ $(INSTALL_DATA) $$xfiles "$(DESTDIR)$(pkglispsrcdir)/$$dir" || exit $$?; }; \
done
-uninstall-dist_pkglispsrcDATA:
+uninstall-nobase_dist_pkglispsrcDATA:
@$(NORMAL_UNINSTALL)
- @list='$(dist_pkglispsrc_DATA)'; test -n "$(pkglispsrcdir)" || list=; \
- files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ @list='$(nobase_dist_pkglispsrc_DATA)'; test -n "$(pkglispsrcdir)" || list=; \
+ $(am__nobase_strip_setup); files=`$(am__nobase_strip)`; \
dir='$(DESTDIR)$(pkglispsrcdir)'; $(am__uninstall_files_from_dir)
install-pkgincludeHEADERS: $(pkginclude_HEADERS)
@$(NORMAL_INSTALL)
done
check-am: all-am
$(MAKE) $(AM_MAKEFLAGS) $(check_PROGRAMS)
+ $(MAKE) $(AM_MAKEFLAGS) check-local
check: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) check-am
all-am: Makefile $(PROGRAMS) $(DATA) $(HEADERS)
info-am:
-install-data-am: install-data-local install-dist_pkglispsrcDATA \
+install-data-am: install-data-local install-nobase_dist_pkglispsrcDATA \
install-pkgincludeHEADERS
install-dvi: install-dvi-am
ps-am:
-uninstall-am: uninstall-binPROGRAMS uninstall-dist_pkglispsrcDATA \
+uninstall-am: uninstall-binPROGRAMS \
+ uninstall-nobase_dist_pkglispsrcDATA \
uninstall-pkgincludeHEADERS
.MAKE: all check check-am install install-am install-strip
-.PHONY: all all-am check check-am clean clean-binPROGRAMS \
+.PHONY: all all-am check check-am check-local clean clean-binPROGRAMS \
clean-checkPROGRAMS clean-generic clean-libtool distclean \
distclean-compile distclean-generic distclean-libtool distdir \
dvi dvi-am html html-am info info-am install install-am \
install-binPROGRAMS install-data install-data-am \
- install-data-local install-dist_pkglispsrcDATA install-dvi \
- install-dvi-am install-exec install-exec-am install-html \
- install-html-am install-info install-info-am install-man \
+ install-data-local install-dvi install-dvi-am install-exec \
+ install-exec-am install-html install-html-am install-info \
+ install-info-am install-man install-nobase_dist_pkglispsrcDATA \
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 \
uninstall uninstall-am uninstall-binPROGRAMS \
- uninstall-dist_pkglispsrcDATA uninstall-pkgincludeHEADERS
+ uninstall-nobase_dist_pkglispsrcDATA \
+ uninstall-pkgincludeHEADERS
-.sod.c: $(SOD); $(SOD) -tc $<
-.sod.h: $(SOD); $(SOD) -th $<
+.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $<
+.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $<
###----- That's all, folks --------------------------------------------------
-sod: $(dist_pkglispsrc_DATA)
- set -ex; true_srcdir=$$(cd $(srcdir); pwd); \
+sod: $(LISP_SOURCES)
+ $(V_DUMP)true_srcdir=$$(cd $(srcdir); pwd); \
ASDF_OUTPUT_TRANSLATIONS=$$true_srcdir:$(abs_builddir): \
- $(CL_LAUNCH) -o sod -d ! -l $(LISPSYS) +I -S $$true_srcdir/ \
+ $(CL_LAUNCH) -o sod -d ! -l $(LISPSYS) +I -S $$true_srcdir/: \
-s sod-frontend -r sod-frontend:main
+check-local:
+ $(V_TEST)true_srcdir=$$(cd $(srcdir); pwd); \
+ ASDF_OUTPUT_TRANSLATIONS=$$true_srcdir:$(abs_builddir): \
+ $(CL_LAUNCH) -l $(LISPSYS) -s sod-test +I -S $$true_srcdir/: \
+ -i '(handler-case ;\
+ (progn ;\
+ (setf sod-test:*build-version* "$(VERSION)") ;\
+ (asdf:test-system "sod")) ;\
+ (error (cond) ;\
+ (format *error-output* "ERR: ~A~%" cond) ;\
+ (cl-launch:quit 1)))'
+
###--------------------------------------------------------------------------
### Installation.
dots=$$(echo $$fwd | sed 's/[^ ][^ ]*/../g'); \
rel=$$(echo $$dots $$twd | tr " " "/"); \
echo >&2 "ln -s $$rel $$to"; \
- ln -s $$rel $(DESTDIR)$$from.new; \
- mv $(DESTDIR)$$from.new $(DESTDIR)$$from
+ ln -s $$rel $(DESTDIR)$$from/sod.asd.new; \
+ mv $(DESTDIR)$$from/sod.asd.new $(DESTDIR)$$from/sod.asd
###----- That's all, folks --------------------------------------------------
',name
(lambda (,classvar)
(make-sod-slot ,classvar ,name (c-type ,type)
- (make-property-set :lisp-class 'sod-class-slot
+ (make-property-set :slot-class 'sod-class-slot
:initializer-function
(lambda (,class)
,init)
(make-instance 'c-function-type :subtype subtype
:arguments (if (and arguments
(null (cdr arguments))
+ (not (eq (car arguments) :ellipsis))
(eq (argument-type (car arguments))
c-type-void))
nil
(gethash kw *declspec-map*))))))
(cond ((or (not ds) (and predicate (not (funcall predicate ds))))
(values (list indicator) nil nil))
- ((ds-taggedp ds)
+ ((and (typep ds 'declspec) (ds-taggedp ds))
(scanner-step scanner)
(if (eq (token-type scanner) :id)
(let ((ty (make-c-tagged-type (ds-label ds)
(make-pointer-type type quals)))
(cdr state))))))
- (next-declspec-p ()
- ;; Ansert whether the next token is a valid declaration
- ;; specifier, without consuming it.
- (and (eq (token-type scanner) :id)
- (let ((id (token-value scanner)))
- (or (gethash id *module-type-map*)
- (gethash id *declspec-map*)))))
+ (predict-argument-list-p ()
+ ;; See `prefix-lparen'. Predict an argument list rather
+ ;; than a nested declarator if (a) abstract declarators are
+ ;; permitted and (b) the next token is a declaration
+ ;; specifier or ellipsis.
+ (let ((type (token-type scanner))
+ (value (token-value scanner)))
+ (and abstractp
+ (or (eq type :ellipsis)
+ (and (eq type :id)
+ (or (gethash value *module-type-map*)
+ (gethash value *declspec-map*)))))))
(prefix-lparen ()
;; Prefix: `('
;; specifier, then we have a postfix argument list.
(parse
(peek (seq (#\(
- (nil (if (and abstractp (next-declspec-p))
+ (nil (if (predict-argument-list-p)
(values nil nil nil)
(values t t nil))))
(lparen #\))))))
(cons #'identity name))))
(argument-list ()
- ;; [ argument [ `,' argument ]* ]
-
- (parse (list (:min 0)
- (seq ((base-type (parse-c-type scanner))
- (dtor (parse-declarator scanner
- base-type
- :abstractp t)))
- (make-argument (cdr dtor) (car dtor)))
- #\,)))
+ ;; [argument [`,' argument]* [`,' `...']] | `...'
+ ;;
+ ;; The possibility of a trailing `,' `...' means that we
+ ;; can't use the standard `list' parser. Note that, unlike
+ ;; `real' C, we allow an ellipsis even if there are no
+ ;; explicit arguments.
+
+ (let ((args nil))
+ (loop
+ (when (eq (token-type scanner) :ellipsis)
+ (push :ellipsis args)
+ (scanner-step scanner)
+ (return))
+ (multiple-value-bind (arg winp consumedp)
+ (parse (seq ((base-type (parse-c-type scanner))
+ (dtor (parse-declarator scanner
+ base-type
+ :abstractp t)))
+ (make-argument (cdr dtor) (car dtor))))
+ (unless winp
+ (if (or consumedp args)
+ (return-from argument-list (values arg nil t))
+ (return)))
+ (push arg args))
+ (unless (eq (token-type scanner) #\,)
+ (return))
+ (scanner-step scanner))
+ (values (nreverse args) t args)))
(postfix-lparen ()
;; Postfix: `(' argument-list `)'
(defmethod print-object ((entry method-entry) stream)
(maybe-print-unreadable-object (entry stream :type t)
- (format stream "~A:~A"
+ (format stream "~A:~A~@[ ~S~]"
(method-entry-effective-method entry)
- (sod-class-nickname (method-entry-chain-head entry)))))
+ (sod-class-nickname (method-entry-chain-head entry))
+ (method-entry-role entry))))
(defmethod compute-sod-effective-method
((message sod-message) (class sod-class))
(subclass sod-class)
(chain-head sod-class)
(chain-tail sod-class))
- (flet ((make-entry (message)
+ (flet ((make-entries (message)
(let ((method (find message
(sod-class-effective-methods subclass)
:key #'effective-method-message)))
- (make-method-entry method chain-head chain-tail))))
+ (make-method-entries method chain-head chain-tail))))
(make-instance 'vtmsgs
:class class
:subclass subclass
:chain-head chain-head
:chain-tail chain-tail
- :entries (mapcar #'make-entry
+ :entries (mapcan #'make-entries
(sod-class-messages class)))))
;;; class-pointer
(export 'compte-vtmsgs)
(defgeneric compute-vtmsgs (class subclass chain-head chain-tail)
(:documentation
- "Return a VTMSGS object containing method entries for CLASS.
+ "Return a `vtmsgs' object containing method entries for CLASS.
The CHAIN-HEAD describes which chain the method entries should be
constructed for.
- The default method simply calls MAKE-METHOD-ENTRY for each of the methods
- and wraps a VTMSGS object around them. This ought to be enough for almost
- all purposes."))
+ The default method simply calls `make-method-entry' for each of the
+ methods and wraps a `vtmsgs' object around them. This ought to be enough
+ for almost all purposes."))
;;; class-pointer
(defmethod make-sod-slot
((class sod-class) name type pset &optional location)
(with-default-error-location (location)
- (let ((slot (make-instance (get-property pset :lisp-class :symbol
+ (let ((slot (make-instance (get-property pset :slot-class :symbol
'sod-slot)
:class class
:name name
:location (file-location location)
:pset pset)))
(with-slots (slots) class
- (setf slots (append slots (list slot)))))))
+ (setf slots (append slots (list slot))))
+ slot)))
(defmethod shared-initialize :after ((slot sod-slot) slot-names &key pset)
"This method does nothing.
(file-location location))))
(with-slots (instance-initializers) class
(setf instance-initializers
- (append instance-initializers (list initializer)))))))
+ (append instance-initializers (list initializer))))
+ initializer)))
(defmethod make-sod-class-initializer
((class sod-class) nick name value-kind value-form pset
(file-location location))))
(with-slots (class-initializers) class
(setf class-initializers
- (append class-initializers (list initializer)))))))
+ (append class-initializers (list initializer))))
+ initializer)))
(defmethod make-sod-initializer-using-slot
((class sod-class) (slot sod-slot)
init-class value-kind value-form pset location)
- (make-instance (get-property pset :lisp-class :symbol init-class)
+ (make-instance (get-property pset :initializer-class :symbol init-class)
:class class
:slot slot
:value-kind value-kind
(defmethod make-sod-message
((class sod-class) name type pset &optional location)
(with-default-error-location (location)
- (let ((message (make-instance (get-property pset :lisp-class :symbol
- 'standard-message)
- :class class
- :name name
- :type type
- :location (file-location location)
- :pset pset)))
+ (let* ((msg-class (or (get-property pset :message-class :symbol)
+ (and (get-property pset :combination :keyword)
+ 'aggregating-message)
+ 'standard-message))
+ (message (make-instance msg-class
+ :class class
+ :name name
+ :type type
+ :location (file-location location)
+ :pset pset)))
(with-slots (messages) class
- (setf messages (append messages (list message)))))))
+ (setf messages (append messages (list message))))
+ message)))
(defmethod shared-initialize :after
((message sod-message) slot-names &key pset)
type body pset
(file-location location))))
(with-slots (methods) class
- (setf methods (append methods (list method)))))))
+ (setf methods (append methods (list method))))
+ method)))
(defmethod make-sod-method-using-message
((message sod-message) (class sod-class) type body pset location)
- (make-instance (or (get-property pset :lisp-class :symbol)
+ (make-instance (or (get-property pset :method-class :symbol)
(sod-message-method-class message class pset))
:message message
:class class
(with-slots (body type) method
(unless (or (not body)
(every (lambda (arg)
- (or (argument-name arg)
+ (or (eq arg :ellipsis)
+ (argument-name arg)
(eq (argument-type arg) (c-type void))))
(c-function-arguments type)))
(error "Abstract declarators not permitted in method definitions")))
"Construct and return a new SOD class with the given NAME and SUPERCLASSES.
This is the main constructor function for classes. The protocol works as
- follows. The `:lisp-class' property in PSET is checked: if it exists, it
- must be a symbol naming a (CLOS) class, which is used in place of
+ follows. The `:lisp-metaclass' property in PSET is checked: if it exists,
+ it must be a symbol naming a (CLOS) class, which is used in place of
`sod-class'. All of the arguments are then passed to `make-instance';
further behaviour is left to the standard CLOS instance construction
protocol; for example, `sod-class' defines an `:after'-method on
(with-default-error-location (location)
(let* ((pset (property-set pset))
- (class (make-instance (get-property pset :lisp-class :symbol
+ (class (make-instance (get-property pset :lisp-metaclass :symbol
'sod-class)
:name name
:superclasses superclasses
This is the main constructor function for slots. This is a generic
function primarily so that the CLASS can intervene in the construction
- process. The default method uses the `:lisp-class' property (defaulting
+ process. The default method uses the `:slot-class' property (defaulting
to `sod-slot') to choose a (CLOS) class to instantiate. The slot is then
constructed by `make-instance' passing the arguments as initargs; further
behaviour is left to the standard CLOS instance construction protocol; for
This generic function does the common work for constructing instance and
class initializers. It can usefully be specialized according to both the
- class and slot types. The default method uses the `:lisp-class' property
- (defaulting to INIT-CLASS) to choose a (CLOS) class to instantiate. The
- slot is then constructed by `make-instance' passing the arguments as
- initargs; further behaviour is left to the standard CLOS instance
- construction protocol; for example, `sod-initializer' defines an
+ class and slot types. The default method uses the `:initializer-class'
+ property (defaulting to INIT-CLASS) to choose a (CLOS) class to
+ instantiate. The slot is then constructed by `make-instance' passing the
+ arguments as initargs; further behaviour is left to the standard CLOS
+ instance construction protocol; for example, `sod-initializer' defines an
`:after'-method on `shared-initialize'.
Diagnosing unused properties is left for the caller (usually
This is the main constructor function for messages. This is a generic
function primarily so that the CLASS can intervene in the construction
- process. The default method uses the `:lisp-class' property (defaulting
- to `sod-message') to choose a (CLOS) class to instantiate. The message is
- then constructed by `make-instance' passing the arguments as initargs;
- further behaviour is left to the standard CLOS instance construction
- protocol; for example, `sod-message' defines an `:after'-method on
- `shared-initialize'."))
+ process. The default method uses the `:message-class' property to choose
+ a (CLOS) class to instantiate; if no such property is provided but a
+ `combination' property is present, then `aggregating-message' is chosen;
+ otherwise `standard-message' is used. The message is then constructed by
+ `make-instance' passing the arguments as initargs; further behaviour is
+ left to the standard CLOS instance construction protocol; for example,
+ `sod-message' defines an `:after'-method on `shared-initialize'."))
(export 'make-sod-method)
(defgeneric make-sod-method
This is a generic function so that it can be specialized according to both
a class and -- more particularly -- a message. The default method uses
- the `:lisp-class' property (defaulting to the result of calling
+ the `:method-class' property (defaulting to the result of calling
`sod-message-method-class') to choose a (CLOS) class to instantiate. The
method is then constructed by `make-instance' passing the arguments as
initargs; further behaviour is left to the standard CLOS instance
"Return the preferred class for methods on MESSAGE.
The message can inspect the PSET to decide on a particular message. A
- `:lisp-class' property will usually override this decision: it's then the
- programmer's responsibility to ensure that the selected method class is
- appropriate."))
+ `:method-class' property will usually override this decision: it's then
+ the programmer's responsibility to ensure that the selected method class
+ is appropriate."))
(export 'check-message-type)
(defgeneric check-message-type (message type)
(class :ichains :start) (class :ichains :end)
(class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
(class :conversions)
+ (class :message-macros)
(class :object)
(:classes :end))
(sod-class-nickname super-head))))
(terpri stream)))))
+ ;; Provide convenience macros for sending the newly defined messages. (The
+ ;; macros work on all subclasses too.)
+ ;;
+ ;; We need each message's method entry type for this, so we need to dig it
+ ;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
+ ;; entries for precisely the messages we want to make macros for.
+ (when (sod-class-messages class)
+ (sequence-output (stream sequencer)
+ ((class :message-macros)
+ (let* ((vtable (find (sod-class-chain-head class)
+ (sod-class-vtables class)
+ :key #'vtable-chain-head))
+ (vtmsgs (find-if (lambda (item)
+ (and (typep item 'vtmsgs)
+ (eql (vtmsgs-class item) class)))
+ (vtable-body vtable))))
+ (format stream "/* Message invocation macros. */~%")
+ (dolist (entry (vtmsgs-entries vtmsgs))
+ (let* ((type (method-entry-function-type entry))
+ (args (c-function-arguments type))
+ (in-names nil) (out-names nil) (varargsp nil) (me "me"))
+ (do ((args args (cdr args)))
+ ((endp args))
+ (let* ((raw-name (princ-to-string (argument-name (car args))))
+ (name (if (find raw-name
+ (list "_vt"
+ (sod-class-nickname class)
+ (method-entry-slot-name entry))
+ :test #'string=)
+ (format nil "sod__a_~A" raw-name)
+ raw-name)))
+ (cond ((and (cdr args) (eq (cadr args) :ellipsis))
+ (setf varargsp t)
+ (unless in-names (setf me "SOD__CAR(__VA_ARGS__)"))
+ (push (format nil "/*~A*/ ..." name) in-names)
+ (push "__VA_ARGS__" out-names)
+ (return))
+ (t
+ (push name in-names)
+ (push name out-names)))))
+ (when varargsp
+ (format stream "#if __STDC_VERSION__ >= 199901~%"))
+ (format stream "#define ~A(~{~A~^, ~}) ~
+ ~A->_vt->~A.~A(~{~A~^, ~})~%"
+ (message-macro-name class entry)
+ (nreverse in-names)
+ me
+ (sod-class-nickname class)
+ (method-entry-slot-name entry)
+ (nreverse out-names))
+ (when varargsp
+ (format stream "#endif~%"))))
+ (terpri stream)))))
+
;; Generate vtmsgs structure for all superclasses.
(hook-output (car (sod-class-vtables class))
'vtmsgs
(sequence-output (stream sequencer)
((class :vtmsgs (sod-message-class message) :slots)
(pprint-logical-block (stream nil :prefix " " :suffix ";")
- (pprint-c-type pointer-type stream (sod-message-name message)))
+ (pprint-c-type pointer-type stream (method-entry-slot-name entry)))
(terpri stream)))))
(defmethod hook-output progn ((cptr class-pointer)
(defmethod hook-output progn ((entry method-entry)
(reason (eql :c))
sequencer)
- (with-slots (method chain-head chain-tail) entry
+ (with-slots (method chain-head chain-tail role) entry
(let* ((message (effective-method-message method))
(class (effective-method-class method))
(super (sod-message-class message)))
(sequence-output (stream sequencer)
((class :vtable chain-head :vtmsgs super :slots)
(format stream " /* ~19@A = */ ~A,~%"
- (sod-message-name message)
- (method-entry-function-name method chain-head)))))))
+ (method-entry-slot-name entry)
+ (method-entry-function-name method chain-head role)))))))
;;;--------------------------------------------------------------------------
;;; Filling in the class object.
(and (= (length message-args) (length method-args))
(every (lambda (message-arg method-arg)
(if (eq message-arg :ellipsis)
- (eq method-arg (c-type va-list))
+ (c-type-equal-p (argument-type method-arg)
+ (c-type va-list))
(c-type-equal-p (argument-type message-arg)
(argument-type method-arg))))
message-args method-args)))
(defun vtable-name (class chain-head)
(format nil "~A__vtable_~A" class (sod-class-nickname chain-head)))
+(export 'message-macro-name)
+(defun message-macro-name (class entry)
+ (format nil "~A_~A" class (method-entry-slot-name entry)))
+
;;;----- That's all, folks --------------------------------------------------
(cl:in-package #:sod)
+;;; Note! You'll notice that none of the classes defined here store property
+;;; sets persistently, even though there's a `:pset' keyword argument
+;;; accepted by many of the classes' initialization methods. That's because
+;;; part of the pset protocol involves checking that there are no unused
+;;; properties, and this typically happens shortly after the appropriate
+;;; objects are constructed. It would be tempting to stash the pset at
+;;; initialization time, and then pick some property from it out later -- but
+;;; that won't work in general because an error might have been signalled
+;;; about that property. It wouldn't surprise me greatly to discover that
+;;; `most' code paths resulted in the property being looked up in time to
+;;; avoid the unused-property error, but a subtle change in circumstances
+;;; then causes a thing done on demand to be done later, leading to
+;;; irritating and misleading errors being reported to the user. So please
+;;; don't do that.
+
;;;--------------------------------------------------------------------------
;;; Classes.
computed on demand via methods on `slot-unbound'.
* The ILAYOUT describes the layout for an instance of the class. It's
- quite complicated; see the documentation of the ILAYOUT class for
+ quite complicated; see the documentation of the `ilayout' class for
detais.
* The EFFECTIVE-METHODS are a list of effective methods, specialized for
the class.
* The VTABLES are a list of descriptions of vtables for the class. The
- individual elements are VTABLE objects, which are even more
- complicated than ILAYOUT structures. See the class documentation for
- details."))
+ individual elements are `vtable' objects, which are even more
+ complicated than `ilayout' structures. See the class documentation
+ for details."))
(defmethod print-object ((class sod-class) stream)
(maybe-print-unreadable-object (class stream :type t)
;; Compound statements.
-(export '(if-inst make-if-inst
- while-inst make-while-inst
- do-inst make-do-inst
- inst-condition inst-consequent inst-alternative inst-body))
-
-(definst if (stream) (condition consequent alternative)
+(definst if (stream :export t) (condition consequent alternative)
(format-compound-statement (stream consequent alternative)
(format stream "if (~A)" condition))
(when alternative
(format-compound-statement (stream alternative)
(write-string "else" stream))))
-(definst while (stream) (condition body)
+(definst while (stream :export t) (condition body)
(format-compound-statement (stream body)
(format stream "while (~A)" condition)))
-(definst do-while (stream) (body condition)
+(definst do-while (stream :export t) (body condition)
(format-compound-statement (stream body :space)
(write-string "do" stream))
(format stream "while (~A);" condition))
;; Special varargs hacks.
-(export '(va-start-inst make-va-start-inst
- va-copy-inst make-va-copy-inst
- va-end-inst make-va-end-inst
- inst-ap inst-arg inst-to inst-from))
-
-(definst va-start (stream) (ap arg)
+(definst va-start (stream :export t) (ap arg)
(format stream "va_start(~@<~A, ~_~A~:>);" ap arg))
-(definst va-copy (stream) (to from)
+(definst va-copy (stream :export t) (to from)
(format stream "va_copy(~@<~A, ~_~A~:>);" to from))
-(definst va-end (stream) (ap)
+(definst va-end (stream :export t) (ap)
(format stream "va_end(~A);" ap))
;; Expressions.
-(export '(call-inst make-call-inst inst-func inst-args))
-
-(definst call (stream) (func args)
+(definst call (stream :export t) (func args)
(format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))
;;;--------------------------------------------------------------------------
(defmethod emit-insts ((codegen basic-codegen) insts)
(asetf (codegen-insts codegen) (revappend insts it)))
+(defmethod emit-decl ((codegen basic-codegen) inst)
+ (push inst (codegen-vars codegen)))
+
+(defmethod emit-decls ((codegen basic-codegen) insts)
+ (asetf (codegen-vars codegen) (revappend insts it)))
+
(defmethod ensure-var ((codegen basic-codegen) name type &optional init)
(let* ((vars (codegen-vars codegen))
- (var (find name vars :key #'inst-name :test #'equal)))
+ (var (find name
+ (remove-if-not (lambda (var) (typep var 'var-inst)) vars)
+ :key #'inst-name :test #'equal)))
(cond ((not var)
(setf (codegen-vars codegen)
(cons (make-var-inst name type init) vars)))
(c-type-equal-p type (inst-type var)))
name
nil)))
- vars)
+ (remove-if-not (lambda (var) (typep var 'var-inst)) vars))
(let* ((name (make-instance 'temporary-variable
:in-use-p t
:tag (prog1 temp-index
(make-instance 'temporary-name :tag "sod__ap"))
(defparameter *sod-master-ap*
(make-instance 'temporary-name :tag "sod__master_ap"))
+(defparameter *sod-tmp-ap*
+ (make-instance 'temporary-name :tag "sod__tmp_ap"))
;;;--------------------------------------------------------------------------
;;; Instructions.
;; Instruction definition.
(export 'definst)
-(defmacro definst (code (streamvar) args &body body)
+(defmacro definst (code (streamvar &key export) args &body body)
"Define an instruction type and describe how to output it.
An `inst' can represent any structured piece of output syntax: a
* A print method, which prints a diagnostic dump if `*print-escape*' is
set, or invokes the BODY (with STREAMVAR bound to the output stream)
otherwise. The BODY is expected to produce target code at this
- point."
+ point.
+
+ If EXPORT is non-nil, then export the `CODE-inst' and `make-CODE-inst'
+ symbols."
(let ((inst-var (gensym "INST"))
(class-name (symbolicate code '-inst))
+ (constructor-name (symbolicate 'make- code '-inst))
(keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
args)))
`(progn
,(mapcar (lambda (arg key)
`(,arg :initarg ,key :reader ,(symbolicate 'inst- arg)))
args keys))
- (defun ,(symbolicate 'make- code '-inst) (,@args)
+ (defun ,constructor-name (,@args)
(make-instance ',class-name ,@(mappend #'list keys args)))
(defmethod inst-metric ((,inst-var ,class-name))
(with-slots (,@args) ,inst-var
(print-unreadable-object (,inst-var ,streamvar :type t)
(format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
,@(mappend #'list keys args)))
- (progn ,@body)))))))
+ (progn ,@body))))
+ ,@(and export `((export '(,class-name ,constructor-name))))
+ ',code)))
;; Important instruction classes.
-(export '(block-inst make-block-inst var-inst make-var-inst
- function-inst make-function-inst set-inst make-set-inst
- return-inst make-return-inst expr-inst make-expr-inst
- inst-decls inst-body inst-name inst-type inst-init inst-var
- inst-expr))
-
-(definst var (stream) (name type init)
+(definst var (stream :export t) (name type init)
(pprint-c-type type stream name)
(when init
- (format stream " = ~A" init)))
-(definst set (stream) (var expr)
+ (format stream " = ~A" init))
+ (write-char #\; stream))
+(definst set (stream :export t) (var expr)
(format stream "~@<~A = ~@_~2I~A;~:>" var expr))
-(definst return (stream) (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 expr (stream) (expr)
+(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 block (stream) (decls body)
- (format stream "{~:@_~@< ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
+(definst block (stream :export t) (decls body)
+ (format stream "{~:@_~@< ~2I~@[~{~A~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
decls body))
-(definst function (stream) (name type body)
+(definst function (stream :export t) (name type body)
(pprint-logical-block (stream nil)
(princ "static " stream)
(pprint-c-type type stream name)
(:method (codegen insts)
(dolist (inst insts) (emit-inst codegen inst))))
+(export '(emit-decl emit-decls))
+(defgeneric emit-decl (codegen inst)
+ (:documentation
+ "Add INST to the end of CODEGEN's list of declarations."))
+(defgeneric emit-decls (codegen insts)
+ (:documentation
+ "Add a list of INSTS to the end of CODEGEN's list of declarations."))
+
(export 'codegen-push)
(defgeneric codegen-push (codegen)
(:documentation
;;; -*-lisp-*-
;;;
-;;; Builtin module provides basic definitions
+;;; Debugging utilities for Sod
;;;
-;;; (c) 2009 Straylight/Edgeware
+;;; (c) 2015 Straylight/Edgeware
;;;
;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Simple Object Definition system.
+;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
(cl:in-package #:sod)
-;;;--------------------------------------------------------------------------
-;;; Testing.
+(export '*debugout-pathname*)
+(defvar *debugout-pathname* #p"debugout.c")
-#+test
-(define-sod-class "AbstractStack" ("SodObject")
- :nick 'abstk
- (message "emptyp" (fun int))
- (message "push" (fun void ("item" (* void))))
- (message "pop" (fun (* void)))
- (method "abstk" "pop" (fun void) #{
- assert(!me->_vt.emptyp());
- }
- :role :before))
+(export 'test-module)
+(defun test-module (path reason)
+ "Reset the translator's state, read a module from PATH and output it with
+ REASON, returning the result as a string."
+ (unless *builtin-module* (make-builtin-module))
+ (clear-the-decks)
+ (setf *module-map* (make-hash-table :test #'equal))
+ (with-open-file (out *debugout-pathname*
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (output-module (read-module path) reason out)))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Aggregating method combinations
+;;;
+;;; (c) 2015 Straylight/Edgeware
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This file is part of the Sensble Object Design, an object system for C.
+;;;
+;;; SOD is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; SOD is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with SOD; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:in-package #:sod)
+
+;;;--------------------------------------------------------------------------
+;;; Classes and protocol.
+
+(export 'aggregating-message)
+(defclass aggregating-message (simple-message)
+ ((combination :initarg :combination :type keyword
+ :reader message-combination)
+ (kernel-function :type function :reader message-kernel-function))
+ (:documentation
+ "Message class for aggregating method combinations.
+
+ An aggregating method combination invokes the primary methods in order,
+ most-specific first, collecting their return values, and combining them
+ together in some way to produce a result for the effective method as a
+ whole.
+
+ Mostly, this is done by initializing an accumulator to some appropriate
+ value, updating it with the result of each primary method in turn, and
+ finally returning some appropriate output function of it. The order is
+ determined by the `:most-specific' property, which may have the value
+ `:first' or `:last'.
+
+ The `progn' method combination is implemented as a slightly weird special
+ case of an aggregating method combination with a trivial state. More
+ typical combinations are `:sum', `:product', `:min', `:max', `:and', and
+ `:or'. Finally, there's a `custom' combination which uses user-supplied
+ code fragments to stitch everything together."))
+
+(export 'aggregating-message-properties)
+(defgeneric aggregating-message-properties (message combination)
+ (:documentation
+ "Return a description of the properties needed by the method COMBINATION.
+
+ The description should be a plist of alternating property name and type
+ keywords. The named properties will be looked up in the pset supplied at
+ initialization time, and supplied to `compute-aggregating-message-kernel'
+ as keyword arguments. Defaults can be supplied in method BVLs.
+
+ The default is not to capture any property values.
+
+ The reason for this is as not to retain the pset beyond message object
+ initialization.")
+ (:method (message combination) nil))
+
+(export 'compute-aggregating-message-kernel)
+(defgeneric compute-aggregating-message-kernel
+ (message combination codegen target methods arg-names &key)
+ (:documentation
+ "Determine how to aggregate the direct methods for an aggregating message.
+
+ The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
+ METHODS): it should emit, to CODEGEN, an appropriate effective-method
+ kernel which invokes the listed direct METHODS, in the appropriate order,
+ collects and aggregates their values, and delivers to TARGET the final
+ result of the method kernel.
+
+ The easy way to implement this method is to use the macro
+ `define-aggregating-method-combination'."))
+
+(export 'check-aggregating-message-type)
+(defgeneric check-aggregating-message-type (message combination type)
+ (:documentation
+ "Check that TYPE is an acceptable function TYPE for the COMBINATION.
+
+ For example, `progn' messages must return `void', while `and' and `or'
+ messages must return `int'.")
+ (:method (message combination type)
+ t))
+
+(export 'aggregating-effective-method)
+(defclass aggregating-effective-method (simple-effective-method) ()
+ (:documentation "Effective method counterpart to `aggregating-message'."))
+
+;;;--------------------------------------------------------------------------
+;;; Implementation.
+
+(defmethod check-message-type ((message aggregating-message) type)
+ (with-slots (combination) message
+ (check-aggregating-message-type message combination type)))
+
+(defmethod message-effective-method-class ((message aggregating-message))
+ 'aggregating-effective-method)
+
+(defmethod simple-method-body
+ ((method aggregating-effective-method) codegen target)
+ (let ((argument-names (effective-method-basic-argument-names method))
+ (primary-methods (effective-method-primary-methods method)))
+ (funcall (message-kernel-function (effective-method-message method))
+ codegen target argument-names primary-methods)))
+
+(defmethod shared-initialize :before
+ ((message aggregating-message) slot-names &key pset)
+ (declare (ignore slot-names))
+ (with-slots (combination kernel-function) message
+ (let ((most-specific (get-property pset :most-specific :keyword :first))
+ (comb (get-property pset :combination :keyword)))
+
+ ;; Check that we've been given a method combination and make sure it
+ ;; actually exists.
+ (unless comb
+ (error "The `combination' property is required."))
+ (unless (some (lambda (method)
+ (let* ((specs (method-specializers method))
+ (message-spec (car specs))
+ (combination-spec (cadr specs)))
+ (and (typep message-spec 'class)
+ (typep message message-spec)
+ (typep combination-spec 'eql-specializer)
+ (eq (eql-specializer-object combination-spec)
+ comb))))
+ (generic-function-methods
+ #'compute-aggregating-message-kernel))
+ (error "Unknown method combination `~(~A~)'." comb))
+ (setf combination comb)
+
+ ;; Make sure the ordering is actually valid.
+ (unless (member most-specific '(:first :last))
+ (error "The `most_specific' property must be `first' or `last'."))
+
+ ;; Set up the function which will compute the kernel.
+ (let ((magic (cons nil nil))
+ (keys nil))
+
+ ;; Collect the property values wanted by the method combination.
+ (do ((want (aggregating-message-properties message comb)
+ (cddr want)))
+ ((endp want))
+ (let* ((name (car want))
+ (type (cadr want))
+ (prop (get-property pset name type magic)))
+ (unless (eq prop magic)
+ (setf keys (list* name prop keys)))))
+
+ ;; Set the kernel function for later.
+ (setf kernel-function
+ (lambda (codegen target arg-names methods)
+ (apply #'compute-aggregating-message-kernel
+ message comb
+ codegen target
+ (ecase most-specific
+ (:first methods)
+ (:last (setf methods (reverse methods))))
+ arg-names
+ keys)))))))
+
+;;;--------------------------------------------------------------------------
+;;; Utilities.
+
+(export 'define-aggregating-method-combination)
+(defmacro define-aggregating-method-combination
+ (comb
+ (vars
+ &key (codegen (gensym "CODEGEN-"))
+ (methods (gensym "METHODS-")))
+ &key properties return-type
+ ((:around around-func) '#'funcall)
+ ((:first-method first-method-func) nil firstp)
+ ((:methods methods-func) '#'funcall))
+ "Utility macro for definining aggregating method combinations.
+
+ The VARS are a list of variable names to be bound to temporary variable
+ objects of the method's return type. Additional keyword arguments define
+ variables names to be bound to other possibly interesting values:
+
+ * CODEGEN is the `codegen' object passed at effective-method computation
+ time; and
+
+ * METHODS is the list of primary methods, in the order in which they
+ should be invoked. Note that this list must be non-empty, since
+ otherwise the method on `compute-effective-method-body' specialized to
+ `simple-effective-method' will suppress the method entirely.
+
+ The PROPERTIES, if specified, are a list of properties to be collected
+ during message-object initialization; items in the list have the form
+
+ (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])
+
+ similar to a `&key' BVL entry, except for the additional TYPE entry. In
+ particular, a symbolic NAME may be written in place of a singleton list.
+ The KEYWORD names the property as it should be looked up in the pset,
+ while the NAME names a variable to which the property value or default is
+ bound.
+
+ All of these variables, and the VARS, are available in the functions
+ described below.
+
+ If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
+ on `check-aggregating-message-type' to check the that the message's return
+ type matches RETURN-TYPE.
+
+ The AROUND, FIRST-METHOD, and METHODS are function designators (probably
+ `lambda' forms) providing pieces of the aggregating behaviour.
+
+ The AROUND function is called first, with a single argument BODY, though
+ the variables above are also in scope. It is expected to emit code to
+ CODEGEN which invokes the METHODS in the appropriate order, and arranges
+ to store the aggregated return value in the first of the VARS.
+
+ It may call BODY as a function in order to assist with this; let ARGS be
+ the list of arguments supplied to it. The default behaviour is to call
+ BODY with no arguments. The BODY function first calls FIRST-METHOD,
+ passing it as arguments a function INVOKE and the ARGS which were passed
+ to BODY, and then calls METHODS once for each remaining method, again
+ passing an INVOKE function and the ARGS. If FIRST-METHOD is not
+ specified, then the METHODS function is used for all of the methods. If
+ METHODS is not specified, then the behaviour is simply to call INVOKE
+ immediately. (See the definition of the `:progn' method combination.)
+
+ Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
+ the appropriate direct method and deliver its return value to TARGET,
+ which defaults to `:void'."
+
+ (with-gensyms (type msg combvar target arg-names args want-type
+ meth targ func call-methfunc
+ aroundfunc fmethfunc methfunc)
+ `(progn
+
+ ;; If properties are listed, arrange for them to be collected.
+ ,@(and properties
+ `((defmethod aggregating-message-properties
+ ((,msg aggregating-message) (,combvar (eql ',comb)))
+ ',(mapcan (lambda (prop)
+ (list (let* ((name (car prop))
+ (names (if (listp name) name
+ (list name))))
+ (if (cddr names) (car names)
+ (intern (car names) :keyword)))
+ (cadr prop)))
+ properties))))
+
+ ;; If a particular return type is wanted, check that.
+ ,@(and return-type
+ `((defmethod check-aggregating-message-type
+ ((,msg aggregating-message)
+ (,combvar (eql ',comb))
+ (,type c-function-type))
+ (let ((,want-type (c-type ,return-type)))
+ (unless (c-type-equal-p (c-type-subtype ,type)
+ ,want-type)
+ (error "Messages with `~(~A~)' combination ~
+ must return `~A'."
+ ,combvar ,want-type)))
+ (call-next-method))))
+
+ ;; Define the main kernel-compuation method.
+ (defmethod compute-aggregating-message-kernel
+ ((,msg aggregating-message) (,combvar (eql ',comb))
+ ,codegen ,target ,methods ,arg-names
+ &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
+ properties))
+ (declare (ignore ,combvar))
+
+ ;; Declare the necessary variables and give names to the functions
+ ;; supplied by the caller.
+ (let* (,@(and vars
+ `((,type (c-type-subtype (sod-message-type ,msg)))))
+ ,@(mapcar (lambda (var)
+ (list var `(temporary-var ,codegen ,type)))
+ vars)
+ (,aroundfunc ,around-func)
+ (,methfunc ,methods-func)
+ (,fmethfunc ,(if firstp first-method-func methfunc)))
+
+ ;; Arrange to release the temporaries when we're finished with
+ ;; them.
+ (unwind-protect
+ (progn
+
+ ;; Wrap the AROUND function around most of the work.
+ (funcall ,aroundfunc
+ (lambda (&rest ,args)
+ (flet ((,call-methfunc (,func ,meth)
+ ;; Call FUNC, passing it an INVOKE
+ ;; function which will generate a call
+ ;; to METH.
+ (apply ,func
+ (lambda
+ (&optional (,targ :void))
+ (invoke-method ,codegen
+ ,targ
+ ,arg-names
+ ,meth))
+ ,args)))
+
+ ;; The first method might need special
+ ;; handling.
+ (,call-methfunc ,fmethfunc (car ,methods))
+
+ ;; Call the remaining methods in the right
+ ;; order.
+ (dolist (,meth (cdr ,methods))
+ (,call-methfunc ,methfunc ,meth)))))
+
+ ;; Outside the AROUND function now, deliver the final
+ ;; result to the right place.
+ (deliver-expr ,codegen ,target ,(car vars)))
+
+ ;; Finally, release the temporary variables.
+ ,@(mapcar (lambda (var) `(setf (var-in-use-p ,var) nil))
+ vars))))
+
+ ',comb)))
+
+;;;--------------------------------------------------------------------------
+;;; Fixed aggregating method combinations.
+
+(define-aggregating-method-combination :progn (nil)
+ :return-type void)
+
+(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
+ :first-method (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-set-inst acc val)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-update-inst acc #\+ val))))
+
+(define-aggregating-method-combination :product ((acc val) :codegen codegen)
+ :first-method (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-set-inst acc val)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-update-inst acc #\* val))))
+
+(define-aggregating-method-combination :min ((acc val) :codegen codegen)
+ :first-method (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-set-inst acc val)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
+ (make-set-inst acc val) nil))))
+
+(define-aggregating-method-combination :max ((acc val) :codegen codegen)
+ :first-method (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-set-inst acc val)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
+ (make-set-inst acc val) nil))))
+
+(define-aggregating-method-combination :and ((ret val) :codegen codegen)
+ :return-type int
+ :around (lambda (body)
+ (codegen-push codegen)
+ (deliver-expr codegen ret 0)
+ (funcall body)
+ (deliver-expr codegen ret 1)
+ (emit-inst codegen
+ (make-do-while-inst (codegen-pop-block codegen) 0)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst (format nil "!~A" val)
+ (make-break-inst) nil))))
+
+(define-aggregating-method-combination :or ((ret val) :codegen codegen)
+ :return-type int
+ :around (lambda (body)
+ (codegen-push codegen)
+ (deliver-expr codegen ret 1)
+ (funcall body)
+ (deliver-expr codegen ret 0)
+ (emit-inst codegen
+ (make-do-while-inst (codegen-pop-block codegen) 0)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
+
+;;;--------------------------------------------------------------------------
+;;; A customizable aggregating method combination.
+
+(defmethod aggregating-message-properties
+ ((message aggregating-message) (combination (eql :custom)))
+ '(:retvar :id
+ :valvar :id
+ :decls :fragment
+ :before :fragment
+ :first :fragment
+ :each :fragment
+ :after :fragment
+ :count :id))
+
+(defmethod compute-aggregating-message-kernel
+ ((message aggregating-message) (combination (eql :custom))
+ codegen target methods arg-names
+ &key (retvar "sod_ret") (valvar "sod_val")
+ decls before each (first each) after count)
+ (let* ((type (c-type-subtype (sod-message-type message)))
+ (not-void-p (not (eq type c-type-void))))
+ (when not-void-p
+ (ensure-var codegen retvar type)
+ (ensure-var codegen valvar type))
+ (when count
+ (ensure-var codegen count c-type-int (length methods)))
+ (when decls
+ (emit-decl codegen decls))
+ (labels ((maybe-emit (fragment)
+ (when fragment (emit-inst codegen fragment)))
+ (invoke (method fragment)
+ (invoke-method codegen (if not-void-p valvar :void)
+ arg-names method)
+ (maybe-emit fragment)))
+ (maybe-emit before)
+ (invoke (car methods) first)
+ (dolist (method (cdr methods)) (invoke method each))
+ (maybe-emit after)
+ (deliver-expr codegen target retvar))))
+
+;;;----- That's all, folks --------------------------------------------------
(call-next-method)
(primary-method-class message)))
+(defmethod primary-method-class ((message simple-message))
+ 'basic-direct-method)
+
;;;--------------------------------------------------------------------------
;;; Direct method classes.
(slot-name (eql 'next-method-type)))
(declare (ignore class))
(let* ((message (sod-method-message method))
- (type (sod-message-type message)))
+ (return-type (c-type-subtype (sod-message-type message)))
+ (msgargs (sod-message-argument-tail message))
+ (arguments (if (varargs-message-p message)
+ (cons (make-argument *sod-master-ap*
+ (c-type va-list))
+ (butlast msgargs))
+ msgargs)))
(setf (slot-value method 'next-method-type)
- (c-type (fun (lisp (c-type-subtype type))
+ (c-type (fun (lisp return-type)
("me" (* (class (sod-method-class method))))
- .
- (c-function-arguments type))))))
+ . arguments)))))
(defmethod slot-unbound (class
(method delegating-direct-method)
(declare (ignore class))
(let ((message (effective-method-message method)))
(setf (slot-value method 'basic-argument-names)
- (subst *sod-master-ap* *sod-ap*
- (mapcar #'argument-name
- (sod-message-no-varargs-tail message))))))
+ (mapcar #'argument-name
+ (sod-message-no-varargs-tail message)))))
(defmethod effective-method-function-name ((method effective-method))
(let* ((class (effective-method-class method))
method
(let* ((message-type (sod-message-type message))
(return-type (c-type-subtype message-type))
- (voidp (eq return-type (c-type void)))
(basic-tail (effective-method-basic-argument-names method)))
(flet ((method-kernel (target)
(dolist (before before-methods)
(invoke-method codegen :void basic-tail before))
- (if (or voidp (null after-methods))
+ (if (null after-methods)
(funcall body target)
(convert-stmts codegen target return-type
(lambda (target)
(funcall body target)
(dolist (after (reverse after-methods))
(invoke-method codegen :void
- after basic-tail)))))))
+ basic-tail after)))))))
(invoke-delegation-chain codegen target basic-tail
around-methods #'method-kernel)))))
effective method out into its own function.")
(defmethod method-entry-function-name
- ((method effective-method) (chain-head sod-class))
+ ((method effective-method) (chain-head sod-class) role)
(let* ((class (effective-method-class method))
(message (effective-method-message method))
(message-class (sod-message-class message)))
(if (or (not (slot-boundp method 'functions))
(slot-value method 'functions))
- (format nil "~A__mentry_~A__~A__chain_~A"
- class
+ (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A"
+ class role
(sod-class-nickname message-class)
(sod-message-name message)
(sod-class-nickname chain-head))
0)))
+(defmethod method-entry-slot-name ((entry method-entry))
+ (let* ((method (method-entry-effective-method entry))
+ (message (effective-method-message method))
+ (name (sod-message-name message))
+ (role (method-entry-role entry)))
+ (method-entry-slot-name-by-role entry role name)))
+
(defmethod method-entry-function-type ((entry method-entry))
(let* ((method (method-entry-effective-method entry))
(message (effective-method-message method))
- (type (sod-message-type message)))
+ (type (sod-message-type message))
+ (tail (ecase (method-entry-role entry)
+ ((nil) (sod-message-argument-tail message))
+ (:valist (sod-message-no-varargs-tail message)))))
(c-type (fun (lisp (c-type-subtype type))
("me" (* (class (method-entry-chain-tail entry))))
- . (sod-message-argument-tail message)))))
-
-(defmethod make-method-entry ((method basic-effective-method)
- (chain-head sod-class) (chain-tail sod-class))
- (make-instance 'method-entry
- :method method
- :chain-head chain-head
- :chain-tail chain-tail))
+ . tail))))
+
+(defmethod make-method-entries ((method basic-effective-method)
+ (chain-head sod-class)
+ (chain-tail sod-class))
+ (let ((entries nil)
+ (message (effective-method-message method)))
+ (flet ((make (role)
+ (push (make-instance 'method-entry
+ :method method :role role
+ :chain-head chain-head
+ :chain-tail chain-tail)
+ entries)))
+ (when (varargs-message-p message) (make :valist))
+ (make nil)
+ entries)))
(defmethod compute-method-entry-functions ((method basic-effective-method))
:class class
:method method))
- ;; Effective method function details.
- (emf-name (effective-method-function-name method))
- (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
- (emf-arg-tail (mapcar (lambda (arg)
- (if (eq (argument-name arg) *sod-ap*)
- (make-argument *sod-master-ap*
- (c-type va-list))
- arg))
- (sod-message-no-varargs-tail message)))
- (emf-type (c-type (fun (lisp return-type)
- ("sod__obj" (lisp ilayout-type))
- . (sod-message-no-varargs-tail message))))
-
;; Method entry details.
(chain-tails (remove-if-not (lambda (super)
(sod-subclass-p super message-class))
(mapcar #'car
(sod-class-chains class))))
(n-entries (length chain-tails))
- (entry-args (sod-message-argument-tail message))
- (parm-n (do ((prev "me" (car args))
- (args entry-args (cdr args)))
- ((endp args) nil)
- (when (eq (car args) :ellipsis)
- (return prev))))
- (entry-target (codegen-target codegen)))
+ (raw-entry-args (sod-message-argument-tail message))
+ (entry-args (sod-message-no-varargs-tail message))
+ (parm-n (let ((tail (last raw-entry-args 2)))
+ (and tail (eq (cadr tail) :ellipsis) (car tail))))
+ (entry-target (codegen-target codegen))
+
+ ;; Effective method function details.
+ (emf-name (effective-method-function-name method))
+ (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
+ (emf-arg-tail (sod-message-no-varargs-tail message))
+ (emf-type (c-type (fun (lisp return-type)
+ ("sod__obj" (lisp ilayout-type))
+ . emf-arg-tail))))
(flet ((setup-entry (tail)
(let ((head (sod-class-chain-head tail)))
(ensure-var codegen "sod__obj" ilayout-type
(make-convert-to-ilayout-inst class
head "me"))))
- (varargs-prologue ()
- (ensure-var codegen *sod-master-ap* (c-type va-list))
- (emit-inst codegen
- (make-va-start-inst *sod-master-ap* parm-n)))
- (varargs-epilogue ()
- (emit-inst codegen (make-va-end-inst *sod-master-ap*)))
(finish-entry (tail)
(let* ((head (sod-class-chain-head tail))
- (name (method-entry-function-name method head))
+ (role (if parm-n :valist nil))
+ (name (method-entry-function-name method head role))
(type (c-type (fun (lisp return-type)
("me" (* (class tail)))
. entry-args))))
- (codegen-pop-function codegen name type))))
+ (codegen-pop-function codegen name type)
+
+ ;; If this is a varargs method then we've made the
+ ;; `:valist' role. Also make the `nil' role.
+ (when parm-n
+ (let ((call (make-call-inst name
+ (cons "me"
+ (mapcar #'argument-name
+ entry-args))))
+ (main (method-entry-function-name method head nil))
+ (main-type (c-type (fun (lisp return-type)
+ ("me" (* (class tail)))
+ . raw-entry-args))))
+ (codegen-push codegen)
+ (ensure-var codegen *sod-ap* (c-type va-list))
+ (emit-inst codegen
+ (make-va-start-inst *sod-ap*
+ (argument-name parm-n)))
+ (convert-stmts codegen entry-target return-type
+ (lambda (target)
+ (deliver-expr codegen target call)))
+ (emit-inst codegen (make-va-end-inst *sod-ap*))
+ (codegen-pop-function codegen main main-type))))))
;; Generate the method body. We'll work out what to do with it later.
(codegen-push codegen)
- (let* ((result (if (eq return-type (c-type void)) nil
+ (let* ((result (if (eq return-type c-type-void) nil
(temporary-var codegen return-type)))
(emf-target (or result :void)))
(compute-effective-method-body method codegen emf-target)
(dolist (tail chain-tails)
(setup-entry tail)
(dolist (var vars)
- (ensure-var codegen (inst-name var)
- (inst-type var) (inst-init var)))
- (when parm-n (varargs-prologue))
+ (if (typep var 'var-inst)
+ (ensure-var codegen (inst-name var)
+ (inst-type var) (inst-init var))
+ (emit-decl codegen var)))
(emit-insts codegen insts)
- (when parm-n (varargs-epilogue))
(deliver-expr codegen entry-target result)
(finish-entry tail)))
emf-arg-tail)))))
(dolist (tail chain-tails)
(setup-entry tail)
- (cond (parm-n
- (varargs-prologue)
- (convert-stmts codegen entry-target return-type
- (lambda (target)
- (deliver-expr codegen
- target call)
- (varargs-epilogue))))
- (t
- (deliver-expr codegen entry-target call)))
+ (deliver-expr codegen entry-target call)
(finish-entry tail)))))))
(codegen-functions codegen))))
(defmethod compute-effective-method-body
((method simple-effective-method) codegen target)
- (with-slots (message basic-argument-names primary-methods) method
- (basic-effective-method-body codegen target method
- (lambda (target)
- (simple-method-body method
- codegen
- target)))))
+ (basic-effective-method-body codegen target method
+ (lambda (target)
+ (simple-method-body method
+ codegen
+ target))))
;;;--------------------------------------------------------------------------
;;; Standard method combination.
(defclass standard-message (simple-message)
()
(:documentation
- "Message class for standard method combination.
+ "Message class for standard method combinations.
Standard method combination is a simple method combination where the
primary methods are invoked as a delegation chain, from most- to
(chain-head :initarg :chain-head :type sod-class
:reader method-entry-chain-head)
(chain-tail :initarg :chain-tail :type sod-class
- :reader method-entry-chain-tail))
+ :reader method-entry-chain-tail)
+ (role :initarg :role :type (or :keyword null) :reader method-entry-role))
(:documentation
"An entry point into an effective method.
- Specifically, this is the entry point to the effective method METHOD
- invoked via the vtable for the chain headed by CHAIN-HEAD. The CHAIN-TAIL
- is the most specific class on this chain; this is useful because we can
- reuse the types of method entries from superclasses on non-primary chains.
+ Specifically, this is the entry point to the effective METHOD invoked via
+ the vtable for the chain headed by CHAIN-HEAD, and serving the given ROLE.
+ The CHAIN-TAIL is the most specific class on this chain; this is useful
+ because we can reuse the types of method entries from superclasses on
+ non-primary chains.
Each effective method may have several different method entries, because
an effective method can be called via vtables attached to different
job of the method entry to adjust the instance pointers correctly for the
rest of the effective method.
+ A vtable can contain more than one entry for the same message. Such
+ entries are distinguished by their roles. A message always has an entry
+ with the `nil role; in addition, a varargs message also has a `:valist'
+ role, which accepts a `va_list' argument in place of the variable argument
+ listNo other roles are currently defined, though they may be introduced by
+ extensions.
+
The boundaries between a method entry and the effective method
is (intentionally) somewhat fuzzy. In extreme cases, the effective method
may not exist at all as a distinct entity in the output because its
content is duplicated in all of the method entry functions. This is left
up to the effective method protocol."))
-(export 'make-method-entry)
-(defgeneric make-method-entry (effective-method chain-head chain-tail)
+(export 'make-method-entries)
+(defgeneric make-method-entries (effective-method chain-head chain-tail)
(:documentation
- "Return a METHOD-ENTRY for an EFFECTIVE-METHOD called via CHAIN-HEAD.
+ "Return a list of `method-entry' objects for an EFFECTIVE-METHOD called
+ via CHAIN-HEAD.
There is no default method for this function. (Maybe when the
effective-method/method-entry output protocol has settled down I'll know
(:documentation
"Return the C function type for a method entry."))
+(export 'method-entry-slot-name)
+(defgeneric method-entry-slot-name (entry)
+ (:documentation
+ "Return the `vtmsgs' slot name for a method entry.
+
+ The default method indirects through `method-entry-slot-name-by-role'."))
+
+(defgeneric method-entry-slot-name-by-role (entry role name)
+ (:documentation "Easier implementation for `method-entry-slot-name'.")
+ (:method ((entry method-entry) (role (eql nil)) name) name)
+ (:method ((entry method-entry) (role (eql :valist)) name)
+ (format nil "~A__v" name)))
+
(export 'effective-method-basic-argument-names)
(defgeneric effective-method-basic-argument-names (method)
(:documentation
CLASS where CLASS is the class on which the method was defined.
If the message accepts a variable-length argument list then a copy of the
- prevailing master argument pointer is provided in place of the
- `:ellipsis'."
+ prevailing argument pointer is provided in place of the `:ellipsis'."
(let* ((message (sod-method-message direct-method))
(class (sod-method-class direct-method))
(convert-stmts codegen target
(c-type-subtype (sod-method-type direct-method))
(lambda (var)
- (ensure-var codegen *sod-ap* (c-type va-list))
+ (ensure-var codegen *sod-tmp-ap* (c-type va-list))
(emit-inst codegen
- (make-va-copy-inst *sod-ap*
- *sod-master-ap*))
+ (make-va-copy-inst *sod-tmp-ap*
+ *sod-ap*))
(deliver-expr codegen var
(make-call-inst function arguments))
(emit-inst codegen
- (make-va-end-inst *sod-ap*))))
+ (make-va-end-inst *sod-tmp-ap*))))
(deliver-expr codegen target (make-call-inst function arguments)))))
(export 'ensure-ilayout-var)
(let* ((message (codegen-message codegen))
(message-type (sod-message-type message))
(return-type (c-type-subtype message-type))
- (arguments (mapcar (lambda (arg)
- (if (eq (argument-name arg) *sod-ap*)
- (make-argument *sod-master-ap*
- (c-type va-list))
- arg))
- (sod-message-no-varargs-tail message))))
+ (raw-args (sod-message-argument-tail message))
+ (arguments (if (varargs-message-p message)
+ (cons (make-argument *sod-ap*
+ (c-type va-list))
+ (butlast raw-args))
+ raw-args)))
(codegen-push codegen)
(ensure-ilayout-var codegen super)
(funcall body (codegen-target codegen))
"Returns the function name of an effective method."))
(export 'method-entry-function-name)
-(defgeneric method-entry-function-name (method chain-head)
+(defgeneric method-entry-function-name (method chain-head role)
(:documentation
"Returns the function name of a method entry.
- The method entry is given as an effective method/chain-head pair, rather
- than as a method entry object because we want the function name before
- we've made the entry object."))
+ The method entry is given as an effective method/chain-head/role triple,
+ rather than as a method entry object because we want the function name
+ before we've made the entry object."))
(export 'compute-method-entry-functions)
(defgeneric compute-method-entry-functions (method)
(let* ((message (codegen-message codegen))
(argument-tail (if (varargs-message-p message)
- (cons *sod-master-ap* basic-tail)
+ (cons *sod-tmp-ap* basic-tail)
basic-tail)))
(labels ((next-trampoline (method chain)
(if (or kernel chain)
(defmethod finalize-module ((module module))
(let* ((pset (module-pset module))
- (class (get-property pset :lisp-class :symbol 'module)))
+ (class (get-property pset :module-class :symbol 'module)))
;; Always call `change-class', even if it's the same one; this will
;; exercise the property-set fiddling in `shared-initialize' and we can
(line (file-location-line location))
(filename (file-location-filename location)))
(cond (line
- (format stream "~&#line ~D~@[ ~S~]~%" line filename)
+ (when (typep stream 'position-aware-stream)
+ (format stream "~&#line ~D~@[ ~S~]~%" line filename))
(funcall thunk)
(when (typep stream 'position-aware-stream)
(fresh-line stream)
(:guard :start)
(:typedefs :start) :typedefs (:typedefs :end)
(:includes :start) :includes (:includes :end)
- (:classes :start) :classes (:classes :end)
+ (:classes :start) (:classes :end)
(:guard :end)
:epilogue)
(parse-message-item (sub-pset type name)
;; message-item ::=
;; declspec+ declarator -!- (method-body | `;')
- (make-sod-message class name type sub-pset scanner)
- (parse (or #\; (parse-method-item sub-pset
- type nick name))))
+ ;;
+ ;; Don't allow a method-body here if the message takes a
+ ;; varargs list, because we don't have a name for the
+ ;; `va_list' parameter.
+ (let ((message (make-sod-message class name type
+ sub-pset scanner)))
+ (if (varargs-message-p message)
+ (parse #\;)
+ (parse (or #\; (parse-method-item sub-pset
+ type nick name))))))
(parse-method-item (sub-pset type sub-nick name)
;; method-item ::=
;; (which might be dotted). So we parse that here and
;; dispatch based on what we find.
(parse (or (plug class-item scanner class sub-pset)
- ;(peek
+ (peek
(seq ((ds (parse-c-type scanner))
(dc (parse-maybe-dotted-declarator ds))
(nil (class-item-dispatch sub-pset
ds
(car dc)
- (cdr dc)))));)
+ (cdr dc))))))
(and "class"
(parse-initializer-item
sub-pset
During module construction, this is always an instance of `module'. Once
we've finished constructing it, we'll call `change-class' to turn it into
- an instance of whatever type is requested in the module's `:lisp-class'
+ an instance of whatever type is requested in the module's `:module-class'
property.")
(export 'module-import)
This isn't necessary if you made the module by hand. If you've
constructed it incrementally, then it might be a good plan. In
particular, it will change the class (using `change-class') of the module
- according to the class choice set in the module's `:lisp-class' property.
- This has the side effects of calling `shared-initialize', setting the
- module's state to `t', and checking for unrecognized
+ according to the class choice set in the module's `:module-class'
+ property. This has the side effects of calling `shared-initialize',
+ setting the module's state to `t', and checking for unrecognized
properties. (Therefore subclasses should add a method to
`shared-initialize' taking care of looking at interesting properties, just
to make sure they're ticked off.)"))
(once-only (string value winp consumedp)
(with-gensyms (my-value my-winp my-consumedp label what)
`(let ((,scanner (make-string-scanner ,string)))
+ (declare (ignorable ,scanner))
(multiple-value-bind (,my-value ,my-winp ,my-consumedp)
(with-parser-context
(character-scanner-context :scanner ,scanner)
;;;--------------------------------------------------------------------------
;;; Test expression parser.
-(defparse token (:context (context character-parser-context) parser)
- (with-gensyms (value)
- (expand-parser-spec context
- `(seq ((,value ,parser) :whitespace) ,value))))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defparse token (:context (context character-parser-context) parser)
+ (with-gensyms (value)
+ (expand-parser-spec context
+ `(seq ((,value ,parser) :whitespace) ,value)))))
(let ((add (binop "+" (x y 5) `(+ ,x ,y)))
(sub (binop "-" (x y 5) `(- ,x ,y)))
(buf nil :type (or charbuf (member nil :eof)) :read-only t)
(size 0 :type charbuf-index :read-only t))
-(export 'charbuf-scanner-place-p)
-(defstruct charbuf-scanner-place
- "A captured place we can return to later.
-
- We remember the buffer-chain link, so that we can retrace our steps up to
- the present. We also need the index at which we continue reading
- characters; and the line and column numbers to resume from."
- (scanner nil :type charbuf-scanner :read-only t)
- (link nil :type charbuf-chain-link :read-only t)
- (index 0 :type charbuf-index :read-only t)
- (line 0 :type fixnum :read-only t)
- (column 0 :type fixnum :read-only t))
-
-(defmethod file-location ((place charbuf-scanner-place))
- (make-file-location (scanner-filename
- (charbuf-scanner-place-scanner place))
- (charbuf-scanner-place-line place)
- (charbuf-scanner-place-column place)))
-
;;;--------------------------------------------------------------------------
;;; Main class.
captured places properly when he's finished. In practice, this is usually
done using the `peek' parser macro so there isn't a problem."))
+(export 'charbuf-scanner-place-p)
+(defstruct charbuf-scanner-place
+ "A captured place we can return to later.
+
+ We remember the buffer-chain link, so that we can retrace our steps up to
+ the present. We also need the index at which we continue reading
+ characters; and the line and column numbers to resume from."
+ (scanner nil :type charbuf-scanner :read-only t)
+ (link nil :type charbuf-chain-link :read-only t)
+ (index 0 :type charbuf-index :read-only t)
+ (line 0 :type fixnum :read-only t)
+ (column 0 :type fixnum :read-only t))
+
+(defmethod file-location ((place charbuf-scanner-place))
+ (make-file-location (scanner-filename
+ (charbuf-scanner-place-scanner place))
+ (charbuf-scanner-place-line place)
+ (charbuf-scanner-place-column place)))
+
;;;--------------------------------------------------------------------------
;;; Utilities.
expression: term | expression `+' term | expression `-' term
term: factor | term `*' factor | term `/' factor
factor: primary | `+' factor | `-' factor
- primary: int | id | string | `(' expression `)' | `?' lisp-expression
+ primary: int | id | string | `(' expression `)' | `{' fragment `}'
+ | `?' lisp-expression
Only operators for dealing with integers are provided."
(with-parser-context (token-scanner-context :scanner scanner)
(multiple-value-bind (type value)
(decode-property sexp)
(values (cons type value) t t))))
+ (#\{
+ (values (cons :fragment
+ (parse-delimited-fragment scanner
+ #\{ #\}))
+ t t))
(t
(values (list :int :id :char :string #\?)
nil nil)))))
;;; Testing.
(defmethod perform ((op test-op) (system (eql (find-system "sod-test"))))
- (operate 'load-op system)
- (funcall (find-symbol "RUN-TESTS" "SOD-TEST")))
-
-;;;--------------------------------------------------------------------------
-;;; Hacks.
-
-(defmethod perform :around
- ((op compile-op) (component (eql (find-system "sod-test"))))
- (let ((*compile-file-failure-behaviour* :warn))
- (call-next-method)))
+ (handler-bind (((or warning style-warning)
+ (lambda (cond)
+ (declare (ignore cond))
+ (invoke-restart 'muffle-warning))))
+ (operate 'load-op system)
+ (let ((result (funcall (find-symbol "RUN-TESTS" "SOD-TEST"))))
+ (unless (funcall (find-symbol "WAS-SUCCESSFUL" "XLUNIT") result)
+ (error "Failed test")))))
;;;----- That's all, folks --------------------------------------------------
(defsystem sod
;; Boring copyright stuff.
- :version "0.1.0"
+ :version "0.2.0"
:author "Mark Wooding"
:license "GNU General Public License, version 2 or later"
(:file "class-finalize-impl" :depends-on ("class-finalize-proto"))
;; Method generation.
- (:file "method-proto" :depends-on ("class-utilities"))
+ (:file "method-proto" :depends-on ("class-make-proto"))
(:file "method-impl" :depends-on ("method-proto"))
+ (:file "method-aggregate" :depends-on ("method-impl"))
;; Class output.
(:file "class-output" :depends-on
- ("classes" "class-layout-proto" "class-layout-impl"
- "method-proto" "method-impl" "output-proto"))))
+ ("classes" "class-layout-impl" "method-impl" "output-proto"))
+
+ ;; Debugging and interactive testing.
+ (:file "debug" :depends-on ("builtin" "module-output"))))
;;;--------------------------------------------------------------------------
;;; Testing.
(defmethod perform ((op test-op) (component (eql (find-system "sod"))))
(declare (ignore op component))
- (operate 'test-op "sod-test" :force t))
+ (handler-bind (((or warning style-warning)
+ (lambda (cond)
+ (declare (ignore cond))
+ (invoke-restart 'muffle-warning))))
+ (operate 'test-op "sod-test")))
;;;----- That's all, folks --------------------------------------------------
rather than `~A'."
object print string))))
+(defclass base-test (test-case) ())
+(add-test *sod-test-suite* (get-suite base-test))
+
+(export '*build-version*)
+(defvar *build-version* nil)
+
+(def-test-method check-version ((test base-test) :run nil)
+ (unless (or (null *build-version*)
+ (and (>= (length *build-version*) (length *sod-version*))
+ (string= *build-version* *sod-version*
+ :end1 (length *sod-version*))))
+ (failure "Build version ~A doesn't match package version ~A."
+ *build-version* *sod-version*)))
+
(defun run-tests (&optional which)
(textui-test-run (acond
((null which) *sod-test-suite*)
--- /dev/null
+### -*-makefile-*-
+###
+### Build script for SOD examples and tests
+###
+### (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.
+
+include $(top_srcdir)/vars.am
+
+###--------------------------------------------------------------------------
+### The silly Chimaera example.
+
+check_PROGRAMS += chimaera
+
+EXTRA_DIST += chimaera.sod
+nodist_chimaera_SOURCES = chimaera.c chimaera.h
+BUILT_SOURCES += $(nodist_chimaera_SOURCES)
+
+EXTRA_DIST += chimaera.ref
+CLEANFILES += chimaera.out
+check-local:: chimaera chimaera.ref
+ ./chimaera >chimaera.out
+ diff -u $(srcdir)/chimaera.ref chimaera.out
+
+###----- That's all, folks --------------------------------------------------
--- /dev/null
+# Makefile.in generated by automake 1.11.6 from Makefile.am.
+# @configure_input@
+
+# Copyright (C) 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
+# 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software
+# Foundation, Inc.
+# This Makefile.in is free software; the Free Software Foundation
+# gives unlimited permission to copy and/or distribute it,
+# with or without modifications, as long as this notice is preserved.
+
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
+# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
+# PARTICULAR PURPOSE.
+
+@SET_MAKE@
+
+### -*-makefile-*-
+###
+### Build script for SOD examples and tests
+###
+### (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.
+
+### -*-makefile-*-
+###
+### Common variable definitions for build scripts
+###
+### (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.
+
+###--------------------------------------------------------------------------
+### Miscellaneous useful definitions.
+
+
+VPATH = @srcdir@
+am__make_dryrun = \
+ { \
+ am__dry=no; \
+ case $$MAKEFLAGS in \
+ *\\[\ \ ]*) \
+ echo 'am--echo: ; @echo "AM" OK' | $(MAKE) -f - 2>/dev/null \
+ | grep '^AM OK$$' >/dev/null || am__dry=yes;; \
+ *) \
+ for am__flg in $$MAKEFLAGS; do \
+ case $$am__flg in \
+ *=*|--*) ;; \
+ *n*) am__dry=yes; break;; \
+ esac; \
+ done;; \
+ esac; \
+ test $$am__dry = yes; \
+ }
+pkgdatadir = $(datadir)/@PACKAGE@
+pkgincludedir = $(includedir)/@PACKAGE@
+pkglibdir = $(libdir)/@PACKAGE@
+pkglibexecdir = $(libexecdir)/@PACKAGE@
+am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
+install_sh_DATA = $(install_sh) -c -m 644
+install_sh_PROGRAM = $(install_sh) -c
+install_sh_SCRIPT = $(install_sh) -c
+INSTALL_HEADER = $(INSTALL_DATA)
+transform = $(program_transform_name)
+NORMAL_INSTALL = :
+PRE_INSTALL = :
+POST_INSTALL = :
+NORMAL_UNINSTALL = :
+PRE_UNINSTALL = :
+POST_UNINSTALL = :
+build_triplet = @build@
+host_triplet = @host@
+DIST_COMMON = $(pkginclude_HEADERS) $(srcdir)/Makefile.am \
+ $(srcdir)/Makefile.in $(top_srcdir)/vars.am
+bin_PROGRAMS =
+check_PROGRAMS = chimaera$(EXEEXT)
+subdir = test
+ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
+am__aclocal_m4_deps = $(top_srcdir)/configure.ac
+am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
+ $(ACLOCAL_M4)
+mkinstalldirs = $(install_sh) -d
+CONFIG_CLEAN_FILES =
+CONFIG_CLEAN_VPATH_FILES =
+am__installdirs = "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgincludedir)"
+PROGRAMS = $(bin_PROGRAMS)
+nodist_chimaera_OBJECTS = chimaera.$(OBJEXT)
+chimaera_OBJECTS = $(nodist_chimaera_OBJECTS)
+chimaera_LDADD = $(LDADD)
+chimaera_DEPENDENCIES = $(top_builddir)/lib/libsod.la
+AM_V_lt = $(am__v_lt_@AM_V@)
+am__v_lt_ = $(am__v_lt_@AM_DEFAULT_V@)
+am__v_lt_0 = --silent
+DEFAULT_INCLUDES = -I.@am__isrc@
+depcomp = $(SHELL) $(top_srcdir)/config/depcomp
+am__depfiles_maybe = depfiles
+am__mv = mv -f
+COMPILE = $(CC) $(DEFS) $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) \
+ $(CPPFLAGS) $(AM_CFLAGS) $(CFLAGS)
+LTCOMPILE = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=compile $(CC) $(DEFS) \
+ $(DEFAULT_INCLUDES) $(INCLUDES) $(AM_CPPFLAGS) $(CPPFLAGS) \
+ $(AM_CFLAGS) $(CFLAGS)
+AM_V_CC = $(am__v_CC_@AM_V@)
+am__v_CC_ = $(am__v_CC_@AM_DEFAULT_V@)
+am__v_CC_0 = @echo " CC " $@;
+AM_V_at = $(am__v_at_@AM_V@)
+am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
+am__v_at_0 = @
+CCLD = $(CC)
+LINK = $(LIBTOOL) $(AM_V_lt) --tag=CC $(AM_LIBTOOLFLAGS) \
+ $(LIBTOOLFLAGS) --mode=link $(CCLD) $(AM_CFLAGS) $(CFLAGS) \
+ $(AM_LDFLAGS) $(LDFLAGS) -o $@
+AM_V_CCLD = $(am__v_CCLD_@AM_V@)
+am__v_CCLD_ = $(am__v_CCLD_@AM_DEFAULT_V@)
+am__v_CCLD_0 = @echo " CCLD " $@;
+AM_V_GEN = $(am__v_GEN_@AM_V@)
+am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
+am__v_GEN_0 = @echo " GEN " $@;
+SOURCES = $(nodist_chimaera_SOURCES)
+DIST_SOURCES =
+am__can_run_installinfo = \
+ case $$AM_UPDATE_INFO_DIR in \
+ n|no|NO) false;; \
+ *) (install-info --version) >/dev/null 2>&1;; \
+ esac
+am__vpath_adj_setup = srcdirstrip=`echo "$(srcdir)" | sed 's|.|.|g'`;
+am__vpath_adj = case $$p in \
+ $(srcdir)/*) f=`echo "$$p" | sed "s|^$$srcdirstrip/||"`;; \
+ *) f=$$p;; \
+ esac;
+am__strip_dir = f=`echo $$p | sed -e 's|^.*/||'`;
+am__install_max = 40
+am__nobase_strip_setup = \
+ srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*|]/\\\\&/g'`
+am__nobase_strip = \
+ for p in $$list; do echo "$$p"; done | sed -e "s|$$srcdirstrip/||"
+am__nobase_list = $(am__nobase_strip_setup); \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed "s| $$srcdirstrip/| |;"' / .*\//!s/ .*/ ./; s,\( .*\)/[^/]*$$,\1,' | \
+ $(AWK) 'BEGIN { files["."] = "" } { files[$$2] = files[$$2] " " $$1; \
+ if (++n[$$2] == $(am__install_max)) \
+ { print $$2, files[$$2]; n[$$2] = 0; files[$$2] = "" } } \
+ END { for (dir in files) print dir, files[dir] }'
+am__base_list = \
+ sed '$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;$$!N;s/\n/ /g' | \
+ sed '$$!N;$$!N;$$!N;$$!N;s/\n/ /g'
+am__uninstall_files_from_dir = { \
+ test -z "$$files" \
+ || { test ! -d "$$dir" && test ! -f "$$dir" && test ! -r "$$dir"; } \
+ || { echo " ( cd '$$dir' && rm -f" $$files ")"; \
+ $(am__cd) "$$dir" && rm -f $$files; }; \
+ }
+HEADERS = $(pkginclude_HEADERS)
+ETAGS = etags
+CTAGS = ctags
+DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
+ACLOCAL = @ACLOCAL@
+AMTAR = @AMTAR@
+AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
+AR = @AR@
+AUTOCONF = @AUTOCONF@
+AUTOHEADER = @AUTOHEADER@
+AUTOMAKE = @AUTOMAKE@
+AWK = @AWK@
+CC = @CC@
+CCDEPMODE = @CCDEPMODE@
+CFLAGS = @CFLAGS@
+CL_LAUNCH = @CL_LAUNCH@
+CPP = @CPP@
+CPPFLAGS = @CPPFLAGS@
+CYGPATH_W = @CYGPATH_W@
+DEFS = @DEFS@
+DEPDIR = @DEPDIR@
+DLLTOOL = @DLLTOOL@
+DSYMUTIL = @DSYMUTIL@
+DUMPBIN = @DUMPBIN@
+ECHO_C = @ECHO_C@
+ECHO_N = @ECHO_N@
+ECHO_T = @ECHO_T@
+EGREP = @EGREP@
+EXEEXT = @EXEEXT@
+FGREP = @FGREP@
+GREP = @GREP@
+INSTALL = @INSTALL@
+INSTALL_DATA = @INSTALL_DATA@
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
+LD = @LD@
+LDFLAGS = @LDFLAGS@
+LIBOBJS = @LIBOBJS@
+LIBS = @LIBS@
+LIBTOOL = @LIBTOOL@
+LIBTOOL_VERSION_INFO = @LIBTOOL_VERSION_INFO@
+LIPO = @LIPO@
+LISPSYS = @LISPSYS@
+LN_S = @LN_S@
+LTLIBOBJS = @LTLIBOBJS@
+MAKEINFO = @MAKEINFO@
+MANIFEST_TOOL = @MANIFEST_TOOL@
+MKDIR_P = @MKDIR_P@
+NM = @NM@
+NMEDIT = @NMEDIT@
+OBJDUMP = @OBJDUMP@
+OBJEXT = @OBJEXT@
+OTOOL = @OTOOL@
+OTOOL64 = @OTOOL64@
+PACKAGE = @PACKAGE@
+PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
+PACKAGE_NAME = @PACKAGE_NAME@
+PACKAGE_STRING = @PACKAGE_STRING@
+PACKAGE_TARNAME = @PACKAGE_TARNAME@
+PACKAGE_URL = @PACKAGE_URL@
+PACKAGE_VERSION = @PACKAGE_VERSION@
+PATH_SEPARATOR = @PATH_SEPARATOR@
+RANLIB = @RANLIB@
+SED = @SED@
+SET_MAKE = @SET_MAKE@
+SHELL = @SHELL@
+STRIP = @STRIP@
+VERSION = @VERSION@
+abs_builddir = @abs_builddir@
+abs_srcdir = @abs_srcdir@
+abs_top_builddir = @abs_top_builddir@
+abs_top_srcdir = @abs_top_srcdir@
+ac_ct_AR = @ac_ct_AR@
+ac_ct_CC = @ac_ct_CC@
+ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
+am__include = @am__include@
+am__leading_dot = @am__leading_dot@
+am__quote = @am__quote@
+am__tar = @am__tar@
+am__untar = @am__untar@
+bindir = @bindir@
+build = @build@
+build_alias = @build_alias@
+build_cpu = @build_cpu@
+build_os = @build_os@
+build_vendor = @build_vendor@
+builddir = @builddir@
+datadir = @datadir@
+datarootdir = @datarootdir@
+docdir = @docdir@
+dvidir = @dvidir@
+exec_prefix = @exec_prefix@
+fasl = @fasl@
+host = @host@
+host_alias = @host_alias@
+host_cpu = @host_cpu@
+host_os = @host_os@
+host_vendor = @host_vendor@
+htmldir = @htmldir@
+includedir = @includedir@
+infodir = @infodir@
+install_sh = @install_sh@
+libdir = @libdir@
+libexecdir = @libexecdir@
+lispsrcdir = @lispsrcdir@
+lispsysdir = @lispsysdir@
+localedir = @localedir@
+localstatedir = @localstatedir@
+mandir = @mandir@
+mkdir_p = @mkdir_p@
+oldincludedir = @oldincludedir@
+pdfdir = @pdfdir@
+prefix = @prefix@
+program_transform_name = @program_transform_name@
+psdir = @psdir@
+sbindir = @sbindir@
+sharedstatedir = @sharedstatedir@
+srcdir = @srcdir@
+sysconfdir = @sysconfdir@
+target_alias = @target_alias@
+top_build_prefix = @top_build_prefix@
+top_builddir = @top_builddir@
+top_srcdir = @top_srcdir@
+pkglispsrcdir = $(lispsrcdir)/$(PACKAGE)
+
+###--------------------------------------------------------------------------
+### Initial values for common variables.
+EXTRA_DIST = chimaera.sod chimaera.ref
+CLEANFILES = $(BUILT_SOURCES) chimaera.out
+DISTCLEANFILES =
+MAINTAINERCLEANFILES =
+SUFFIXES = .c .h .sod
+BUILT_SOURCES = $(nodist_chimaera_SOURCES)
+pkginclude_HEADERS =
+
+###--------------------------------------------------------------------------
+### Include and library path.
+SOD_INCLUDES = \
+ -I$(top_srcdir)/lib -I$(top_builddir)/lib
+
+AM_CPPFLAGS = $(SOD_INCLUDES)
+LDADD = $(top_builddir)/lib/libsod.la
+
+###--------------------------------------------------------------------------
+### Standard configuration substitutions.
+confsubst = $(top_srcdir)/config/confsubst
+SUBSTITUTIONS = \
+ prefix=$(prefix) exec_prefix=$(exec_prefix) \
+ libdir=$(libdir) includedir=$(includedir) \
+ bindir=$(bindir) sbindir=$(sbindir) \
+ PACKAGE=$(PACKAGE) VERSION=$(VERSION)
+
+V_SUBST = $(V_SUBST_$(V))
+V_SUBST_ = $(V_SUBST_$(AM_DEFAULT_VERBOSITY))
+V_SUBST_0 = @echo " SUBST $@";
+SUBST = $(V_SUBST)$(confsubst)
+
+###--------------------------------------------------------------------------
+### Translating SOD input files.
+SOD = $(top_builddir)/src/sod
+V_SOD_c = $(V_SOD_c_$(V))
+V_SOD_c_ = $(V_SOD_c_$(AM_DEFAULT_VERBOSITY))
+V_SOD_c_0 = @echo " SOD[c] $@";
+V_SOD_h = $(V_SOD_h_$(V))
+V_SOD_h_ = $(V_SOD_h_$(AM_DEFAULT_VERBOSITY))
+V_SOD_h_0 = @echo " SOD[h] $@";
+
+###--------------------------------------------------------------------------
+### Silent rules for Lisp.
+V_DUMP = $(V_DUMP_$(V))
+V_DUMP_ = $(V_DUMP_$(AM_DEFAULT_VERBOSITY))
+V_DUMP_0 = @echo " DUMP $@";
+V_TEST = $(V_TEST_$(V))
+V_TEST_ = $(V_TEST_$(AM_DEFAULT_VERBOSITY))
+V_TEST_0 = @echo " TEST $@";
+nodist_chimaera_SOURCES = chimaera.c chimaera.h
+all: $(BUILT_SOURCES)
+ $(MAKE) $(AM_MAKEFLAGS) all-am
+
+.SUFFIXES:
+.SUFFIXES: .c .h .sod .lo .o .obj
+$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(top_srcdir)/vars.am $(am__configure_deps)
+ @for dep in $?; do \
+ case '$(am__configure_deps)' in \
+ *$$dep*) \
+ ( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
+ && { if test -f $@; then exit 0; else break; fi; }; \
+ exit 1;; \
+ esac; \
+ done; \
+ echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign test/Makefile'; \
+ $(am__cd) $(top_srcdir) && \
+ $(AUTOMAKE) --foreign test/Makefile
+.PRECIOUS: Makefile
+Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
+ @case '$?' in \
+ *config.status*) \
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
+ *) \
+ echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe)'; \
+ cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__depfiles_maybe);; \
+ esac;
+$(top_srcdir)/vars.am:
+
+$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+
+$(top_srcdir)/configure: $(am__configure_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(ACLOCAL_M4): $(am__aclocal_m4_deps)
+ cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
+$(am__aclocal_m4_deps):
+install-binPROGRAMS: $(bin_PROGRAMS)
+ @$(NORMAL_INSTALL)
+ @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \
+ if test -n "$$list"; then \
+ echo " $(MKDIR_P) '$(DESTDIR)$(bindir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(bindir)" || exit 1; \
+ fi; \
+ for p in $$list; do echo "$$p $$p"; done | \
+ sed 's/$(EXEEXT)$$//' | \
+ while read p p1; do if test -f $$p || test -f $$p1; \
+ then echo "$$p"; echo "$$p"; else :; fi; \
+ done | \
+ sed -e 'p;s,.*/,,;n;h' -e 's|.*|.|' \
+ -e 'p;x;s,.*/,,;s/$(EXEEXT)$$//;$(transform);s/$$/$(EXEEXT)/' | \
+ sed 'N;N;N;s,\n, ,g' | \
+ $(AWK) 'BEGIN { files["."] = ""; dirs["."] = 1 } \
+ { d=$$3; if (dirs[d] != 1) { print "d", d; dirs[d] = 1 } \
+ if ($$2 == $$4) files[d] = files[d] " " $$1; \
+ else { print "f", $$3 "/" $$4, $$1; } } \
+ END { for (d in files) print "f", d, files[d] }' | \
+ while read type dir files; do \
+ if test "$$dir" = .; then dir=; else dir=/$$dir; fi; \
+ test -z "$$files" || { \
+ echo " $(INSTALL_PROGRAM_ENV) $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL_PROGRAM) $$files '$(DESTDIR)$(bindir)$$dir'"; \
+ $(INSTALL_PROGRAM_ENV) $(LIBTOOL) $(AM_LIBTOOLFLAGS) $(LIBTOOLFLAGS) --mode=install $(INSTALL_PROGRAM) $$files "$(DESTDIR)$(bindir)$$dir" || exit $$?; \
+ } \
+ ; done
+
+uninstall-binPROGRAMS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(bin_PROGRAMS)'; test -n "$(bindir)" || list=; \
+ files=`for p in $$list; do echo "$$p"; done | \
+ sed -e 'h;s,^.*/,,;s/$(EXEEXT)$$//;$(transform)' \
+ -e 's/$$/$(EXEEXT)/' `; \
+ test -n "$$list" || exit 0; \
+ echo " ( cd '$(DESTDIR)$(bindir)' && rm -f" $$files ")"; \
+ cd "$(DESTDIR)$(bindir)" && rm -f $$files
+
+clean-binPROGRAMS:
+ @list='$(bin_PROGRAMS)'; test -n "$$list" || exit 0; \
+ echo " rm -f" $$list; \
+ rm -f $$list || exit $$?; \
+ test -n "$(EXEEXT)" || exit 0; \
+ list=`for p in $$list; do echo "$$p"; done | sed 's/$(EXEEXT)$$//'`; \
+ echo " rm -f" $$list; \
+ rm -f $$list
+
+clean-checkPROGRAMS:
+ @list='$(check_PROGRAMS)'; test -n "$$list" || exit 0; \
+ echo " rm -f" $$list; \
+ rm -f $$list || exit $$?; \
+ test -n "$(EXEEXT)" || exit 0; \
+ list=`for p in $$list; do echo "$$p"; done | sed 's/$(EXEEXT)$$//'`; \
+ echo " rm -f" $$list; \
+ rm -f $$list
+chimaera$(EXEEXT): $(chimaera_OBJECTS) $(chimaera_DEPENDENCIES) $(EXTRA_chimaera_DEPENDENCIES)
+ @rm -f chimaera$(EXEEXT)
+ $(AM_V_CCLD)$(LINK) $(chimaera_OBJECTS) $(chimaera_LDADD) $(LIBS)
+
+mostlyclean-compile:
+ -rm -f *.$(OBJEXT)
+
+distclean-compile:
+ -rm -f *.tab.c
+
+@AMDEP_TRUE@@am__include@ @am__quote@./$(DEPDIR)/chimaera.Po@am__quote@
+
+.c.o:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c $<
+
+.c.obj:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(COMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ `$(CYGPATH_W) '$<'`
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Po
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=no @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(COMPILE) -c `$(CYGPATH_W) '$<'`
+
+.c.lo:
+@am__fastdepCC_TRUE@ $(AM_V_CC)$(LTCOMPILE) -MT $@ -MD -MP -MF $(DEPDIR)/$*.Tpo -c -o $@ $<
+@am__fastdepCC_TRUE@ $(AM_V_at)$(am__mv) $(DEPDIR)/$*.Tpo $(DEPDIR)/$*.Plo
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ $(AM_V_CC)source='$<' object='$@' libtool=yes @AMDEPBACKSLASH@
+@AMDEP_TRUE@@am__fastdepCC_FALSE@ DEPDIR=$(DEPDIR) $(CCDEPMODE) $(depcomp) @AMDEPBACKSLASH@
+@am__fastdepCC_FALSE@ $(AM_V_CC@am__nodep@)$(LTCOMPILE) -c -o $@ $<
+
+mostlyclean-libtool:
+ -rm -f *.lo
+
+clean-libtool:
+ -rm -rf .libs _libs
+install-pkgincludeHEADERS: $(pkginclude_HEADERS)
+ @$(NORMAL_INSTALL)
+ @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ if test -n "$$list"; then \
+ echo " $(MKDIR_P) '$(DESTDIR)$(pkgincludedir)'"; \
+ $(MKDIR_P) "$(DESTDIR)$(pkgincludedir)" || exit 1; \
+ fi; \
+ for p in $$list; do \
+ if test -f "$$p"; then d=; else d="$(srcdir)/"; fi; \
+ echo "$$d$$p"; \
+ done | $(am__base_list) | \
+ while read files; do \
+ echo " $(INSTALL_HEADER) $$files '$(DESTDIR)$(pkgincludedir)'"; \
+ $(INSTALL_HEADER) $$files "$(DESTDIR)$(pkgincludedir)" || exit $$?; \
+ done
+
+uninstall-pkgincludeHEADERS:
+ @$(NORMAL_UNINSTALL)
+ @list='$(pkginclude_HEADERS)'; test -n "$(pkgincludedir)" || list=; \
+ files=`for p in $$list; do echo $$p; done | sed -e 's|^.*/||'`; \
+ dir='$(DESTDIR)$(pkgincludedir)'; $(am__uninstall_files_from_dir)
+
+ID: $(HEADERS) $(SOURCES) $(LISP) $(TAGS_FILES)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ mkid -fID $$unique
+tags: TAGS
+
+TAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ set x; \
+ here=`pwd`; \
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ shift; \
+ if test -z "$(ETAGS_ARGS)$$*$$unique"; then :; else \
+ test -n "$$unique" || unique=$$empty_fix; \
+ if test $$# -gt 0; then \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ "$$@" $$unique; \
+ else \
+ $(ETAGS) $(ETAGSFLAGS) $(AM_ETAGSFLAGS) $(ETAGS_ARGS) \
+ $$unique; \
+ fi; \
+ fi
+ctags: CTAGS
+CTAGS: $(HEADERS) $(SOURCES) $(TAGS_DEPENDENCIES) \
+ $(TAGS_FILES) $(LISP)
+ list='$(SOURCES) $(HEADERS) $(LISP) $(TAGS_FILES)'; \
+ unique=`for i in $$list; do \
+ if test -f "$$i"; then echo $$i; else echo $(srcdir)/$$i; fi; \
+ done | \
+ $(AWK) '{ files[$$0] = 1; nonempty = 1; } \
+ END { if (nonempty) { for (i in files) print i; }; }'`; \
+ test -z "$(CTAGS_ARGS)$$unique" \
+ || $(CTAGS) $(CTAGSFLAGS) $(AM_CTAGSFLAGS) $(CTAGS_ARGS) \
+ $$unique
+
+GTAGS:
+ here=`$(am__cd) $(top_builddir) && pwd` \
+ && $(am__cd) $(top_srcdir) \
+ && gtags -i $(GTAGS_ARGS) "$$here"
+
+distclean-tags:
+ -rm -f TAGS ID GTAGS GRTAGS GSYMS GPATH tags
+
+distdir: $(DISTFILES)
+ @srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
+ list='$(DISTFILES)'; \
+ dist_files=`for file in $$list; do echo $$file; done | \
+ sed -e "s|^$$srcdirstrip/||;t" \
+ -e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
+ case $$dist_files in \
+ */*) $(MKDIR_P) `echo "$$dist_files" | \
+ sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
+ sort -u` ;; \
+ esac; \
+ for file in $$dist_files; do \
+ if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
+ if test -d $$d/$$file; then \
+ dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
+ if test -d "$(distdir)/$$file"; then \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
+ cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
+ find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
+ fi; \
+ cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
+ else \
+ test -f "$(distdir)/$$file" \
+ || cp -p $$d/$$file "$(distdir)/$$file" \
+ || exit 1; \
+ fi; \
+ done
+check-am: all-am
+ $(MAKE) $(AM_MAKEFLAGS) $(check_PROGRAMS)
+ $(MAKE) $(AM_MAKEFLAGS) check-local
+check: $(BUILT_SOURCES)
+ $(MAKE) $(AM_MAKEFLAGS) check-am
+all-am: Makefile $(PROGRAMS) $(HEADERS)
+installdirs:
+ for dir in "$(DESTDIR)$(bindir)" "$(DESTDIR)$(pkgincludedir)"; do \
+ test -z "$$dir" || $(MKDIR_P) "$$dir"; \
+ done
+install: $(BUILT_SOURCES)
+ $(MAKE) $(AM_MAKEFLAGS) install-am
+install-exec: install-exec-am
+install-data: install-data-am
+uninstall: uninstall-am
+
+install-am: all-am
+ @$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
+
+installcheck: installcheck-am
+install-strip:
+ if test -z '$(STRIP)'; then \
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ install; \
+ else \
+ $(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
+ install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
+ "INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \
+ fi
+mostlyclean-generic:
+
+clean-generic:
+ -test -z "$(CLEANFILES)" || rm -f $(CLEANFILES)
+
+distclean-generic:
+ -test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
+ -test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
+ -test -z "$(DISTCLEANFILES)" || rm -f $(DISTCLEANFILES)
+
+maintainer-clean-generic:
+ @echo "This command is intended for maintainers to use"
+ @echo "it deletes files that may require special tools to rebuild."
+ -test -z "$(BUILT_SOURCES)" || rm -f $(BUILT_SOURCES)
+ -test -z "$(MAINTAINERCLEANFILES)" || rm -f $(MAINTAINERCLEANFILES)
+clean: clean-am
+
+clean-am: clean-binPROGRAMS clean-checkPROGRAMS clean-generic \
+ clean-libtool mostlyclean-am
+
+distclean: distclean-am
+ -rm -rf ./$(DEPDIR)
+ -rm -f Makefile
+distclean-am: clean-am distclean-compile distclean-generic \
+ distclean-tags
+
+dvi: dvi-am
+
+dvi-am:
+
+html: html-am
+
+html-am:
+
+info: info-am
+
+info-am:
+
+install-data-am: install-pkgincludeHEADERS
+
+install-dvi: install-dvi-am
+
+install-dvi-am:
+
+install-exec-am: install-binPROGRAMS
+
+install-html: install-html-am
+
+install-html-am:
+
+install-info: install-info-am
+
+install-info-am:
+
+install-man:
+
+install-pdf: install-pdf-am
+
+install-pdf-am:
+
+install-ps: install-ps-am
+
+install-ps-am:
+
+installcheck-am:
+
+maintainer-clean: maintainer-clean-am
+ -rm -rf ./$(DEPDIR)
+ -rm -f Makefile
+maintainer-clean-am: distclean-am maintainer-clean-generic
+
+mostlyclean: mostlyclean-am
+
+mostlyclean-am: mostlyclean-compile mostlyclean-generic \
+ mostlyclean-libtool
+
+pdf: pdf-am
+
+pdf-am:
+
+ps: ps-am
+
+ps-am:
+
+uninstall-am: uninstall-binPROGRAMS uninstall-pkgincludeHEADERS
+
+.MAKE: all check check-am install install-am install-strip
+
+.PHONY: CTAGS GTAGS all all-am check check-am check-local clean \
+ clean-binPROGRAMS clean-checkPROGRAMS clean-generic \
+ clean-libtool ctags distclean distclean-compile \
+ distclean-generic distclean-libtool distclean-tags distdir dvi \
+ dvi-am html html-am info info-am install install-am \
+ 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-man \
+ 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-pkgincludeHEADERS
+
+.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $<
+.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $<
+
+###----- That's all, folks --------------------------------------------------
+check-local:: chimaera chimaera.ref
+ ./chimaera >chimaera.out
+ diff -u $(srcdir)/chimaera.ref chimaera.out
+
+###----- That's all, folks --------------------------------------------------
+
+# Tell versions [3.59,3.63) of GNU make to not export all variables.
+# Otherwise a system limit (for SysV at least) may be exceeded.
+.NOEXPORT:
--- /dev/null
+provoking Lion as a lion
+Munch!
+tickle Lion #0...
+Munch!
+tickle Lion #1...
+Munch!
+tickle Lion #2...
+Munch!
+provoking Goat as a goat
+Bonk!
+tickle Goat #0...
+Bonk!
+tickle Goat #1...
+Bonk!
+tickle Goat #2...
+Bonk!
+provoking Serpent as a serpent
+Nom!
+tickle Serpent #0...
+Sssss!
+tickle Serpent #1...
+Sssss!
+tickle Serpent #2...
+Nom!
+provoking Chimaera as a lion
+Munch!
+provoking Chimaera as a goat
+Bonk!
+provoking Chimaera as a serpent
+Nom!
+tickle Chimaera #0...
+Munch!
+Bonk!
+Sssss!
+tickle Chimaera #1...
+Munch!
+Bonk!
+Sssss!
+tickle Chimaera #2...
+Munch!
+Bonk!
+Nom!
class Animal : SodObject {
int tickles = 0;
- void tickle(void) { }
+ [combination = progn]
+ void tickle();
[role = before]
- void nml.tickle(void) { me->nml.tickles++; }
+ void nml.tickle() { me->nml.tickles++; }
}
class Lion : Animal {
- void bite(void) { puts("Munch!"); }
- void nml.tickle(void) { me->_vt->lion.bite(me); }
+ void bite() { puts("Munch!"); }
+ void nml.tickle() { me->_vt->lion.bite(me); }
}
class Goat : Animal {
- void butt(void) { puts("Bonk!"); }
- void nml.tickle(void) { me->_vt->goat.butt(me); }
+ void butt() { puts("Bonk!"); }
+ void nml.tickle() { me->_vt->goat.butt(me); }
}
class Serpent : Animal {
- void hiss(void) { puts("Sssss!"); }
- void bite(void) { puts("Nom!"); }
- void nml.tickle(void) {
+ 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);
}
s->_vt->serpent.bite(s);
}
-#define SOD_DECL(cls_, var_) \
- struct cls_##__ilayout var_##__layout; \
- cls_ *var_ = cls_##__class->cls.init(&var_##__layout)
-
int main(void)
{
{
LDADD = $(top_builddir)/lib/libsod.la
###--------------------------------------------------------------------------
+### Standard configuration substitutions.
+
+## Substitute tags in files.
+confsubst = $(top_srcdir)/config/confsubst
+
+SUBSTITUTIONS = \
+ prefix=$(prefix) exec_prefix=$(exec_prefix) \
+ libdir=$(libdir) includedir=$(includedir) \
+ bindir=$(bindir) sbindir=$(sbindir) \
+ PACKAGE=$(PACKAGE) VERSION=$(VERSION)
+
+V_SUBST = $(V_SUBST_$(V))
+V_SUBST_ = $(V_SUBST_$(AM_DEFAULT_VERBOSITY))
+V_SUBST_0 = @echo " SUBST $@";
+SUBST = $(V_SUBST)$(confsubst)
+
+###--------------------------------------------------------------------------
### Translating SOD input files.
## The tool location.
SOD = $(top_builddir)/src/sod
+## Silent rules treatment.
+V_SOD_c = $(V_SOD_c_$(V))
+V_SOD_c_ = $(V_SOD_c_$(AM_DEFAULT_VERBOSITY))
+V_SOD_c_0 = @echo " SOD[c] $@";
+V_SOD_h = $(V_SOD_h_$(V))
+V_SOD_h_ = $(V_SOD_h_$(AM_DEFAULT_VERBOSITY))
+V_SOD_h_0 = @echo " SOD[h] $@";
+
## Build rules.
SUFFIXES += .c .h .sod
-.sod.c: $(SOD); $(SOD) -tc $<
-.sod.h: $(SOD); $(SOD) -th $<
+.sod.c: $(SOD); $(V_SOD_c)$(SOD) -tc $<
+.sod.h: $(SOD); $(V_SOD_h)$(SOD) -th $<
+
+###--------------------------------------------------------------------------
+### Silent rules for Lisp.
+
+V_DUMP = $(V_DUMP_$(V))
+V_DUMP_ = $(V_DUMP_$(AM_DEFAULT_VERBOSITY))
+V_DUMP_0 = @echo " DUMP $@";
+
+V_TEST = $(V_TEST_$(V))
+V_TEST_ = $(V_TEST_$(AM_DEFAULT_VERBOSITY))
+V_TEST_0 = @echo " TEST $@";
###----- That's all, folks --------------------------------------------------
~mdw / sod / commitdiff