From 576444ccc75a3abc09e6eb2b4f7d8771690dd36d Mon Sep 17 00:00:00 2001 From: bstarynk Date: Thu, 28 Feb 2008 18:55:33 +0000 Subject: gcc/Changelog: 2008-02-26 Basile Starynkevitch * Makefile.in: adding melt-private-include/ thing * melt/ : subdirectory moved here (was in ..) git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/branches/melt-branch@132754 138bc75d-0d04-0410-961f-82ee72b054a4 --- gcc/Makefile.in | 52 +- gcc/melt/README-MELT | 95 + gcc/melt/warm-basilys.bysl | 8872 ++++++++++++++++++++++++++++++++++++++++++++ gcc/run-basilys.h | 25 +- 4 files changed, 9028 insertions(+), 16 deletions(-) create mode 100644 gcc/melt/README-MELT create mode 100644 gcc/melt/warm-basilys.bysl (limited to 'gcc') diff --git a/gcc/Makefile.in b/gcc/Makefile.in index 1cc90cbdf33..4e775d517a2 100644 --- a/gcc/Makefile.in +++ b/gcc/Makefile.in @@ -285,7 +285,7 @@ ZLIBINC = @zlibinc@ GMPLIBS = @GMPLIBS@ GMPINC = @GMPINC@ -### for Basilys +### for MELT/ Basilys # How to find PPL (Parma Polyhedra Library) PPLLIBS = @ppllibs@ PPLINC = @pplinc@ @@ -4497,10 +4497,56 @@ po/gcc.pot: force AWK=$(AWK) $(SHELL) $(srcdir)/po/exgettext \ $(XGETTEXT) gcc $(srcdir) - -## definition for basilys internal compilation +################################################################ +## definition for basilys/MELT internal compilation +## see thread http://gcc.gnu.org/ml/gcc/2008-02/msg00632.html +## in particular http://gcc.gnu.org/ml/gcc/2008-02/msg00673.html compile-basilys-defs: echo '#generated compile-basilys-defs' > $@ echo 'ALL_CFLAGS="' $(ALL_CFLAGS) '"' >> $@ echo 'ALL_CPPFLAGS="' -I$(PWD) $(ALL_CPPFLAGS) '"' >> $@ + + + +## this is the installation directory +melt_private_include_dir=$(libexecsubdir)/melt-private-include/ + +## this is the local build directory +melt_build_include_dir= melt-private-build-include + +# we want to generate all the direct (non system) dependencies of run-basilys.h +# the following should work if $(CC) is some recent version of GCC (probably >= 4.x) + +# we first generate the make-dependencies using -MMD +# this should write into run-basilys.d some stuff like +## run-basilys-deps: srcdir.../gcc/run-basilys.h config.h auto-host.h .... +# with the srcdir... replaced by the source directory +# however, there are also config/ files in the dependency list +# config/ files should be handled specially since they are the only #include-d files +# which are not flat, ie in a subdirectory, like srcdir.../gcc/config/i386/x86-64.h +# there is also a dependency on tm.h (in objdir) which contains stuff like #include "config/i386/x86-64.h" +run-basilys.d: run-basilys.h \ + $(CONFIG_H) $(SYSTEM_H) $(TIMEVAR_H) $(TM_H) $(TREE_H) $(GGC_H) \ + tree-pass.h basilys.h gt-basilys.h + $(CC) -MT run-basilys-deps -MMD $(ALL_CFLAGS) $(ALL_CPPFLAGS) $< + +.PHONY: run-basilys-deps +## the include below defines the dependencies of run-basilys-deps +## included file run-basilys.d is generated above +-include run-basilys.d + + +## copy all the file in the dependency of run-basilys-deps into $(melt_private_include_dir) +## but handle the $(srcdir)/config/ files specially by copying them within a config/ directory +run-basilys-deps: + $(mkinstalldirs) $(melt_build_include_dir); \ + for f in $^ ; do \ + cf=`echo $$f | sed -q ":^$(srcdir)/config/:$(melt_build_include_dir)/config:"`; \ + if [ -n "$$cf" ] ; then \ + cp -p $$f $$cf ; \ + else \ + cp -p $$f $(melt_build_include_dir)/ ; \ + fi; \ + done + ### end of basilys stuff \ No newline at end of file diff --git a/gcc/melt/README-MELT b/gcc/melt/README-MELT new file mode 100644 index 00000000000..c1cc59e6b3c --- /dev/null +++ b/gcc/melt/README-MELT @@ -0,0 +1,95 @@ +## file melt/README.melt in melt-branch of GCC + +Please read the wiki page on http://gcc.gnu.org/wiki/MiddleEndLispTranslator +and my GCC summit 2007 paper +Multi-stage construction of a global static analyser by Basile Starynkevitch, pages 143 - 152 + +This directory contains melt files. MELT is a dialect of Lisp compiled +into C code which should be compilable (by some strange basilys-gcc +script invoking any GCC [or perhaps even another compiler?] with the +appropriate -fPIC and -I options + +The MELT source files are called .bysl (sorry for the messy suffix) + +This basilys-gcc (which really should be named melt-gcc) should be something similar to +########################## CUT HERE FILE basilys-gcc to be installed in your $PATH +#! /bin/bash +if [ ! -e $1 ]; then + echo $0: no input file $1 1>&2 + exit 1 +fi +cc="ccache gcc" +if [ ! -z "$3" ]; then + cc=$3 +fi +srcin=$1 +echo BasilysGcc $srcin 1>&2 +##***## CHANGE BELOW LINE APPROPRIATELY ACCORDING TO YOUR GCC BUILD DIRECTORY +. /usr/src/Lang/basile-ggcc/_Obj/gcc/compile-basilys-defs +# indent $srcin +outn=$2 +if [ -z "$outn" ]; then + outn=$(basename $srcin .c).so +fi +rm $outn +objn=$(basename $srcin .c).pic.o +barn=$(basename $srcin .c) +datf=$(tempfile -s .c -p bdat) +md5src=$(md5sum $srcin) +date "+const char basilys_compiled_timestamp[]=\"$barn %c\";" > $datf +echo "const char basilys_md5[]=\"$md5src\";" >> $datf +## ccache works only with a -c option +$cc -time -fPIC -g3 $ALL_CFLAGS $ALL_CPPFLAGS $srcin -c -o $objn +gcc -shared -fPIC $objn $datf -o $outn +head -9 $datf +rm -f $datf +echo "Basilysgcc -shared -fPIC -fno-inline -g3 -Wextra -Wall $ALL_CFLAGS $ALL_CPPFLAGS $srcin -o $outn" +ls -l $outn* $objn* +############################## END OF basilys-gcc + +However, you have to change the sourcing of /usr/src/Lang/basile-ggcc/_Obj/gcc/compile-basilys-defs +into the sourcing of $YOURBUILDGCCDIR/gcc/compile-basilys-defs + +You might also compile *.bysl file with the contrib/cold-basilys.lisp +using CLISP with a script coldbasilys similar to + +############################## CUT HERE file coldbasilys to be installed in your $PATH +#! /usr/bin/clisp -C +;; !# + +;; -*- lisp -*- + +(proclaim '(optimize (debug 0) (safety 1) (speed 3))) + +(let +( (argv + EXT:*ARGS* + )) + (format *error-output* "coldbasilys start ~s ~%" argv)) + + +(load "cold-basilys.lisp") + +(time (mapc (function handle-source-file) EXT:*ARGS*)) + +#################################### end of coldbasilys + +I am sorry for all this temporary mess. As soon as warm-basilys.bysl +is debugged, it should bootstrap itself in the following sense: + + a *generated* warm-basilys.c exists somewhere; it is quite big (>300KLOC) + + this generated file should be compiled (successfully) by the above + basilys-gcc script into a warm-basilys.so (to be put in a place to be defined) + + this warm-basilys.so is dynamically loaded by cc1 thru + + gcc/cc1 -fbasilys -fbasilys-init=warm-basilys.so \ + -fbasilys-command=compileseq -fbasilys-arg=warm-basilys.bysl \ + -frandom-seed=AbCdEfGhIj + +for debugging I usually add the -fbasilys-debug -fdump-ipa-basilys flags which should not be needed + +You should also be able to generate this wam-basilys.c file with coldbasilys warm-basilys.bysl + +#### comments and questions to diff --git a/gcc/melt/warm-basilys.bysl b/gcc/melt/warm-basilys.bysl new file mode 100644 index 00000000000..b829bd811b9 --- /dev/null +++ b/gcc/melt/warm-basilys.bysl @@ -0,0 +1,8872 @@ +; -*- Lisp -*- +;; file warm-basilys.bysl +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Copyright 2008 Free Software Foundation, Inc. +;; Contributed by Basile Starynkevitch + +;; This file is part of GCC. + +;; GCC 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 3, or (at your option) +;; any later version. + +;; GCC 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 GCC; see the file COPYING3. If not see +;; . + +;;;;;; +;; This file is a bootstrapping compiler for the basilys lisp dialect +;; it should be able to compile itself (into a generated C file) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; root class +(defclass class_root + :predef CLASS_ROOT) + +;; class of everything with a property table +(defclass class_proped + :super class_root + :fields (prop_table) + :predef CLASS_PROPED) + + +;; arbitrary container as class +(defclass class_container + :super class_root + :fields (container_value)) + +;; class of named objects +(defclass class_named + :super class_proped + :fields (named_name) + :predef CLASS_NAMED) + +;; class of discriminants +(defclass class_discr + :super class_named + :fields (disc_methodict + disc_sender + disc_super) + :predef CLASS_DISCR) + +;; class of classes +(defclass class_class + :super class_discr + :fields (class_ancestors class_fields class_objnumdescr class_data) + :predef CLASS_CLASS) + +;; class of fields +(defclass class_field + ;; the fields' objnum is its offset + :super class_named + :fields (fld_ownclass fld_typinfo) + :predef CLASS_FIELD) + +;; class of primitive +(defclass class_primitive + :super class_named + :fields (prim_formals prim_type prim_expansion) + :predef CLASS_PRIMITIVE) + +;; class of located stuff +(defclass class_located + :super class_proped + :fields (loca_location) + :predef CLASS_LOCATED) + +;; class of source expressions +(defclass class_sexpr + :super class_located + :fields (sexp_contents ;list of contents + ) + :predef CLASS_SEXPR) + +;; class of message selectors +(defclass class_selector + :super class_named + :fields (sel_signature sel_data) + :predef CLASS_SELECTOR) + + +;; class of symbols +(defclass class_symbol + :predef CLASS_SYMBOL + :super class_named + :fields (symb_data)) + +;; class of generated (ie cloned) symbols - like lisp gensym +(defclass class_clonedsymbol + :super class_symbol + :fields (csym_urank ;unique rank as a boxed integer + )) + +;; class of keyword symbols +(defclass class_keyword + :predef CLASS_KEYWORD + :super class_symbol + :fields ()) + +;; class of C types keywords +(defclass class_ctype + :super class_named + :fields ( + ctype_keyword ;the keyword associated to the ctype (e.g. :long) + ctype_cname ;the name for C of the type (eg long) + ctype_parchar ;the name of the basilys parameter char (eg BPAR_LONG) + ctype_parstring ;the name of the basilys parameter string (eg BPARSTR_LONG) + ctype_argfield ;the name of the basilys argument union field (eg bp_long) + ctype_resfield ;the name of the basilys result union field (eg bp_longptr) + ) + ) + +;; class of tokenizers +(defclass class_tokenizer + :super class_named + :fields (tok_symboldict ; stringmap for symbols + tok_keywdict ;stringmap for keywords + tok_addsymbol ;closure to add a symbol of given name + tok_addkeyw ;closure to add a keyword of given name + tok_internsymbol ;closure to intern a symbol + tok_internkeyw ;closure to intern a keyword + ) + :predef CLASS_TOKENIZER) + +;; class of command dispatchers +(defclass class_command_dispatcher + :super class_named + :fields (cmd_fundict ;stringmap for closures + ) + :predef CLASS_COMMAND_DISPATCHER) + +;; primitive for converting a string constant into a string value +(defprimitive stringconst2val (discr :cstring strc) :value + " basilysgc_new_string((" discr "), (" strc "))") + + +;; primitive for testing if an object is a (sub) instance of a class +(defprimitive is_a (obj cla) :long + " basilys_is_instance_of((" obj "), (" cla "))") + +;; primitive for testing objectness +(defprimitive is_object (obj) :long + " (basilys_magic_discr(" obj ") == OBMAG_OBJECT)") + + +;; primitive to return the last predefined index +(defprimitive last_globpredef_index () :long + "BGLOB__LASTGLOB") + +;; primitive to safely return a global predef by its index +(defprimitive get_globpredef (:long ix) :value + "(basilys_globpredef((" ix ")))") + +;; primitive to get the discriminant of a value +(defprimitive discrim (v) :value + "(basilys_discr((" v ")))") + +;; primitive to get the integer inside a boxed or mixed integer or objnum +(defprimitive get_int (v) :long + "(basilys_get_int((" v ")))") +;; primitive to put the integer inside a boxed or mixed integer or objnum +(defprimitive put_int (v :long i) :void + "basilys_put_int((" v "), (" i "))") + +;; primitive to get the hashcode of an object (or 0) +(defprimitive obj_hash(v) :long + "(basilys_obj_hash((" v ")))") +;; primitive to get the length of an object (or 0) +(defprimitive obj_len(v) :long + "(basilys_obj_len((" v ")))") +;; primitive to get the number of an object (or 0) +(defprimitive obj_num(v) :long + "(basilys_obj_num((" v ")))") +;; primitive to compue a nonzero hash +(defprimitive nonzero_hash () :long + "(basilys_nonzerohash())") + +;; primitive for identity and non-identity test +(defprimitive == (a b) :long "((" a ") == (" b "))") +(defprimitive != (a b) :long "((" a ") != (" b "))") + +;; primitive always returning nil +(defprimitive the_null () :value "(NULL)") + +;;; the call counter +(defprimitive the_callcount () :long "callcount") + +;; primitive to get or create a symbol from a string value +(defprimitive get_symbolstr (strv) :value + "basilysgc_named_symbol( basilys_string_str(" strv "), BASILYS_GET)") +(defprimitive create_symbolstr (strv) :value + "basilysgc_named_symbol( basilys_string_str(" strv "), BASILYS_CREATE)") + +;; primitive to get or create a keyword from a string value +(defprimitive get_keywordstr (strv) :value + "basilysgc_named_keyword( basilys_string_str(" strv "), BASILYS_GET)") +(defprimitive create_keywordstr (strv) :value + "basilysgc_named_keyword( basilys_string_str(" strv "), BASILYS_CREATE)") + +;; runtime assertion with message +(defprimitive assert_msg (:cstring msg :long cond) :void + "basilys_assertmsg(" msg ", ( " cond "))") +;; check explicitly the call stack +(defprimitive checkcallstack_msg (:cstring msg) :void + "basilys_check_call_frames(BASILYS_ANYWHERE, (" msg "))") +;; for brezakpoint +(defprimitive cbreak_msg (:cstring msg) :void + "basilys_cbreak(" msg ")") + +;;; less, lessorequal, greater, greaterorequal, equal, different number +(defprimitive i (:long a b) :long "((" a ") > (" b "))") +(defprimitive >=i (:long a b) :long "((" a ") >= (" b "))") +(defprimitive !=i (:long a b) :long "((" a ") != (" b "))") +;;; integer arithmetic +(defprimitive +i (:long a b) :long "((" a ") + (" b "))") +(defprimitive -i (:long a b) :long "((" a ") - (" b "))") +(defprimitive *i (:long a b) :long "((" a ") * (" b "))") +(defprimitive andi (:long a b) :long "((" a ") & (" b "))") +(defprimitive ori (:long a b) :long "((" a ") | (" b "))") +(defprimitive xori (:long a b) :long "((" a ") ^ (" b "))") +(defprimitive negi (:long i) :long "(-(" i "))") +(defprimitive noti (:long i) :long "(~(" i "))") + +(defprimitive /i (:long a b) :long "(basilys_idiv(" a "), (" b "))") +(defprimitive %i (:long a b) :long "(basilys_imod(" a "), (" b "))") +(defprimitive /iraw (:long a b) :long "((" a ") / (" b "))") +(defprimitive %iraw (:long a b) :long "((" a ") % (" b "))") +;; boolean not +(defprimitive not (:long i) :long "(!(" i "))") +;;; nullity test (for values) +(defprimitive null (v) :long "((" v ") == NULL)") +(defprimitive notnull (v) :long "((" v ") != NULL)") +;;; zero test (for numbers) +(defprimitive zerop (:long i) :long "((" i ") == OL)") +;; primitive for testing if debug +(defprimitive need_dbg (:long depth) :long + "(dump_file && (" depth ")>=0 && (" depth ") <= BASILYSDBG_MAXDEPTH)") + +(defprimitive need_dbglim (:long depth limit) :long + "(dump_file && (" depth ")>=0 && (" depth ") < (" limit "))") + +(defprimitive outstrcont_dbg (:cstring s) :void + "basilys_puts(dump_file,(" s "))") +(defprimitive outnum_dbg (:cstring pref :long l :cstring suf) :void + "basilys_putnum(dump_file,(" pref "), (" l "), (" suf "))") +(defprimitive outstr_dbg (str) :void + "basilys_putstr(dump_file,(" str "))") +(defprimitive outstrbuf_dbg (sbuf) :void + "basilys_putstrbuf(dump_file,(" sbuf "))") +(defprimitive outnewline_dbg () :void + "basilys_newlineflush(dump_file)") + +(defprimitive output_cfile_decl_impl (uninam declbuf implbuf) :void + "basilys_output_cfile_decl_impl((" uninam "), (" declbuf "), (" implbuf "))") + +(defprimitive message_dbg (:cstring msg) :void + "debugeputs((" msg "))") +(defprimitive messagenum_dbg (:cstring msg :long i) :void + "debugnum((" msg "), (" i "))") +(defprimitive messageval_dbg (:cstring msg :value val) :void + "debugvalue((" msg "), ((void*)(" val ")))") +(defprimitive longbacktrace_dbg (:cstring msg :long maxdepth) :void + "debugbacktrace((" msg "), (int)(" maxdepth "))") +(defprimitive shortbacktrace_dbg (:cstring msg :long maxdepth) :void + "basilys_dbgshortbacktrace((" msg "), (" maxdepth "))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; STRBUF primitives +;; primitive to make a strbuf +(defprimitive make_strbuf (discr) :value + "basilysgc_new_strbuf((" discr "), (char*)0)") +(defprimitive strbuf_usedlength (sbuf) :long + "basilys_strbuf_usedlength((" sbuf "))") + +(defprimitive is_strbuf (v) :long + "(basilys_magic_discr((" v ")) == OBMAG_STRBUF)") +;; primitive to add a string const into a strbuf +(defprimitive add2sbuf_strconst (sbuf :cstring str) :void + "basilysgc_add_strbuf((" sbuf "), (" str "))") +;; primitive to add a string value into a strbuf +(defprimitive add2sbuf_string (sbuf str) :void + "basilysgc_add_strbuf((" sbuf "), basilys_string_str(" str "))") + +;; primitive to add an indentation or space into a strbuf +(defprimitive add2sbuf_indent (sbuf :long depth) :void + "basilysgc_strbuf_add_indent((" sbuf "), (" depth "), 72)") + + +;; primitive to add an indented newline into a strbuf +(defprimitive add2sbuf_indentnl (sbuf :long depth) :void + "basilysgc_strbuf_add_indent((" sbuf "), (" depth "), 0)") + + +;; primitive to add a strbuf into a strbuf +(defprimitive add2sbuf_sbuf (sbuf asbuf) :void + "basilysgc_add_strbuf((" sbuf "), basilys_strbuf_str(" asbuf "))") + +;; primitive to add a string value, C encoded, into a strbuf +(defprimitive add2sbuf_cencstring (sbuf str) :void + "basilysgc_add_strbuf_cstr((" sbuf "), basilys_string_str(" str "))") + +;; primitive to add a strbuf, C encoded, into a strbuf +(defprimitive add2sbuf_cencstrbuf (sbuf asbuf) :void + "basilysgc_add_strbuf_cstr((" sbuf "), basilys_strbuf_str(" asbuf "))") + +;; primitive to add a string value, Ccomment encoded, into a strbuf +(defprimitive add2sbuf_ccomstring (sbuf str) :void + "basilysgc_add_strbuf_ccomment((" sbuf "), basilys_string_str(" str "))") + +;; primitive to add a strbuf, C encoded, into a strbuf +(defprimitive add2sbuf_ccomstrbuf (sbuf asbuf) :void + "basilysgc_add_strbuf_ccomment((" sbuf "), basilys_strbuf_str(" asbuf "))") + + +;; primitive to add into a strbuf a string as C ident (nonalphanum +;; replaced by _) +(defprimitive add2sbuf_cident (sbuf str) :void + "basilysgc_add_strbuf_cident((" sbuf "), basilys_string_str(" str "))") + +;; primitive to add into a strbuf the prefix of a string as C ident (nonalphanum +;; replaced by _) limited by a small length +(defprimitive add2sbuf_cidentprefix (sbuf str :long preflen) :void + "basilysgc_add_strbuf_cidentprefix((" sbuf "), basilys_string_str(" str "), (" preflen "))") + +;; primitive to add a long in decimal into a strbuf +(defprimitive add2sbuf_longdec (sbuf :long num) :void + "basilysgc_add_strbuf_dec((" sbuf "), (" num "))") + +;; primitive to add a long in hex into a strbuf +(defprimitive add2sbuf_longhex (sbuf :long num) :void + "basilysgc_add_strbuf_hex((" sbuf "), (" num "))") + +;; primitive to add a routine descr into a strbuf +(defprimitive add2sbuf_routinedescr (sbuf rout) :void + "basilysgc_add_strbuf((" sbuf "), basilys_routine_descrstr(" rout "))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; STRING primitives +;; primitive for testing if a value is a string +(defprimitive is_string (str) :long + " (basilys_magic_discr(" str ") == OBMAG_STRING)") +;; string equal +(defprimitive ==s (s1 s2) :long + "basilys_string_same((" s1 "), (" s2 "))") +;;; make a string +(defprimitive make_string (dis str) :value + "(basilysgc_new_stringdup((" dis "), basilys_string_str((" str "))))") +(defprimitive make_stringconst (dis :cstring cstr) :value + "(basilysgc_new_stringdup((" dis "), (" cstr ")))") + +(defprimitive string_length (str) :long + "basilys_string_length((" str "))") +;;; convert a strbuf into a string +(defprimitive strbuf2string (dis sbuf) :value + "(basilysgc_new_stringdup((" dis "), basilys_strbuf_str((" sbuf "))))") +;;; compute the naked basename +(defprimitive make_string_nakedbasename (dis str) :value + "(basilysgc_new_string_nakedbasename((" dis "), basilys_string_str((" str "))))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; OBJECT primitives +;; primitive to get an object length +(defprimitive object_length (ob) :long + "((long)basilys_object_length((" ob ")))") +;; primitive to get the nth field of an object +(defprimitive object_nth_field (ob :long n) :value + "(basilys_field_object((" ob "), (" n ")))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; MULTIPLEs primitives +;;;; test +(defprimitive is_multiple (mul) :long + "(basilys_magic_discr((" mul ")) == OBMAG_MULTIPLE)") +(defprimitive is_multiple_or_null (mul) :long + "((" mul ") == NULL || (basilys_magic_discr((" mul ")) == OBMAG_MULTIPLE))") +;;; make +(defprimitive make_multiple (discr :long ln) :value + "(basilysgc_new_multiple((" discr "), (" ln ")))") +(defprimitive make_tuple1 (discr v1) :value + "(basilysgc_new_mult1((" discr "),(" v1 ")))") +(defprimitive make_tuple2 (discr v1 v2) :value + "(basilysgc_new_mult2((" discr "),(" v1 "), (" v2 ")))") +(defprimitive make_tuple3 (discr v1 v2 v3) :value + "(basilysgc_new_mult3((" discr "),(" v1 "), (" v2 "), (" v3 ")))") +(defprimitive make_tuple4 (discr v1 v2 v3 v4) :value + "(basilysgc_new_mult4((" discr "),(" v1 "), (" v2 "), (" v3 "), (" v4 ")))") +(defprimitive make_tuple5 (discr v1 v2 v3 v4 v5) :value + "(basilysgc_new_mult5((" discr "),(" v1 "), (" v2 "), (" v3 "), (" v4 "), (" v5 ")))") +;; primitive to get the nth in a multiple +(defprimitive multiple_nth (mul :long n) :value + "(basilys_multiple_nth((" mul "), (" n ")))") +;; primitive to get the length of a multiple +(defprimitive multiple_length (v) :long + "(basilys_multiple_length((" v ")))") +;; be careful to avoid circularities +(defprimitive multiple_put_nth (mul :long n :value v) :void + " basilysgc_multiple_put_nth((" mul "), (" n "), (" v "))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; MAPOBJECTs primitives +;;;; test +(defprimitive is_mapobject (map) :long + "(basilys_magic_discr((" map ")) == OBMAG_MAPOBJECTS)") +;; primitive to get the allocated size of a mapobject +(defprimitive mapobject_size (map) :long + "(basilys_size_mapobjects(" map "))") +;; primitive to get the attribute count of a mapobject +(defprimitive mapobject_count (map) :long + "(basilys_count_mapobjects(" map "))") +;; primitive to get the nth attribute of a mapobject +(defprimitive mapobject_nth_attr (map :long n) :value + "(basilys_nthattr_mapobjects((" map "), (int)(" n ")))") +;; primitive to get the nth value of a mapobject +(defprimitive mapobject_nth_val (map :long n) :value + "(basilys_nthval_mapobjects((" map "), (int)(" n ")))") +;; primitive to get the value of an attribute in a mapobject +(defprimitive mapobject_get (map attr) :value + "(basilys_get_mapobjects((" map "), (" attr ")))") +;; primitive for making a new map of objects +(defprimitive make_mapobject (discr :long len) :value + " (basilysgc_new_mapobjects( (void*) (" discr "), (" len ")))") +;; primitive for putting into a map of objects +(defprimitive mapobject_put (map key val) :void + " basilysgc_put_mapobjects( (void*) (" map "), (" key "), (" val "))") +;; primivite for removing from a map of objects +(defprimitive mapobject_remove (map key) :void + " basilysgc_remove_mapobjects( (void*) (" map "), (" key "))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; MAPSTRINGs primitive +;; test +(defprimitive is_mapstring (map) :long +"(basilys_magic_discr((" map ")) == OBMAG_MAPSTRINGS)") +;; primitive to get the allocated size of a mapstring +(defprimitive mapstring_size (map) :long + "(basilys_size_mapstrings(" map "))") +;; primitive to get the attribute count of a mapstring +(defprimitive mapstring_count (map) :long + "(basilys_count_mapstrings(" map "))") +;; get an entry in a mapstring from a C string +(defprimitive mapstring_rawget (map :cstring cstr) :value + "(basilys_get_mapstrings((" map "), (" cstr ")))") +;; primitive for making a new map of strings +(defprimitive make_mapstring (discr :long len) :value + " (basilysgc_new_mapstrings( (void*) (" discr "), (" len ")))") +;; primitive for putting into a map of strings +(defprimitive mapstring_rawput (map :cstring key :value val) :void + " basilysgc_put_mapstrings( (void*) (" map "), (" key "), (" val "))") +(defprimitive mapstring_putstr (map keystr val) :void + " basilysgc_put_mapstrings((void*) (" map "), basilys_string_str(" keystr "), (" val "))") +(defprimitive mapstring_getstr (map keystr) :value + "(basilys_get_mapstrings((" map "), basilys_string_str(" keystr ")))") +;; primivite for removing from a map of strings +(defprimitive mapstring_rawremove (map :cstring key) :void + " basilysgc_remove_mapstrings( (void*) (" map "), (" key "))") + +;; primitive to make the nth stringattr of a mapobject +(defprimitive mapstring_nth_attrstr (map sdicr :long n) :value + "(basilysgc_new_stringdup((" sdicr "), basilys_nthattrraw_mapstrings((" map "), (int)(" n "))))") +;; primitive to get the nth value of a mapobject +(defprimitive mapstring_nth_val (map :long n) :value + "(basilys_nthval_mapstrings((" map "), (int)(" n ")))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; ROUTINEs primitives +;; test +(defprimitive is_routine (rou) :long +"(basils_magic_discr((" rou ")) == OBMAG_ROUTINE)") +;;; descriptive string of a routine +(defprimitive routine_descr (rou) :value + "(basilysgc_new_stringdup(basilys_routine_descrstr((" rou "))))") +;;; size of a routine +(defprimitive routine_size (rou) :long + "(basilys_routine_size((" rou ")))") +;;; nth comp in routine +(defprimitive routine_nth (rou :long ix) :value +"(basilys_routine_nth((" rou "), (int) (" ix ")))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; CLOSUREs primitives +;; test +(defprimitive is_closure (clo) :long + " (basilys_magic_discr((" clo ")) == OBMAG_CLOSURE)") +(defprimitive closure_size (clo) :long + " (basilys_closure_size((" clo ")))") +(defprimitive closure_routine (clo) :value + " (basilys_closure_routine((" clo ")))") +(defprimitive closure_nth (clo :long ix) :value + "(basilys_closure_nth((" clo "), (int)(" ix ")))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; boxed INTEGERs primitives +;; test +(defprimitive is_integerbox (ib) :long + "(basilys_magic_discr((" ib ")) == OBMAG_INT)") +;; to get the boxed integer use get_int +;; make +(defprimitive make_integerbox (discr :long n) :value + "(basilysgc_new_int((" discr "), (" n ")))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; BOX primitives (boxed values) +;; test +(defprimitive is_box (bx) :long + "(basilys_magic_discr((" bx ")) == OBMAG_BOX)") +;; safe fetch content +(defprimitive box_content (box) :value + "basilys_box_content((" box "))") +;; put into a box +(defprimitive box_put (box val) :void + "basilysgc_box_put((" box "), (" val "))") +;; make a box +(defprimitive make_box (discr valb) :value + "basilysgc_new_box((" discr "), (" valb "))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; LIST primitives +;; test +(defprimitive is_list (li) :long + "(basilys_magic_discr((" li ")) == OBMAG_LIST)") +(defprimitive is_list_or_null (li) :long + "((" li ") == NULL || (basilys_magic_discr((" li ")) == OBMAG_LIST))") +;; first pair of list +(defprimitive list_first (li) :value + "(basilys_list_first((" li ")))") +;; last pair of list +(defprimitive list_last (li) :value +"(basilys_list_last((" li ")))") +;; length of list +(defprimitive list_length (li) :long +"(basilys_list_length((" li ")))") +;; append into list +(defprimitive list_append (li el) :void +"basilysgc_append_list((" li "), (" el "))") +;; prepend into list +(defprimitive list_prepend (li el) :void +"basilysgc_prepend_list((" li "), (" el "))") +;; pop first from list +(defprimitive list_popfirst (li) :value + "(basilysgc_popfirst_list((" li ")))") +;; make list +(defprimitive make_list (discr) :value +"(basilysgc_new_list((" discr ")))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; PAIR primitives +;; test +(defprimitive is_pair (pa) :long + "(basilys_magic_discr((" pa ")) == OBMAG_PAIR)") +;; head +(defprimitive pair_head (pa) :value + "(basilys_pair_head((" pa ")))") +;; tail +(defprimitive pair_tail (pa) :value + "(basilys_pair_tail((" pa ")))") +;; change the head of a pair +(defprimitive pair_set_head (pa hd) :void + "basilysgc_pair_set_head((" pa "), (" hd "))") +;; length of a pair list +(defprimitive pair_listlength (pa) :long + "(basilys_pair_listlength((" pa ")))") +;; make +(defprimitive pair_make (discr hd tl) :value + "(basilysgc_new_pair((" discr "), (" hd "), (" tl ")))") + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; MIXINT primitives (use get_int to get the integer) +;; test +(defprimitive is_mixint (mi) :long + "(basilys_magic_discr((" mi ")) == OBMAG_MIXINT)") +;; get the value +(defprimitive mixint_val (mi) :value + "(basilys_val_mixint((" mi ")))") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; READ FILE primitive +(defprimitive read_file (filnam) :value + "(basilysgc_read_file (basilys_string_str((" filnam "))))") + +;; to signal an error in a basilys source with some additional string value +(defprimitive error_strv (loc :cstring msg :value strv) :void + "error(\"BASILYS ERROR: file %s line %d : %s - %s\"," + " basilys_string_str(basilys_val_mixint(" loc ")), " + " (int) basilys_num_mixint(" loc "), (" + msg + "), basilys_string_str((" strv ")))" + ) +;; signal a plain error in a basilys source +(defprimitive error_plain (loc :cstring msg) :void + "error(\"BASILYS ERROR: file %s line %d :: %s \"," + " basilys_string_str(basilys_val_mixint(" loc ")), " + " (int) basilys_num_mixint(" loc "), (" + msg "))" + ) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; the discriminant for name strings +(definstance discr_namestring class_discr + :predef DISCR_NAMESTRING + :obj_num OBMAG_STRING + :named_name (stringconst2val discr_namestring "DISCR_NAMESTRING") +;;; :disc_super discr_string ;; forward reference not allowed +) + +;;; the discriminant for strings +(definstance discr_string class_discr + :predef DISCR_STRING + :obj_num OBMAG_STRING + :named_name (stringconst2val discr_namestring "DISCR_STRING")) + +(unsafe_put_fields discr_namestring :disc_super discr_string) + +;;; the discriminant for verbatim strings (used for defprimitive) +(definstance discr_verbatimstring class_discr + :obj_num OBMAG_STRING + :predef DISCR_VERBATIMSTRING + :named_name (stringconst2val discr_namestring "DISCR_VERBATIMSTRING") + :disc_super discr_string +) + +;;; the discriminant for any reciever (used for sending to everything) +(definstance discr_anyrecv class_discr + :named_name (stringconst2val discr_namestring "DISCR_ANYRECV") +) + +(unsafe_put_fields discr_string :disc_super discr_anyrecv) + +;;; the discriminant for null reciever (used for sending to nil) +(definstance discr_nullrecv class_discr + :predef DISCR_NULLRECV + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_NULLRECV")) + +;;; the discriminant for strbuf +(definstance discr_strbuf class_discr + :obj_num OBMAG_STRBUF + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_STRBUF")) + +;;; the discriminant for integers +(definstance discr_integer class_discr + :predef DISCR_INTEGER + :obj_num OBMAG_INT + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_INTEGER")) + +;;; the discriminant for lists +(definstance discr_list class_discr + :predef DISCR_LIST + :obj_num OBMAG_LIST + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_LIST")) + +;;; the discriminant for pairs +(definstance discr_pair class_discr + :predef DISCR_PAIR + :obj_num OBMAG_PAIR + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_PAIR")) + +;;; the discriminant for multiples +(definstance discr_multiple class_discr + :predef DISCR_MULTIPLE + :obj_num OBMAG_MULTIPLE + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_MULTIPLE")) + +;;; the discriminant for sequence of fields +(definstance discr_seqfield class_discr + :predef DISCR_SEQFIELD + :obj_num OBMAG_MULTIPLE + :named_name (stringconst2val discr_namestring "DISCR_SEQFIELD") + :disc_super discr_multiple +) + +;;; the discriminant for boxes +(definstance discr_box class_discr + :predef DISCR_BOX + :obj_num OBMAG_BOX + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_BOX")) + +;;; the discriminant for maps of objects +(definstance discr_mapobjects class_discr + :predef DISCR_MAPOBJECTS + :obj_num OBMAG_MAPOBJECTS + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_MAPOBJECTS")) + +;;; the discriminant for maps of strings +(definstance discr_mapstrings class_discr + :predef DISCR_MAPSTRINGS + :obj_num OBMAG_MAPSTRINGS + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_MAPSTRINGS")) + +;;; the discriminant for sequence of classes +(definstance discr_seqclass class_discr + :predef DISCR_SEQCLASS + :obj_num OBMAG_MULTIPLE + :named_name (stringconst2val discr_namestring "DISCR_SEQCLASS") + :disc_super discr_multiple +) + + +;;; the discriminant for method dictionnary maps +(definstance discr_methodmap class_discr + :predef DISCR_METHODMAP + :obj_num OBMAG_MAPOBJECTS + :disc_super discr_mapobjects + :named_name (stringconst2val discr_namestring "DISCR_METHODMAP")) + +;;; the discriminant for charcode integers +(definstance discr_charinteger class_discr + :predef DISCR_CHARINTEGER + :obj_num OBMAG_INT + :named_name (stringconst2val discr_namestring "DISCR_CHARINTEGER") + :disc_super discr_integer +) + + +;;; the discriminant for mixedintegers +(definstance discr_mixedint class_discr + :predef DISCR_MIXEDINT + :obj_num OBMAG_MIXINT + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_MIXEDINT")) + + +;;; the discriminant for closures +(definstance discr_closure class_discr + :predef DISCR_CLOSURE + :obj_num OBMAG_CLOSURE + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_CLOSURE")) + +;;; the discriminant for routines +(definstance discr_routine class_discr + :predef DISCR_ROUTINE + :obj_num OBMAG_ROUTINE + :disc_super discr_anyrecv + :named_name (stringconst2val discr_namestring "DISCR_ROUTINE")) + +(defun install_ctype (ctyp) + (assert_msg "check ctyp" (is_a ctyp class_ctype)) + (debug_msg "install_ctype" ctyp (the_callcount)) + (let ( (ckw (unsafe_get_field :ctype_keyword ctyp)) ) + (assert_msg "check ckw" (is_a ckw class_keyword)) + (unsafe_put_fields ckw :symb_data ctyp) +)) + + +;;; every ctype should be predefined. normexp_defprimitive requires this +;;; while predef are somehow costly, we don't have that much many ctype-s +;;; and each of them nearly requires some code in basilys.h +;;; which should be enhanced for any new ctype +;; the C type for values +(definstance ctype_value class_ctype + :predef CTYPE_VALUE + :named_name (stringconst2val discr_namestring "CTYPE_VALUE") + :ctype_keyword (quote :value) + :ctype_cname (stringconst2val discr_namestring "basilys_ptr_t") + :ctype_parchar (stringconst2val discr_namestring "BPAR_PTR") + :ctype_parstring (stringconst2val discr_namestring "BPARSTR_PTR") + ;; value have to be passed specially, we need to pass the address of the pointer + :ctype_argfield (stringconst2val discr_namestring "bp_aptr") + :ctype_resfield (stringconst2val discr_namestring "bp_aptr") + ) +(install_ctype ctype_value) + +;; the C type for long +(definstance ctype_long class_ctype + :predef CTYPE_LONG + :named_name (stringconst2val discr_namestring "CTYPE_LONG") + :ctype_keyword (quote :long) + :ctype_cname (stringconst2val discr_namestring "long") + :ctype_parchar (stringconst2val discr_namestring "BPAR_LONG") + :ctype_parstring (stringconst2val discr_namestring "BPARSTR_LONG") + :ctype_argfield (stringconst2val discr_namestring "bp_long") + :ctype_resfield (stringconst2val discr_namestring "bp_longptr") + ) +(install_ctype ctype_long) + +;; the C type for gcc trees +(definstance ctype_tree class_ctype + :predef CTYPE_TREE + :named_name (stringconst2val discr_namestring "CTYPE_TREE") + :ctype_keyword ':tree + :ctype_cname (stringconst2val discr_namestring "tree") + :ctype_parchar (stringconst2val discr_namestring "BPAR_TREE") + :ctype_parstring (stringconst2val discr_namestring "BPARSTR_TREE") + :ctype_argfield (stringconst2val discr_namestring "bp_tree") + :ctype_resfield (stringconst2val discr_namestring "bp_treeptr") + ) +(install_ctype ctype_tree) + +;; the C type for void +(definstance ctype_void class_ctype + :predef CTYPE_VOID + :named_name (stringconst2val discr_namestring "CTYPE_VOID") + :ctype_keyword ':void + :ctype_cname (stringconst2val discr_namestring "void") + ;; void is never passed as argument or as extra result + ) +(install_ctype ctype_void) + +;; the C type for constant C strings +(definstance ctype_cstring class_ctype + :predef CTYPE_CSTRING + :named_name (stringconst2val discr_namestring "CTYPE_CSTRING") + :ctype_keyword ':cstring + :ctype_cname (stringconst2val discr_namestring "char*") + ;; constant strings are not passed as argument, this might change in the future + ) +(install_ctype ctype_cstring) + + +;; function to box a value + +(defun boxval (v) + (make_box discr_box v)) + +;; function to add a new symbol +(defun add_new_symbol_token (tokz str) + (let ( (sy (make_instance class_symbol :named_name str)) + (sydict (unsafe_get_field :tok_symboldict tokz)) + ) + (mapstring_putstr sydict str sy) + sy)) + +;; function to add a new keyword +(defun add_new_keyword_token (tokz str) + (let ( (kw (make_instance class_keyword :named_name str)) + (kwdict (unsafe_get_field :tok_keywdict tokz)) + ) + (mapstring_putstr kwdict str kw) + kw)) + +;; function to intern a symbol (or return the previous one) +(defun intern_symbol (tokz symb) + (assert_msg "check tokz" (is_a tokz class_tokenizer)) + (assert_msg "check sym" (is_a symb class_symbol)) + (let ( (syname (unsafe_get_field :named_name symb)) + (sydict (unsafe_get_field :tok_symboldict tokz)) + (oldsy (mapstring_getstr sydict syname)) ) + (or oldsy (progn + (mapstring_putstr sydict syname symb) +; (messageval_dbg "warm interning symbol" symb) + symb)) +)) + +;; function to intern a keyword (or return the previous one) +(defun intern_keyword (tokz keyw) + (assert_msg "check tokz" (is_a tokz class_tokenizer)) + (assert_msg "check keyw" (is_a keyw class_keyword)) + (let ( (kwname (unsafe_get_field :named_name keyw)) + (kwdict (unsafe_get_field :tok_keywdict tokz)) + (oldkw (mapstring_getstr kwdict kwname)) ) + (or oldkw (progn (mapstring_putstr kwdict kwname keyw) keyw)) +)) + +;;; container of a mapstring for cloning symbol, maping symbol names to boxed integer +(definstance container_clonemapstring class_container + :container_value (make_mapstring discr_mapstrings 200) +) + +(defun clone_symbol (symb) + (let ( (mapstr (unsafe_get_field :container_value container_clonemapstring)) + (synam (cond + ( (is_a symb class_named) + (unsafe_get_field :named_name symb)) + ( (is_string symb) + symb) + (:else + (debug_msg "clone_symbol bad symb" symb (the_callcount)) + (assert_msg "invalid symb in clone_symbol" ()) + (return)))) + (boxi (mapstring_getstr mapstr synam)) ) + (or (is_integerbox boxi) + (progn + (setq boxi (make_integerbox discr_integer 0)) + (mapstring_putstr mapstr synam boxi))) + (let ( (:long i (get_int boxi)) ) + (setq i (+i i 1)) + (put_int boxi i) + (make_instance class_clonedsymbol + :named_name synam + :csym_urank (make_integerbox discr_integer i))))) + +;; the tokenizer +(definstance tokenizer class_tokenizer + :predef TOKENIZER + :named_name (stringconst2val discr_namestring "TOKENIZER") + :tok_symboldict (make_mapstring discr_mapstrings 200) + :tok_keywdict (make_mapstring discr_mapstrings 100) + :tok_addsymbol add_new_symbol_token + :tok_addkeyw add_new_keyword_token + :tok_internsymbol intern_symbol + :tok_internkeyw intern_keyword + ) + +;;; iterate over a map of object - if the called f returns nil the +;;; iteration is stopped and returns the "failing" attr +(defun mapobject_iterate (map f) + (if (is_mapobject map) + (if (is_closure f) + (let ( (:long ix 0) ) + (forever maploop + (if (>=i ix (mapobject_size map)) (exit maploop)) + (let ( (curat (mapobject_nth_attr map ix)) + (curval (mapobject_nth_val map ix)) ) + (if curat + (if (null (f curat curval)) + (exit maploop curat)) + )) + (setq ix (+i ix 1)) + ))))) + +;;; iterate over a map of strings - if the called f returns nil the +;;; iteration is stopped +(defun mapstring_iterate (map f) + (if (is_mapstring map) + (if (is_closure f) + (let ( (:long ix 0) ) + (forever maploop + (if (>=i ix (mapstring_size map)) (exit maploop)) + (let ( (curat (mapstring_nth_attrstr map discr_string ix)) + (curval (mapstring_nth_val map ix)) ) + (if curat + (if (null (f curat curval)) + (exit maploop curat) + ))) + (setq ix (+i ix 1)) + ))))) + +;;; iterate in a dictionnary ie on the value in a map of strings - if +;;; the called f returns nil the iteration is stooped +(defun mapstringval_iterate (map f) + (if (is_mapstring map) + (if (is_closure f) + (let ( (:long ix 0) ) + (forever maploop + (if (>=i ix (mapstring_size map)) (exit maploop)) + (let ( (curval (mapstring_nth_val map ix)) ) + (if curval + (if (null (f curval)) + (exit maploop curval) + ))) + (setq ix (+i ix 1)) + ))))) + + +;;; iterator on a list, if the called f returns nil the iteration is stopped +(defun list_iterate (lis f) + (if (is_list lis) + (if (is_closure f) + (let ( (curpair (list_first lis)) ) + (forever lisloop + (if (not (is_pair curpair)) (exit lisloop)) + (let ( (curelem (pair_head curpair)) ) + (if (null (f curelem)) (exit lisloop curelem))) + (setq curpair (pair_tail curpair))))))) + +;; add to a destination list a source list +(defun list_append2list (dlist slist) + (or (is_list slist) (return dlist)) + (or (is_list dlist) (setq dlist (make_list discr_list))) + (list_iterate slist + (lambda (e) (list_append dlist e) slist)) + dlist) + +;;; iterator on a pairlist if the called f returns nil the iteration is stopped +(defun pairlist_iterate (pair f) + (if (is_closure f) + (forever pairloop + (or (is_pair pair) (exit pairloop)) + (let ( (curelem (pair_head pair)) ) + (if (null (f curelem)) (exit pairloop curelem))) + (setq pair (pair_tail pair))))) + +;;; map on a list (list_map lis f) where lis is (e1 ... en) is ((f e1) .... (f en)) +(defun list_map (lis f) +; (debug_msg "list_map lis" lis) +; (debug_msg "list_map f" f) + (and (is_list lis) + (is_closure f) + (let ( (reslis (make_list discr_list)) + (curpair (list_first lis)) ) + (forever lisloop + (if (not (is_pair curpair)) (exit lisloop)) + (let ( (curelem (pair_head curpair)) ) + (list_append reslis (f curelem))) + (setq curpair (pair_tail curpair))) +; (debug_msg "list_map reslis" reslis) + reslis + ))) + +;;; translate a list to a multiple - with each element transformed by a function f (default the identity) +(defun list_to_multiple (lis disc f) + (or disc (setq disc discr_multiple)) + (if (is_list lis) + (let ( (:long ln (list_length lis)) + (tup (make_multiple disc ln)) + (ixb (make_integerbox discr_integer 0)) + (curpair (list_first lis)) ) + (list_iterate + lis + (lambda (c) + (let ( (:long ix (get_int ixb)) + (tc (if (is_closure f) (f c) c)) + ) + (put_int ixb (+i ix 1)) + (multiple_put_nth tup ix tc)) + tup + )) + tup + ))) +;;; translate a pairlist to a tuple - with each element transformed by a function f (default the identity) +(defun pairlist_to_multiple (pair disc f) + (or disc (setq disc discr_multiple)) + (let ( (:long ln 0) ) + (let ( (curpair pair) ) + (forever loopln + (or (is_pair curpair) (exit loopln)) + (setq ln (+i ln 1)) + (setq curpair (pair_tail curpair)))) + (let ( (tup (make_multiple disc ln)) + (:long ix 0) + (curpair pair) + ) + (forever loopfi + (or (is_pair curpair) (exit loopfi)) + (let ( (c (pair_head curpair)) + (tc (if (is_closure f) (f c) c)) ) + (multiple_put_nth tup ix tc) + (setq ix (+i ix 1)) + (setq curpair (pair_tail curpair)))) + tup + ))) + +;;; iterator on tuple , if the called f returns nil the iteration is stopped +;;; the function is called with the component and its index +(defun multiple_iterate (tup f) + (if (is_multiple tup) + (if (is_closure f) + (let ( (:long ln (multiple_length tup)) + (:long ix 0) ) +; (messagenum_dbg "multipliterate ln" ln) + (forever tuploop + (if (>=i ix ln) (exit tuploop)) +; (messagenum_dbg "multipliterate ix" ix) + (let ( (curcomp (multiple_nth tup ix)) ) + (if (null (f curcomp ix)) (exit tuploop curcomp))) + (setq ix (+i ix 1))))))) + +;;; map on tuple -- with tup= (t0 t1 ... t_n-1) return ((f t0 0) (f t1 1) ... (f t_n-1 n-1) +(defun multiple_map (tup f) + (if (is_multiple tup) + (if (is_closure f) + (let ( (:long ln (multiple_length tup)) + (:long ix 0) + (res (make_multiple discr_multiple ln)) + ) + (forever tuploop + (if (>=i ix ln) (exit tuploop)) + (let ( (curcomp (multiple_nth tup ix)) ) + (multiple_put_nth res ix (f curcomp ix))) + (setq ix (+i ix 1))) + res)))) + + +;;; installation of a method in a class or discriminant +(defun install_method (cla sel fun) + (if (is_a cla class_discr) + (if (is_a sel class_selector) + (if (is_closure fun) + (let + ( (mapdict + (unsafe_get_field :disc_methodict cla)) ) + (if (is_mapobject mapdict) + (mapobject_put mapdict sel fun) + (let ( (newmapdict (make_mapobject discr_methodmap 30)) ) + (mapobject_put newmapdict sel fun) + (unsafe_put_fields cla :disc_methodict newmapdict) + ))))))) + + +(defclass class_debuginfo + :super class_root + :fields (dbgi_sbuf ;the produced stringbuf + dbgi_occmap ;the occurrence map (to avoid outputing twice the same object) + dbgi_maxdepth ;the boxed integer maximal depth + ) +) + +;;; selector to output for debugging +;;; reciever: any object or value +;;; arguments: the debuginfo (instance of class_debuginfo), the depth (long) +(defselector dbg_output class_selector + :named_name (stringconst2val discr_namestring "DBG_OUTPUT")) + + +;;; selector to output again for debugging +;;; reciever: any object (already output) +;;; arguments: the debuginfo (instance of class_debuginfo), the depth (long) +(defselector dbg_outputagain class_selector + :named_name (stringconst2val discr_namestring "DBG_OUTPUTAGAIN")) + + +;; somehow needed to be a separate function because of a bug in cold +(defun dbg_outobject (obj dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (let ( (occmap (unsafe_get_field :dbgi_occmap dbgi)) ) + ;(messageval_dbg "Dbg_OutObj obj" obj) + (if (is_mapobject occmap) + (let ( (occ (mapobject_get occmap obj)) ) + (checkcallstack_msg "in dbg_outobject") + ;(messageval_dbg "Dbg_OutObj occ" occ) + (if (is_integerbox occ) + (progn + ;(messageval_dbg "Dbg_Out,Again obj" obj) + (dbg_outputagain obj dbgi depth) + (put_int occ (+i (get_int occ) 1)) + ) + (let ( (newocc (make_integerbox discr_integer 1)) ) + (mapobject_put occmap obj newocc) + (checkcallstack_msg "in dbg_outobject output") + (dbg_output obj dbgi depth) + ))))) + ) + +(defun dbg_out (obj dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (checkcallstack_msg "start dbg_out") + (let ( (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (discr (discrim obj)) + ) + (if (need_dbg 0) + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (if (is_object obj) + (progn + (checkcallstack_msg "start dbg_out outobject") + (dbg_outobject obj dbgi depth) + ) + (if obj + (progn + (checkcallstack_msg "start dbg_out output") + (dbg_output obj dbgi depth) + ) + (if (is_strbuf sbuf) (add2sbuf_strconst sbuf "?_?") + ))) + (if (is_strbuf sbuf) + (add2sbuf_strconst sbuf "..") + ))))) + +;; utility to dump fields in an object from a given rank +(defun dbgout_fields (obj dbgi :long depth rank) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check obj" (is_object obj)) + (let ( (:long nbf (object_length obj)) + (cla (discrim obj)) + (:long ix rank) + (clafieldseq (unsafe_get_field :class_fields cla)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + ) + (assert_msg "check sbuf" (is_strbuf sbuf)) + (if (=i ix nbf) + (exit fldloop)) + (let ( (curfld (multiple_nth clafieldseq ix)) + (curval (object_nth_field obj ix)) + ) + (if curval + (let ( (:long curulen (strbuf_usedlength sbuf)) ) + (add2sbuf_indent sbuf depth) + (add2sbuf_string sbuf (unsafe_get_field :named_name curfld)) + (add2sbuf_strconst sbuf "=") + (dbg_out curval dbgi (+i depth 1)) + (let ( (:long deltalen (-i (strbuf_usedlength sbuf) curulen)) ) + (if (>i deltalen 100) + (add2sbuf_indentnl sbuf depth))) + ))) + (setq ix (+i ix 1)) + ) + ))) + + +;; string debug output +(defun dbgout_string_method (self dbgi :long depth) +; (message_dbg "DbgOut_String") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + ) + (if (== dis DISCR_STRING) + (progn + (add2sbuf_strconst sbuf " \"") + (add2sbuf_cencstring sbuf self) + (add2sbuf_strconst sbuf "\"") + ) + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "\"") + (add2sbuf_cencstring sbuf self) + (add2sbuf_strconst sbuf "\"") + ))))) + +(install_method discr_string dbg_output dbgout_string_method) +(install_method discr_namestring dbg_output dbgout_string_method) +(install_method discr_verbatimstring dbg_output dbgout_string_method) + +;; integer debug output +(defun dbgout_integer_method (self dbgi :long depth) +; (message_dbg "DbgOut_Integer") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + ) + (if (== dis DISCR_INTEGER) + (progn + (add2sbuf_strconst sbuf " #") + (add2sbuf_longdec sbuf (get_int self))) + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "#") + (add2sbuf_longdec sbuf (get_int self))) + )))) + +(install_method discr_integer dbg_output dbgout_integer_method) +(install_method discr_charinteger dbg_output dbgout_integer_method) + +;; mixint debug value +(defun dbgout_mixint_method (self dbgi :long depth) +; (message_dbg "DbgOut_Mixint") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + ) + (if (== dis DISCR_MIXEDINT) + (progn + (add2sbuf_strconst sbuf " #[") + (add2sbuf_longdec sbuf (get_int self))) + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "#[") + (add2sbuf_longdec sbuf (get_int self))) + ) + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (progn + (add2sbuf_strconst sbuf ",") + (dbg_out (mixint_val self) dbgi (+i depth 1)) + ) + (add2sbuf_strconst sbuf ",..") + ) + (add2sbuf_strconst sbuf "]") + ))) +(install_method discr_mixedint dbg_output dbgout_mixint_method) + +;; multiple debug out +(defun dbgout_multiple_method (self dbgi :long depth) +; (message_dbg "DbgOut_Multiple") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + ) + (if (== dis DISCR_MULTIPLE) + (add2sbuf_strconst sbuf " *") + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "*"))) + (let ( (:long ln (multiple_length self)) ) + (add2sbuf_longdec sbuf ln) + (add2sbuf_strconst sbuf "[") + (if (need_dbg depth) + (let ( (:long ix 0) ) + (forever comploop + (if (>=i ix ln) (exit comploop)) + (add2sbuf_indent sbuf depth) + (let ( (:long curulen (strbuf_usedlength sbuf)) ) + (dbg_out (multiple_nth self ix) dbgi (+i 1 depth)) + (and (>i (-i (strbuf_usedlength sbuf) curulen) 100) + (=i ix (closure_size self)) + (exit outloop)) + (add2sbuf_indent sbuf depth) + (let ( (:long curulen (strbuf_usedlength sbuf)) ) + (dbg_out (closure_nth self ix) dbgi (+i depth 1)) + (if (>i (-i (strbuf_usedlength sbuf) curulen) 100) + (add2sbuf_indentnl sbuf (+i 1 depth)))) + (setq ix (+i ix 1)) + ))) + (add2sbuf_strconst sbuf ">") + ))) + +(install_method discr_closure dbg_output dbgout_closure_method) + + + +;; list debug out +(defun dbgout_list_method (self dbgi :long depth) + ; (message_dbg "DbgOut_List") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) ) + (if (== dis DISCR_LIST) + (add2sbuf_strconst sbuf " *li(") + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "("))) + (let ( + (curpair (list_first self)) + (:long ix 0) + ) + (checkcallstack_msg "before loop dbgout_list_method") + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (forever listloop + (checkcallstack_msg "start loop dbgout_list_method") + (if (>i ix 300) + (progn + (add2sbuf_strconst sbuf "...") + (exit listloop))) + (if (not (is_pair curpair)) (exit listloop)) + (add2sbuf_indent sbuf depth) + (let ( (:long curulen (strbuf_usedlength sbuf)) ) + (dbg_out (pair_head curpair) dbgi (+i depth 1)) + (setq curpair (pair_tail curpair)) + (checkcallstack_msg "near endloop dbgout_list_method") + (if curpair + (setq ix (+i ix 1)) + (exit listloop)) + (if (>i (-i (strbuf_usedlength sbuf) curulen) 100) + (add2sbuf_indentnl sbuf (+i 1 depth)))) + )) + (checkcallstack_msg "end dbgout_list_method") + (add2sbuf_strconst sbuf ")"))) + )) +(install_method discr_list dbg_output dbgout_list_method) + +;; pair debug output +(defun dbgout_pair_method (self dbgi :long depth) +; (message_dbg "DbgOut_Pair") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) ) + (if (== dis DISCR_PAIR) + (add2sbuf_strconst sbuf " *pa(.") + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "(."))) + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (progn + (dbg_out (pair_head self) dbgi (+i depth 1)) + (add2sbuf_indent sbuf depth) + (dbg_out (pair_tail self) dbgi (+i depth 1)))) + (add2sbuf_strconst sbuf ".)")))) + +(install_method discr_pair dbg_output dbgout_pair_method) + + +;;; the cold compiler prefers this way... to have an internal function +;;; to output an entry... +(defun dbgoutinternal_mapobj_entry (at va dbgi nextdepthbox) + (let ( (:long nextdepth (get_int nextdepthbox)) + (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) ) + (assert_msg "check sbuf" (is_strbuf sbuf)) + (add2sbuf_indentnl sbuf nextdepth) + (add2sbuf_strconst sbuf "** ") + (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 0) + (dbg_outobject at dbgi nextdepth) + (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth) + (add2sbuf_strconst sbuf " ==") + (add2sbuf_indent sbuf (+i nextdepth 1)) + (dbg_out va dbgi nextdepth) + (add2sbuf_strconst sbuf "; ") + )) + +(defun dbgout_mapobject_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + ) + (if (== dis DISCR_MAPOBJECTS) + (add2sbuf_strconst sbuf " {") + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "{"))) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longdec sbuf (mapobject_count self)) + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (let ( + (nextdepthbox (make_integerbox discr_integer (+i 1 depth))) + ) + (mapobject_iterate + self + (lambda (at va) + (dbgoutinternal_mapobj_entry at va dbgi nextdepthbox) + at + )))) + (add2sbuf_strconst sbuf "}")))) +(install_method discr_mapobjects dbg_output dbgout_mapobject_method) + +;; multiple debug out +(defun dbgout_mapstring_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (:long ix 0) + ) + (if (== dis DISCR_MAPSTRINGS) + (add2sbuf_strconst sbuf " <(") + (progn + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "<("))) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longdec sbuf (mapstring_count self)) + (forever mapstrloop + (if (>i ix (mapstring_size self)) (exit mapstrloop)) + (let ( (curstr (mapstring_nth_attrstr self discr_string ix)) + (curat (mapstring_nth_val self ix)) ) + (if (and (is_string curstr) (notnull curat)) + (progn + (add2sbuf_indentnl sbuf (+i depth 1)) + (add2sbuf_strconst sbuf "!*") + (dbg_out curstr dbgi (+i depth 1)) + (add2sbuf_strconst sbuf " => ") + (add2sbuf_indent sbuf (+i depth 1)) + (dbg_out curat dbgi (+i depth 2)) + ))) + (setq ix (+i ix 1))) + (add2sbuf_strconst sbuf " )>")))) +(install_method discr_mapstrings dbg_output dbgout_mapstring_method) + +;;;; generic object debug +(defun dbgout_anyobject_method (self dbgi :long depth) +; (message_dbg "DbgOut_AnyObject") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) ) + (add2sbuf_strconst sbuf " |") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self)) + (let ( (:long onum (obj_num self)) ) + (if onum + (progn + (add2sbuf_strconst sbuf "#") + (add2sbuf_longdec sbuf onum)))) + (add2sbuf_strconst sbuf "{") + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (dbgout_fields self dbgi (+i depth 1) 0) + ) + (add2sbuf_strconst sbuf "}") + ))) +(install_method class_root dbg_output dbgout_anyobject_method) + +;;;; generic value debug +(defun dbgout_anyrecv_method (self dbgi :long depth) +; (message_dbg "DbgOut_AnyObject") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) ) + (add2sbuf_strconst sbuf " ?.") + (if (is_a dis class_named) (add2sbuf_string sbuf (unsafe_get_field :named_name dis))) + (add2sbuf_strconst sbuf ".? ") +))) +(install_method discr_anyrecv dbg_output dbgout_anyrecv_method) + +;;; generic object debug outputagain +(defun dbgoutagain_anyobject_method (self dbgi :long depth) +; (message_dbg "DbgOutAgain_AnyObject") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) ) + (add2sbuf_strconst sbuf " ^^|") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self)) + ))) +(install_method class_root dbg_outputagain dbgoutagain_anyobject_method) + +;;;; named object debug +(defun dbgout_namedobject_method (self dbgi :long depth) +; (message_dbg "DbgOut_NamedObject") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (onam (unsafe_get_field :named_name self)) + (oprop (unsafe_get_field :prop_table self)) + ) + (assert_msg "check sbuf" (is_strbuf sbuf)) + (add2sbuf_strconst sbuf "`") + (add2sbuf_string sbuf onam) + (add2sbuf_strconst sbuf "|") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self)) + (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) + (let ( (:long onum (obj_num self)) ) + (if onum + (progn + (add2sbuf_strconst sbuf "#") + (add2sbuf_longdec sbuf onum))) + (add2sbuf_strconst sbuf "{") + (if oprop + (progn + (add2sbuf_strconst sbuf "prop=") + (dbg_out oprop dbgi (+i depth 2)) + )) + (dbgout_fields self dbgi (+i depth 1) 2) + (add2sbuf_strconst sbuf "}") + ))))) +(install_method class_named dbg_output dbgout_namedobject_method) + +;;;; named object debug outputagain +(defun dbgoutagain_namedobject_method (self dbgi :long depth) +; (message_dbg "DbgOutAgain_NamedObject") + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (onam (unsafe_get_field :named_name self)) + ) + (add2sbuf_strconst sbuf " ^^`") + (add2sbuf_string sbuf onam) + (add2sbuf_strconst sbuf "|") + (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self)) + ))) +(install_method class_named dbg_outputagain dbgoutagain_namedobject_method) + +;;;; symbol output debug & again +(defun dbgout_symbol_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check self" (is_a self class_symbol)) + (if (<=i depth 0) + (dbgout_namedobject_method self dbgi 0) + (dbgoutagain_symbol_method self dbgi depth))) +(install_method class_symbol dbg_output dbgout_symbol_method) + +(defun dbgoutagain_symbol_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check self" (is_a self class_symbol)) + (let ( (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (onam (unsafe_get_field :named_name self)) + ) + (if (need_dbg 0) + (progn + (add2sbuf_strconst sbuf " $") + (add2sbuf_string sbuf onam) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self)))))) +(install_method class_symbol dbg_outputagain dbgoutagain_symbol_method) + +;;;; keyword output debug & again +(defun dbgout_keyword_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check self" (is_a self class_keyword)) + (if (<=i depth 0) + (dbgout_namedobject_method self dbgi 0) + (dbgoutagain_keyword_method self dbgi depth))) +(install_method class_keyword dbg_output dbgout_keyword_method) + +(defun dbgoutagain_keyword_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check self" (is_a self class_keyword)) + (let ( (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (onam (unsafe_get_field :named_name self)) + ) + (if (need_dbg 0) + (progn + (add2sbuf_strconst sbuf " $:") + (add2sbuf_string sbuf onam) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self)))))) +(install_method class_keyword dbg_outputagain dbgoutagain_keyword_method) + +;;;; clonedsymbol output debug & again +(defun dbgout_clonedsymbol_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check self" (is_a self class_clonedsymbol)) + (if (<=i depth 0) + (dbgout_namedobject_method self dbgi 0) + (dbgoutagain_clonedsymbol_method self dbgi depth) + )) +(install_method class_clonedsymbol dbg_output dbgout_clonedsymbol_method) + +(defun dbgoutagain_clonedsymbol_method (self dbgi :long depth) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (ourank (unsafe_get_field :csym_urank self)) + (:long lrk (get_int ourank)) + (onam (unsafe_get_field :named_name self)) ) + (add2sbuf_strconst sbuf " $$") + (add2sbuf_string sbuf onam) + (add2sbuf_strconst sbuf ":") + (add2sbuf_longdec sbuf lrk) + (add2sbuf_strconst sbuf "/") + (add2sbuf_longhex sbuf (obj_hash self))))) +(install_method class_clonedsymbol dbg_outputagain dbgoutagain_clonedsymbol_method) + +;;;; ctype output debug & again +(defun dbgout_ctype_method (self dbgi :long depth) + (assert_msg "check dbgi" (is_a dbgi class_debuginfo)) + (assert_msg "check self" (is_a self class_ctype)) + (if (<=i depth 0) + (dbgout_namedobject_method self dbgi 0) + (dbgoutagain_ctype_method self dbgi depth) +)) +(install_method class_ctype dbg_output dbgout_ctype_method) + +(defun dbgoutagain_ctype_method (self dbgi :long depth) + (if (need_dbg 0) + (let ( (dis (discrim self)) + (sbuf (unsafe_get_field :dbgi_sbuf dbgi)) + (onam (unsafe_get_field :named_name self)) ) + (add2sbuf_strconst sbuf " $!") + (add2sbuf_string sbuf onam) + (add2sbuf_strconst sbuf "!/") + (add2sbuf_longhex sbuf (obj_hash self))))) +(install_method class_ctype dbg_outputagain dbgoutagain_ctype_method) + +;;;;;;;;;;;;;;;;;;;;;;;; debug message function +(defprimitive the_dbgcounter () :long "basilys_dbgcounter") +(defprimitive increment_dbgcounter () :void "(void) ++basilys_dbgcounter") + +(defun debug_msg (msgstr val :long count) + (if (need_dbg 0) + (let ( (:long dbgcounter (progn (increment_dbgcounter) (the_dbgcounter))) + (sbuf (make_strbuf discr_strbuf)) + (occmap (make_mapobject discr_mapobjects 50)) + (boxedmaxdepth (make_integerbox discr_integer 14)) + (dbgi (make_instance class_debuginfo + :dbgi_sbuf sbuf + :dbgi_occmap occmap + :dbgi_maxdepth boxedmaxdepth)) + ) +; (message_dbg "Debug_Msg+") + (outnum_dbg "!*#" dbgcounter ":") + (outstr_dbg msgstr) + (if (>i count 0) (outnum_dbg " !" count ": ")) + (dbg_out val dbgi 0) + (outstrbuf_dbg sbuf) + (outnewline_dbg) +; (message_dbg "Debug_Msg-") + ))) + +;;;; the class for environments +(defclass class_environment + :super class_root + :fields (env_bind ;the map of bindings + env_prev ;the previous environment + env_proc ;the procedure of this environment +)) + +;; the (super-)class of any binding +(defclass class_any_binding + :super class_root + :fields (binder) +) + +;;; superclass of exported bindings +(defclass class_exported_binding + :super class_any_binding + :fields ( ) +) + +;; macro binding +(defclass class_macro_binding + :super class_exported_binding + :fields (mbind_expanser)) + + +;; value binding - as exported +(defclass class_value_binding + :super class_exported_binding + :fields (vbind_value +)) + +; formal binding (used in generated defprimitive) +(defclass class_formal_binding + :super class_any_binding + :fields (fbind_type) + ;;the obj_num is the argument rank + :predef CLASS_FORMAL_BINDING) + + +;;; fixed bindings are defined in a compilation unit and can be implemented as constants in routine +(defclass class_fixed_binding + :super class_any_binding + :fields () +) + +;; selector binding +(defclass class_selector_binding + :super class_fixed_binding + :fields (sbind_selectordef ;the "source" defselector + sbind_selectordata ;the compiled data + ;; maybe we need an selectorval for the actual value + ) +) + +;; primitive binding +(defclass class_primitive_binding + :super class_fixed_binding + :fields (pbind_primdef ;the source defprimitive + pbind_primitive ;the primitive proper + pbind_primdata ;the primitive data as compiled +)) + + +;; function binding +(defclass class_function_binding + :super class_fixed_binding + :fields (fubind_defun ;the source definition + fubind_fundata ;compiled data +)) + +;; class binding +(defclass class_class_binding + :super class_fixed_binding + :fields (cbind_defclass ;the source definition + cbind_class ;the built class + cbind_cladata ;compiled data +)) + +;; field binding +(defclass class_field_binding + :super class_fixed_binding + :fields (flbind_clabind ;the class binding + flbind_field ;the field proper + flbind_fdata ;the compiled field data +)) + +;; let binding +(defclass class_let_binding + :super class_any_binding + :fields (letbind_type ;the ctype + letbind_expr ;the expression + letbind_loc ;the optional src location + )) + +;; normalized let binding +(defclass class_normlet_binding + :super class_let_binding + :fields ()) ;no additional field, but letbind_expr is "normal" + +;; label binding +(defclass class_label_binding + :super class_any_binding + :fields (labind_loc ;location of the label +;;; following fields are filled later in the compilation phase + labind_clonsy ;unique cloned symbol + labind_res ;result localvar +)) + +;; make a fresh environment +(defun fresh_env (parenv) + (if (is_a parenv class_environment) + (make_instance class_environment + :env_bind (make_mapobject discr_mapobjects 6) + :env_prev parenv))) + +;; the initial environment +(definstance initial_environment class_environment + :env_bind (make_mapobject discr_mapobjects 500) +) + +;; find a binding inside an environment +(defun find_env (env binder) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check binder" (is_object binder)) + (forever findloop + (if (not (is_a env class_environment)) (exit findloop)) + (let ( (bindmap (unsafe_get_field :env_bind env)) ) + (assert_msg "check bindmap" (is_mapobject bindmap)) + (let ( (bnd (mapobject_get bindmap binder)) ) + (if bnd (exit findloop bnd)) + )) + (setq env (unsafe_get_field :env_prev env)) + ) + ) + +; find a binding inside an environment and also returns the reversed list of enclosing procedures +(defun find_enclosing_env (env binder) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check binder" (is_object binder)) + (let ( (proclist (make_list discr_list)) ) + (forever findloop + (if (not (is_a env class_environment)) (exit findloop)) + (let ( (bindmap (unsafe_get_field :env_bind env)) + (eproc (unsafe_get_field :env_proc env)) + ) + (assert_msg "check bindmap" (is_mapobject bindmap)) + (let ( (bnd (mapobject_get bindmap binder)) ) + (if bnd (return bnd proclist))) + (if eproc (list_prepend proclist eproc)) + (setq env (unsafe_get_field :env_prev env)) + )))) + +;; put a binding at top of an environment +(defun put_env (env binding) + (assert_msg "check env" (is_a env class_environment)) + (if (not (is_a binding class_any_binding)) + (progn + (debug_msg "put_env invalid binding" binding (the_callcount)) + (shortbacktrace_dbg "put_env invalid binding" 15))) + (assert_msg "check binding" (is_a binding class_any_binding)) + (let ( (bindmap (unsafe_get_field :env_bind env)) + (binder (unsafe_get_field :binder binding)) + ) + (if (not (is_object binder)) + (progn + (debug_msg "put_env bad binder in binding" binding (the_callcount)) + (debug_msg "put_env bad binder" binder (the_callcount)) + (shortbacktrace_dbg "put_env bad binder in binding" 5))) + (assert_msg "check bindmap" (is_mapobject bindmap)) + (assert_msg "check binder" (is_object binder)) + (mapobject_put bindmap binder binding) + )) + +;; overwrite a binding in the environment where it has been already bind +(defun overwrite_env (env binding) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check binding" (is_a binding class_any_binding)) + (let ( (binder (unsafe_get_field :binder binding)) ) + (assert_msg "check binder" (is_object binder)) + (forever findloop + (if (not (is_a env class_environment)) (exit findloop)) + (let ( (bindmap (unsafe_get_field :env_bind env)) ) + (assert_msg "check bindmap" (is_mapobject bindmap)) + (let ( (oldbinding (mapobject_get bindmap binder)) ) + (if oldbinding + (progn + (mapobject_put bindmap binder binding) + (exit findloop oldbinding)) + )) + (setq env (unsafe_get_field :env_prev env)) + )))) + +;;;;;;;;;;;;;;;;;;;; source program elements +(defclass class_src + :super class_root + :fields (src_loc ;the source location (if any) + ) +) + + +;;; source application +(defclass class_src_apply + :super class_src + :fields (sapp_fun ;the function to apply + sapp_args ;the arguments tuple + )) + +;;; source primitive call +(defclass class_src_primitive + :super class_src + :fields (sprim_oper ;the primitive operation + sprim_args ;the arguments tuple + )) + +;;; source progn +(defclass class_src_progn + :super class_src + :fields (sprogn_body ;the body tuple +)) + +;;; source progn +(defclass class_src_return + :super class_src + :fields (sreturn_body ;the body tuple +)) + +;;;; source setq +(defclass class_src_setq + :super class_src + :fields (sstq_var + sstq_expr)) + + +;;;; source quote +(defclass class_src_quote + :super class_src + :fields (squoted +)) +;;; superclass for all source definitions +(defclass class_srcdef + :super class_src + :fields (sdef_name ;defined name +)) + +;;; superclass for all definitions with formal arglist +(defclass class_srcdeformal + :super class_srcdef + :fields (sformal_args ;formal arguments binding tuple +)) + +;;;; define a function +(defclass class_src_defun + :super class_srcdeformal + :fields (sfun_body ;body sequence +)) + +;;; define a primitive +(defclass class_src_defprimitive + :super class_srcdeformal + :fields (sprim_type ;result type of primitive + sprim_expansion ;primitive expansion +)) + +;; define an object (common to instance, class, selector) +(defclass class_src_defobjcommon + :super class_srcdef + :fields (sobj_predef ;the predefined rank + sobj_docstr ;documentation string +)) + +;; define a class +;;;; the class has been built (at compile time), but we need a +;;;; srcdefclass to actually generate code +(defclass class_src_defclass + :super class_src_defobjcommon + :fields (sclass_clabind ;the binding of the class + sclass_superbind ;binding of superclass (or nil if none) + sclass_fldbinds ;the sequence of (own field bindings) +)) + + +;; define an instance +(defclass class_src_definstance + :super class_src_defobjcommon + :fields (sinst_class ;the class of the instance + sinst_clabind ;the classbinding of the instance + sinst_objnum ;the object number symbol or integer + sinst_fields ;the sequence of field assignment +)) + +;; a field assignment +(defclass class_src_fieldassign + :super class_src + :fields (sfla_field ;the field + sfla_expr ;the expression +)) + + +;; make an instance +(defclass class_src_make_instance + :super class_src + :fields (smins_class ;the class to be instantiated + smins_clabind ;its (class|value) binding + smins_fields ;the sequence of field assignment +)) + +;;; source unsafe get field +(defclass class_src_unsafe_get_field + :super class_src + :fields (suget_obj ;the object expression + suget_field ;the field keyword +)) + +;; source unsafe put fields +(defclass class_src_unsafe_put_fields + :super class_src + :fields (suput_obj ;the object expression + suput_fields ;the sequence of field assignment +)) + + +;; a conditional (if, and, cond) +(defclass class_src_if + :super class_src + :fields (sif_test + sif_then + sif_else +)) + + +;; an or +;;; since (OR a1 a2) is (IF a1 a1 a2) we need to normalize it to avoid evaluating twice a1 +;;; so there is no normalized or... (only normalized if-s) +(defclass class_src_or + :super class_src + :fields (sor_disj ;tuple of disjuncts +)) + + + +;;; letbinding source +(defclass class_src_letbinding + :super class_src + :fields (sletb_type ;the type of the binding + sletb_binder ;the binder (variable) + sletb_expr ;the expression +)) + +;; let source +(defclass class_src_let + :super class_src + :fields (slet_bindings ;the tuple of letbinding-s + slet_body ;the body tuple +)) + +;; lambda +(defclass class_src_lambda + :super class_src + :fields (slam_argbind ;tuple of argument bindings + slam_body ;tuple for body +)) + + +;;; forever & exit share a common label +(defclass class_src_labelled + :super class_src + :fields (slabel_bind ;the label binding +)) + +;; forever +(defclass class_src_forever + :super class_src_labelled + :fields (sfrv_body ;tuple for body +)) + +;; exit +(defclass class_src_exit + :super class_src_labelled + :fields ( sexi_body ;tuple for body +)) + + +;;;;;;;;;;;;;;;;;;;; first pass, macro expansion + +;;get the n-th son of a sexpr +(defun sexpr_nth_son (sexp :long n) + (if (is_a sexp class_sexpr) + (let ( (:long ix 0) + (curpair (list_first (unsafe_get_field :sexp_contents sexp))) + ) + (forever nthloop + (or (is_pair curpair) (exit nthloop)) + (if (==i ix n) (exit nthloop (pair_head curpair))) + (setq ix (+i ix 1)) + (setq curpair (pair_tail curpair)) +)))) + +;;expand all but the first element of a list as a tuple +(defun expand_restlist_as_tuple (arglist env mexpander) + (assert_msg "check end" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (assert_msg "check arglist" (is_list arglist)) + (let ( (:long nbarg (list_length arglist)) + (:long ix 0) + (curpair (pair_tail (list_first arglist))) + (tup (make_multiple discr_multiple (-i nbarg 1))) + ) + (forever exploop + (if (not curpair) (exit exploop)) + (assert_msg "check curpair" (is_pair curpair)) + (let ( (curarg (pair_head curpair)) + (curexp (macroexpand_1 curarg env mexpander)) + ) + (multiple_put_nth tup ix curexp) + (setq ix (+i ix 1)) + (setq curpair (pair_tail curpair)) + )) + tup + )) + +;;expand all of a pairlist as a tuple +(defun expand_pairlist_as_tuple (pair env mexpander) + (assert_msg "check end" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (let ( (:long nbarg (pair_listlength pair)) + (:long ix 0) + (tup (make_multiple discr_multiple nbarg)) ) + (forever exploop + (if (not (is_pair pair)) (exit exploop)) + (let ( (curarg (pair_head pair)) + (curexp (macroexpand_1 curarg env mexpander)) + ) + (multiple_put_nth tup ix curexp) + (setq ix (+i ix 1)) + (setq pair (pair_tail pair)) + )) + tup +)) + + +;;; expand an s-expression known to be an application +(defun expand_apply (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check end" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (let ( (scont (unsafe_get_field :sexp_contents sexpr)) + (sloc (unsafe_get_field :loca_location sexpr)) + (soper (pair_head (list_first scont))) + (xargtup (expand_restlist_as_tuple scont env mexpander)) + (xoper (if (is_a soper class_sexpr) + (macroexpand_1 soper env mexpander) + soper)) + ) + (make_instance class_src_apply + :src_loc sloc + :sapp_fun xoper + :sapp_args xargtup))) + + +;;; expand a keywordfun s-expression +;;; not implemented yet, but might later be useful for stuff like +;;;;; (:fieldname obj) to get a field +;;;;; (:selector recv arg...) to send a message +(defun expand_keywordfun (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check end" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (error_plain (unsafe_get_field :loca_location sexpr) "keywordoper not implemented") + (assert_msg "@@@ expand_keywordfun NOT IMPLEMENTED" 0) +) + +(defun macroexpand_1 (sexpr env mexpander) + (if (null mexpander) (setq mexpander macroexpand_1)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (if (is_a sexpr class_sexpr) + (let ( (scont (unsafe_get_field :sexp_contents sexpr)) + (soper (pair_head (list_first scont))) ) + (cond ( (is_a soper class_symbol) + (let ( (opbind (find_env env soper)) ) + (cond ( (is_a opbind class_macro_binding) + (let ( (mexp (unsafe_get_field :mbind_expanser opbind)) ) + (assert_msg "check mexp" (is_closure mexp)) + (mexp sexpr env mexpander)) ) + ( (is_a opbind class_selector_binding) + (assert_msg "@@@ macroexpand_1 selector binding NOT IMPLEMENTED" 0) + ) + ( (is_a opbind class_primitive_binding) + (expand_primitive opbind sexpr env mexpander) + ) + (:else (expand_apply sexpr env mexpander)) + ) + )) + ( (is_a soper class_keyword) + (expand_keywordfun sexpr env mexpander) ) + ;; the empty list is expanded as nil + ( (==i (list_length scont) 0) + ()) + (:else + (expand_apply sexpr env mexpander)) + )) + sexpr)) + +;;; expand a primitive s-expression +(defun expand_primitive (opbind sexpr env mexpander) + (assert_msg "check opbind" (is_a opbind class_primitive_binding)) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check end" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + (let ( (scont (unsafe_get_field :sexp_contents sexpr)) + (sloc (unsafe_get_field :loca_location sexpr)) + (soper (pair_head (list_first scont))) + (xargtup (expand_restlist_as_tuple scont env mexpander)) + (sprim (unsafe_get_field :pbind_primitive opbind)) + ) + (assert_msg "check sprim" (is_a sprim class_primitive)) + (make_instance class_src_primitive + :src_loc sloc + :sprim_oper sprim + :sprim_args xargtup))) + + + +(defun macroexpand_toplevel_list (slist env) + ;; (messageval_dbg "macroexpand_toplevel_list Env" env) + (debug_msg "macroexpand_toplevel_list env" env (the_callcount)) + (debug_msg "macroexpand_toplevel_list slist" slist (the_callcount)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check slist" (is_list slist)) + (let ( (xlist (list_map slist + (lambda (sexp) + (debug_msg "macroexpand_toplevel_list sexp" sexp (the_callcount)) + (macroexpand_1 sexp env macroexpand_1)))) ) + (debug_msg "macroexpand_toplevel_list res xlist" xlist (the_callcount)) + xlist + )) + +;;; expand an s-expression into a tuple of formal bindings +(defun lambda_arg_bindings (formalsexp) +; (debug_msg "lambda_arg_bindings formalsexp" formalsexp (the_callcount)) + ;; special case for null arglist + (if (null formalsexp) + (progn + (return (make_multiple discr_multiple 0)))) + (assert_msg "check formalsexp" (is_a formalsexp class_sexpr)) + (let ( (:long argrk 0) + (argtype ctype_value) + (arglist (unsafe_get_field :sexp_contents formalsexp)) + (argloc (unsafe_get_field :loca_location formalsexp)) + (argmap (make_mapobject discr_mapobjects (+i 4 (list_length arglist)))) + (bndlist (make_list discr_list)) + (curpair (list_first arglist)) + ) + ;;; first loop on arg + (forever argloop + (if (null curpair) (exit argloop)) + (assert_msg "check curpair" (is_pair curpair)) + (let ( (curarg (pair_head curpair)) ) + (cond + ( (is_a curarg class_keyword) + (let ( (cty (unsafe_get_field :symb_data curarg)) ) + (if (and (is_a cty class_ctype) + (== (unsafe_get_field :ctype_keyword cty) curarg)) + (setq argtype cty) + (progn + (error_strv argloc "invalid keyword in formal arglist" + (unsafe_get_field :named_name curarg)) + ) + ))) + ( (is_a curarg class_symbol) + (if (mapobject_get argmap curarg) + (error_strv argloc "duplicate argument in formal arglist" + (unsafe_get_field :named_name curarg))) + (let ( (curbind + (make_instance class_formal_binding + :binder curarg + :fbind_type argtype)) ) + (put_int curbind argrk) + (mapobject_put argmap curarg curbind) + (list_append bndlist curbind) + (setq argrk (+i argrk 1)) + ) + ) + (:else + (debug_msg "unexpected argument in formal arglist" curarg (the_callcount)) + (let ( (discrarg (discrim curarg) )) + (error_strv argloc "unexepected argument in formal arglist" + (unsafe_get_field :named_name discrarg)) + ))) + (setq curpair (pair_tail curpair)))) + ;;; second loop to fill the bindings tuple + (let ( (bndtup (make_multiple discr_multiple argrk)) + (:long ix 0) + (bndpair (list_first bndlist)) + ) + (forever bndloop + (if (null bndpair) (exit bndloop)) + (assert_msg "check bndpair" (is_pair bndpair)) + (let ( (curbnd (pair_head bndpair)) ) + (assert_msg "check curbnd" (is_a curbnd class_formal_binding)) + (multiple_put_nth bndtup ix curbnd) + ) + (setq ix (+i ix 1)) + (setq bndpair (pair_tail bndpair)) + ) + bndtup + ))) + + +;;;;;;;;;;;;;;;; install an initial macro expanser +(defun install_initial_macro (symb expander) + (assert_msg "check sexpr" (is_a symb class_symbol)) + (assert_msg "check expander" (is_closure expander)) + (let ( (mbind (make_instance class_macro_binding + :binder symb + :mbind_expanser expander + )) ) + (put_env initial_environment mbind) +)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;; macro expansers +;; the defprimitive expander +(defun mexpand_defprimitive (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) +; (debug_msg "mexp.defprim sexpr" sexpr (the_callcount)) + (let ( (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (symb (pair_head curpair)) + ) + (or (is_a symb class_symbol) + (error_plain loc "missing symbol for defprimitive")) + (setq curpair (pair_tail curpair)) + ;; parse the formal arguments + (let ( (btup (lambda_arg_bindings (pair_head curpair))) ) + (setq curpair (pair_tail curpair)) +; (debug_msg "btup after lambda_arg_bindings in mexpand_defprimitive" btup (the_callcount)) + ;; parse the type keyword + (let ( (typkw (pair_head curpair)) ) + (or (is_a typkw class_keyword) + (error_plain loc "missing type keyword for defprimitive")) + (let ( (cty (unsafe_get_field :symb_data typkw)) ) + (or (and (is_a cty class_ctype) + (== (unsafe_get_field :ctype_keyword cty) typkw)) + (progn + (error_strv loc "invalid type keyword for defprimitive" + (unsafe_get_field :named_name typkw)) + )) + ;; parse the rest as to be expanded + (setq curpair (pair_tail curpair)) + (let ( (:long nbcomp (pair_listlength curpair)) + (etuple (make_multiple discr_multiple nbcomp)) + (:long ix 0) ) + (forever comploop + (or (is_pair curpair) (exit comploop)) + (let ( (curcomp (macroexpand_1 (pair_head curpair) env mexpander)) ) + ;; change string to verbatimstring to ease primitive expansion + ;; and check that each component is e string or a symbol + (cond ( (== (discrim curcomp) discr_string) + (setq curcomp (make_string discr_verbatimstring curcomp))) + ( (!= (discrim curcomp) class_symbol) + (error_strv loc "invalid expansion component in primitive" + (unsafe_get_field :named_name symb)))) + (multiple_put_nth etuple ix curcomp) + (setq curpair (pair_tail curpair)) + (setq ix (+i ix 1)))) + (let ( (sdefpri + (make_instance class_src_defprimitive + :src_loc loc + :sdef_name symb + :sformal_args btup + :sprim_type cty + :sprim_expansion etuple)) + (primit + (make_instance class_primitive + :named_name (unsafe_get_field :named_name symb) + :prim_formals btup + :prim_type cty + :prim_expansion etuple)) + (pbind + (make_instance class_primitive_binding + :binder symb + :pbind_primdef sdefpri + :pbind_primitive primit + )) + ) + (put_env env pbind) + sdefpri + ))))))) +(install_initial_macro 'defprimitive mexpand_defprimitive) + + + +;;;;;;;;;;;;;;;;;; the defun expander +(defun mexpand_defun (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (debug_msg "mexp.defun sexpr" sexpr (the_callcount)) + (let ( (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (symb (pair_head curpair)) + (newenv (fresh_env env)) + ) + (or (is_a symb class_symbol) + (error_plain loc "missing symbol for defun")) + (setq curpair (pair_tail curpair)) + ;; parse the formal arguments + (or (null (pair_head curpair)) + (is_a (pair_head curpair) class_sexpr) + (error_plain loc "missing or invalid arglist for defun")) + (let ( (btup (lambda_arg_bindings (pair_head curpair))) ) +; (debug_msg "defun btup" btup (the_callcount)) + (or (is_multiple btup) + (error_plain loc "missing formal arguments for defun")) + (multiple_iterate btup (lambda (fb) (put_env newenv fb) btup) btup) + (setq curpair (pair_tail curpair)) + (let ( (bodytup (expand_pairlist_as_tuple curpair newenv mexpander)) + (sdefun + (make_instance class_src_defun + :src_loc loc + :sdef_name symb + :sformal_args btup + :sfun_body bodytup + )) + (fbind + (make_instance class_function_binding + :binder symb + :fubind_defun sdefun + )) + ) + (put_env env fbind) + sdefun + )))) +(install_initial_macro 'defun mexpand_defun) + + + +;;;;;;;;;;;;;;;; the defclass expander + +;; internal routine with multiple results to scan the defclass +(defun scan_defclass (sexpr env mexpander) + (let ( (predef ()) + (supernam ()) + (superbind ()) + (superclass ()) + (fieldnams ()) + (docstr ()) + (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (fieldsloc ()) + (curpair (pair_tail (list_first cont))) + (symb (pair_head curpair)) + ) + (or (is_a symb class_symbol) + (error_plain loc "missing symbol for defclass")) + (debug_msg "scandefclass start cont" cont (the_callcount)) + (debug_msg "scandefclass start curpair" curpair (the_callcount)) + (setq curpair (pair_tail curpair)) + (forever scanloop + (debug_msg "scandefclass scanloop curpair" curpair (the_callcount)) + (if (not (is_pair curpair)) (exit scanloop)) + (let ( (curkw (pair_head curpair)) ) + (debug_msg "scandefclass scanloop curkw" curkw (the_callcount)) + (if (not (is_a curkw class_keyword)) + (error_plain loc "expecting keyword in defclass")) + (setq curpair (pair_tail curpair)) + (let ( (curval (pair_head curpair)) ) + (setq curpair (pair_tail curpair)) + (debug_msg "scandefclass scanloop curval" curval (the_callcount)) + (cond ( (== curkw ':super) + (if supernam (error_plain loc "duplicate super in defclass")) + (if (not (is_a curval class_symbol)) + (error_plain loc "bad super in defclass")) + (setq supernam curval) + (let ( (superb (find_env env supernam)) ) + ;;; should handle the case when the class is bound in the start environment + ;;; to a value which happens to be a class + (cond ( (is_a superb class_class_binding) + (setq superbind superb) + (setq superclass (unsafe_get_field :cbind_class superb)) + ) + ( (is_a superb class_value_binding) + (let ((superval (unsafe_get_field :vbind_value superb))) + (if (is_a superval class_class) + (progn + (setq superbind superb) + (setq superclass superval)) + (error_strv loc "super is not a class in defclass" + (unsafe_get_field :named_name supernam))))) + (:else + (error_strv loc "invalid super in defclass" + (unsafe_get_field :named_name supernam))) + ) + )) + ( (== curkw ':fields) + (if fieldnams (error_plain loc "duplicate fields in defclass")) + (if (not (is_a curval class_sexpr)) + (error_plain loc "bad fields in defclass")) + (let ( (namlist (unsafe_get_field :sexp_contents curval)) + (namloc (unsafe_get_field :loca_location curval)) + (:long nbnam (list_length namlist)) + (:long ix 0) + (nampair (list_first namlist)) + (namtupl (make_multiple discr_multiple nbnam)) ) + (setq fieldsloc namloc) + (forever namloop + (if (not (is_pair nampair)) (exit namloop)) + (let ( (curnam (pair_head nampair)) ) + (if (not (is_a curnam class_symbol)) + (error_plain namloc "non name field in defclass")) + (multiple_put_nth namtupl ix curnam) + ) + (setq nampair (pair_tail nampair)) + (setq ix (+i ix 1)) + ) + (setq fieldnams namtupl) + )) + ( (== curkw ':predef) + (if predef (error_plain loc "duplicate predef in defclass")) + (setq predef (macroexpand_1 curval env mexpander)) + (or (is_integerbox predef) + (is_a predef class_symbol) + (error_plain loc "bad predef in class")) + ) + ( (== curkw ':docstr) + (if docstr (error_plain loc "duplicate docstr in defclass")) + (setq docstr (macroexpand_1 curval env mexpander)) + (or (is_string docstr) + (error_plain loc "bad docstr in class")) + ) + (:else + (error_strv loc "invalid keyword in defclass" + (unsafe_get_field :named_name curkw)) + ) + )))) + (debug_msg "scandefclass symb" symb (the_callcount)) + (debug_msg "scandefclass loc" loc (the_callcount)) + (debug_msg "scandefclass supernam" supernam (the_callcount)) + (debug_msg "scandefclass superbind" superbind (the_callcount)) + (debug_msg "scandefclass superclass" superclass (the_callcount)) + (debug_msg "scandefclass predef" predef (the_callcount)) + (debug_msg "scandefclass fieldnams" fieldnams (the_callcount)) + (debug_msg "scandefclass fieldsloc" fieldsloc (the_callcount)) + (debug_msg "scandefclass docstr" docstr (the_callcount)) + (return symb loc supernam superbind superclass predef fieldnams fieldsloc docstr) + )) + + +(defun mexpand_defclass (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (debug_msg "mexp.defclass sexpr" sexpr (the_callcount)) + (multicall + (symb loc supernam superbind superclass predef fieldnams fieldsloc docstr) + (scan_defclass sexpr env mexpander) + (debug_msg "mexp.defclass symb" symb (the_callcount)) + (debug_msg "mexp.defclass loc" loc (the_callcount)) + (debug_msg "mexp.defclass supernam" supernam (the_callcount)) + (debug_msg "mexp.defclass superbind" superbind (the_callcount)) + (debug_msg "mexp.defclass superclass" superclass (the_callcount)) + (debug_msg "mexp.defclass predef" predef (the_callcount)) + (debug_msg "mexp.defclass fieldnams" fieldnams (the_callcount)) + (debug_msg "mexp.defclass fieldsloc" fieldsloc (the_callcount)) + (debug_msg "mexp.defclass docstr" docstr (the_callcount)) + (let ( + (ancestors (if (is_object superclass) + (let ( (superancestors (unsafe_get_field :class_ancestors superclass)) + (:long nbsuperanc (multiple_length superancestors)) + (anctuple (make_multiple discr_seqclass (+i 1 nbsuperanc))) + (:long ix 0) + ) + (assert_msg "check superclass" (is_a superclass class_class)) + (assert_msg "check superancestors" (is_multiple superancestors)) + (forever ancloop + (if (>=i ix nbsuperanc) (exit ancloop)) + (multiple_put_nth anctuple ix (multiple_nth superancestors ix)) + (setq ix (+i ix 1)) + ) + (multiple_put_nth anctuple nbsuperanc superclass) + anctuple + ) + (make_multiple discr_seqclass 0))) + (superfields (if (is_object superclass) + (unsafe_get_field :class_fields superclass))) + (:long nbsuperfields (multiple_length superfields)) + (:long nbfieldnames (multiple_length fieldnams)) + (boxnbsuperfields (make_integerbox discr_integer nbsuperfields)) + (fieldstrmap (make_mapstring discr_mapstrings (+i 3 (*i 2 (+i nbsuperfields nbfieldnames))))) + (fieldtup (make_multiple discr_seqfield (+i nbsuperfields nbfieldnames))) + (ownfieldbindings (make_multiple discr_multiple nbfieldnames)) + (newclass (make_instance class_class + :named_name (unsafe_get_field :named_name symb) + :class_ancestors ancestors + ;; other fields to be set later + )) + (clabind (make_instance class_class_binding + :binder symb + :cbind_class newclass)) + ) + (put_env env clabind) + (debug_msg "expdefclas superfields" superfields (the_callcount)) + (multiple_iterate + superfields + (lambda (sfld :long ix) + (messagenum_dbg "expdefclasupflds ix" ix) + (messageval_dbg "expdefclasupfldsval sfld" sfld) + (debug_msg "expdefclasupflds superfield" sfld (the_callcount)) + (assert_msg "check superfield" (is_a sfld class_field)) + (multiple_put_nth fieldtup ix sfld) + (mapstring_putstr fieldstrmap (unsafe_get_field :named_name sfld) sfld) + sfld + )) + (multiple_iterate + fieldnams + (lambda (fldnam :long ix) + (messagenum_dbg "expdefclafldnam ix" ix) + (debug_msg "expdefclafldnam fldnam" fldnam (the_callcount)) + (assert_msg "check fldnam" (is_a fldnam class_symbol)) + (let ( (fldstr (unsafe_get_field :named_name fldnam)) + ) + (if (mapstring_getstr fieldstrmap fldstr) + (error_strv fieldsloc "duplicate field in deflclass" fldstr)) + (let ( (:long fldoff (+i ix (get_int boxnbsuperfields))) + (newfld (make_instance class_field + :named_name fldstr + :fld_ownclass newclass + )) ) + (put_int newfld fldoff) + (messagenum_dbg "expdefclafldnam fldoff" fldoff) + (debug_msg "expdefclafldnam newfld" newfld (the_callcount)) + (multiple_put_nth fieldtup fldoff newfld) + (mapstring_putstr fieldstrmap fldstr newfld) + (let ( (newfldbind (make_instance class_field_binding + :binder fldnam + :flbind_clabind clabind + :flbind_field newfld)) ) + (put_env env newfldbind) + (multiple_put_nth ownfieldbindings ix newfldbind) + ) + newfld + )))) + (unsafe_put_fields newclass + :class_fields fieldtup) + (debug_msg "mexp.defclass newclass" newclass (the_callcount)) + (make_instance class_src_defclass + :src_loc loc + :sdef_name symb + :sobj_predef predef + :sobj_docstr docstr + :sclass_clabind clabind + :sclass_superbind superbind + :sclass_fldbinds ownfieldbindings + )))) +(install_initial_macro 'defclass mexpand_defclass) + + +;;;;;;;;;;;;;;;; the definstance expander + +;; internal to parse a field assignment in a given class +(defun parse_field_assignment (cla loc fldkw expr env mexpander) + (assert_msg "check cla" (is_a cla class_class)) + (assert_msg "check fldkw" (is_a fldkw class_keyword)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check mexpander" (is_closure mexpander)) + ;; expr is an sexpr or a symbol or a string or ... + (let ( (fldbox (make_box discr_box ())) ) + ;; if we have a class, find the field inside + (if (is_a cla class_class) + (multiple_iterate + (unsafe_get_field :class_fields cla) + (lambda (cfld :long ix) + (assert_msg "check fld" (is_a cfld class_field)) + (if (==s (unsafe_get_field :named_name cfld) + (unsafe_get_field :named_name fldkw)) + (progn + (box_put fldbox cfld) + () ; nil to exit to iteration + ) + cfld)) + ) + ;; othewise, find the field by its bound name + (let ( (fldnam (create_symbolstr (unsafe_get_field :named_name fldkw))) + (fldbind (find_env env fldnam)) + (fld (cond + ( (is_a fldbind class_field_binding) + (unsafe_get_field :flbind_field fldbind) ) + ( (is_a fldbind class_value_binding) + (let ( (vfld (unsafe_get_field :vbind_value fldbind)) ) + (if (is_a vfld class_field) + vfld)) ) + )) ) + (if (is_a fld class_field) + (box_put fldbox fld) + (error_strv loc "invalid field name in field assignment" + (unsafe_get_field :named_name fldkw))))) + ;; at last make the field assignment + (let ( (fld (box_content fldbox)) ) + (if (is_a fld class_field) + (let ( (xex (macroexpand_1 expr env mexpander)) ) + (make_instance class_src_fieldassign + :src_loc loc + :sfla_field fld + :sfla_expr xex + )))))) + +;; the definstance expanser +(defun mexpand_definstance (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (debug_msg "mexp.definstance sexpr" sexpr (the_callcount)) + (let ( (predef ()) + (objnum ()) + (fields ()) + (fieldnams ()) + (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (symb (pair_head curpair)) + (claname ()) + (cla ()) + (clabind ()) + ) + (or (is_a symb class_symbol) + (error_plain loc "missing symbol for definstance")) + (debug_msg "mexpand_definstance sexpr" sexpr (the_callcount)) + (setq curpair (pair_tail curpair)) + (let ( (nam (pair_head curpair)) ) + (or (is_a nam class_symbol) + (error_plain loc "missing class name for definstance")) + (let ( (bnd (find_env env nam)) + (fldlist (make_list discr_list)) + ) + (cond + ( (is_a bnd class_class_binding) + (setq clabind bnd) + (setq cla (unsafe_get_field :cbind_class bnd)) ) + ( (and (is_a bnd class_value_binding) + (is_a (unsafe_get_field :vbind_value bnd) class_class)) + (setq clabind bnd) + (setq cla (unsafe_get_field :vbind_value bnd))) + (:else + (error_strv loc "invalid class name for definstance" + (unsafe_get_field :named_name nam)) + (return) + )) + (setq claname nam) + (assert_msg "check cla" (is_a cla class_class)) + (setq curpair (pair_tail curpair)) + (forever insloop + (debug_msg "mexpand_definstance insloop curpair" curpair (the_callcount)) + (or (is_pair curpair) (exit insloop)) + (let ( (curfkw (pair_head curpair)) ) + (debug_msg "mexpand_definstance insloop curfkw" curfkw (the_callcount)) + (or (is_a curfkw class_keyword) + (error_plain loc "expecting keyword in definstance")) + (setq curpair (pair_tail curpair)) + (let ( (curexp (pair_head curpair)) ) + (cond ( (== curfkw ':obj_num) + (if curexp (error_plain loc "duplicate :obj_num in definstance")) + (setq objnum + (if (is_a curexp class_sexpr) + (macroexpand_1 curexp env mexpander) + curexp)) + ) + ( (== curfkw ':predef) + (if curexp (error_plain loc "duplicate :predef in definstance")) + (setq predef + (if (is_a curexp class_sexpr) + (macroexpand_1 curexp env mexpander) + curexp)) + ) + (:else + (let ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) ) + (if flda + (list_append fldlist flda) + ))))) + (setq curpair (pair_tail curpair)) + )) + (let ( ( fastup (list_to_multiple fldlist discr_multiple)) ) + (make_instance class_src_definstance + :src_loc loc + :sdef_name symb + :sobj_predef predef + :sinst_class cla + :sinst_clabind clabind + :sinst_objnum objnum + :sinst_fields fastup + )))))) +(install_initial_macro 'definstance mexpand_definstance) + + + +;;;; the make_instance expander +(defun mexpand_make_instance (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (let ( (fields ()) + (fieldnams ()) + (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (claname (pair_head curpair)) + (cla ()) + (clabind ()) + ) + (debug_msg "mexpand_make_instance start sexpr" sexpr (the_callcount)) + (or (is_a claname class_symbol) + (error_plain loc "missing class symbol for make_instance")) + (let ( (bnd (find_env env claname)) + (fldlist (make_list discr_list)) + ) + (cond + ( (is_a bnd class_class_binding) + (setq clabind bnd) + (setq cla (unsafe_get_field :cbind_class bnd)) ) + ( (and (is_a bnd class_value_binding) + (is_a (unsafe_get_field :vbind_value bnd) class_class)) + (setq clabind bnd) + (setq cla (unsafe_get_field :vbind_value bnd))) + (:else + (error_strv loc "invalid class name for make_instance" + (unsafe_get_field :named_name claname)) + (return) + )) + (assert_msg "check cla" (is_a cla class_class)) + (setq curpair (pair_tail curpair)) + (forever insloop + (debug_msg "mexpand_make_instance insloop curpair" curpair (the_callcount)) + (or (is_pair curpair) (exit insloop)) + (let ( (curfkw (pair_head curpair)) ) + (or (is_a curfkw class_keyword) + (error_plain loc "expecting keyword in make_instance")) + (setq curpair (pair_tail curpair)) + (let ( (curexp (pair_head curpair)) ) + (let ( (flda (parse_field_assignment cla loc curfkw curexp env mexpander)) ) + (if flda + (list_append fldlist flda) + )))) + (setq curpair (pair_tail curpair)) + ) + (let ( ( fastup (list_to_multiple fldlist discr_multiple)) ) + (make_instance class_src_make_instance + :src_loc loc + :smins_class cla + :smins_clabind clabind + :smins_fields fastup) + )))) +(install_initial_macro 'make_instance mexpand_make_instance) + + + +;;;; the unsafe_put_fields expander +(defun mexpand_unsafe_put_fields (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (let ( (fields ()) + (fieldnams ()) + (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (objsrc (pair_head curpair)) + (objexp + (if (is_a objsrc class_sexpr) + (macroexpand_1 objsrc env mexpander) + objsrc)) + ) + (setq curpair (pair_tail curpair)) + (let ( (fldlist (make_list discr_list)) + ) + (forever insloop + (or (is_pair curpair) (exit insloop)) + (let ( (curfkw (pair_head curpair)) ) + (or (is_a curfkw class_keyword) + (error_plain loc "expecting heyword in unsafe_put_fields")) + (setq curpair (pair_tail curpair)) + (let ( (curexp (pair_head curpair)) ) + (let ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) ) + (if flda + (list_append fldlist flda) + )))) + (setq curpair (pair_tail curpair)) + ) + (let ( ( fastup (list_to_multiple fldlist discr_multiple)) ) + (make_instance class_src_unsafe_put_fields + :src_loc loc + :suput_obj objexp + :suput_fields fastup) + )))) +(install_initial_macro 'unsafe_put_fields mexpand_unsafe_put_fields) + +;;;; the unsafe_get_field expander +(defun mexpand_unsafe_get_field (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (let ( (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (curfkw (pair_head curpair)) + ) + (or (is_a curfkw class_keyword) + (progn + (error_plain loc "field keyword expected in unsafe_get_field") + (return))) + (setq curpair (pair_tail curpair)) + (let ( (curexp (pair_head curpair)) ) + (setq curpair (pair_tail curpair)) + (if curpair (error_plain loc "unsafe_get_field with more than two sons")) + ;; it is not a field assignment but we use the parse_field_assignment + ;; routine to get the field and the expression + (let ( (flda (parse_field_assignment () loc curfkw curexp env mexpander)) ) + (if (not (is_a flda class_src_fieldassign)) + (progn + (error_plain loc "bad field and expression in unsafe_get_field") + (return))) + (let ( (fld (unsafe_get_field :sfla_field flda)) + (exp (unsafe_get_field :sfla_expr flda)) ) + (make_instance class_src_unsafe_get_field + :src_loc loc + :suget_obj exp + :suget_field fld + )))))) +(install_initial_macro 'unsafe_get_field mexpand_unsafe_get_field) + + + +;;;; the setq expander +(defun mexpand_setq (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (let ( (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (cursym (pair_head curpair)) + ) + (or (is_a cursym class_symbol) + (progn + (error_plain loc "var symbol name expected in setq") + (return))) + (setq curpair (pair_tail curpair)) + (let ( (curexp (pair_head curpair)) ) + (setq curpair (pair_tail curpair)) + (if curpair (error_plain loc "setq with more than two sons")) + (make_instance class_src_setq + :src_loc loc + :sstq_var cursym + :sstq_expr (macroexpand_1 curexp env mexpander) + ) +))) +(install_initial_macro 'setq mexpand_setq) + +;;;;; the if expanser +(defun mexpand_if (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (let ( (xcond ()) + (xthen ()) + (xelse ()) + (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (curpair (pair_tail (list_first cont))) + (curif (pair_head curpair)) ) + (or (is_pair curpair) + (error_plain loc "missing condition in IF")) + (setq curpair (pair_tail curpair)) + (or (is_pair curpair) + (error_plain loc "missing then in IF")) + (setq xcond (macroexpand_1 curif env mexpander)) + (let ( (curthen (pair_head curpair)) ) + (setq curpair (pair_tail curpair)) + (setq xthen (macroexpand_1 curthen env mexpander)) + (if (is_pair curpair) + (let ( (curelse (pair_head curpair)) ) + (setq xelse (macroexpand_1 curelse env mexpander)) + (setq curpair (pair_tail curpair)) + (if (is_pair curpair) + (error_plain loc "IF with more than three sons")))) + (make_instance class_src_if + :src_loc loc + :sif_test xcond + :sif_then xthen + :sif_else xelse) + ))) +(install_initial_macro 'if mexpand_if) + + +;;;;; the cond expanser +(defun mexpand_cond (sexpr env mexpander) + (assert_msg "check sexpr" (is_a sexpr class_sexpr)) + (assert_msg "check env" (is_a env class_environment)) + (let ( + (cont (unsafe_get_field :sexp_contents sexpr)) + (loc (unsafe_get_field :loca_location sexpr)) + (cexptuple (pairlist_to_multiple + (pair_tail (list_first cont)) + discr_multiple + (lambda (c) + (or (is_a c class_sexpr) + (error_plain loc "COND with non-sexpr")) + c + ))) + (:long nbcond (multiple_length cexptuple)) + (lastcexp (multiple_nth cexptuple (-i nbcond 1))) + (lastcontpair (if (is_a lastcexp class_sexpr) + (list_first + (unsafe_get_field :sexp_contents lastcexp)))) + (lastloc (if (is_a lastcexp class_sexpr) + (unsafe_get_field :loca_location lastcexp))) + (lasttest (pair_head lastcontpair)) + (res (cond + ( (== lasttest ':else) + (pairlist_to_progn (pair_tail lastcontpair) + lastloc + env + mexpander) ) + ( lasttest + (make_instance class_src_if + :src_loc lastloc + :sif_test (macroexpand_1 lasttest env mexpander) + :sif_then (pairlist_to_progn (pair_tail lastcontpair) + lastloc + env + mexpander)) + ))) + (:long ix (-i nbcond 2)) + ) + (forever revloop + (if (30000) of data + ndata_locbind ;local binding tuple to fill the data + )) + +;; normal "static" instance - built at modules initialization +(defclass class_nrep_datainstance + :super class_nrep_data + :fields (ninst_objnum ;object number (a number or a symbol) + ninst_predef ;predefined rank (number or symbol) + ninst_hash ;integer hash + ninst_slots ;tuple of normalized slots expressions +)) + +;; normal "static" string +(defclass class_nrep_datastring + :super class_nrep_data + :fields ( nstr_string ;the string +)) + +;; normal "static" tuple +(defclass class_nrep_datatuple + :super class_nrep_data + :fields ( ntup_comp ;the tuple of component values expressions +)) + +;; normal interned static symbol +(defclass class_nrep_datasymbol + :super class_nrep_datainstance + :fields ( ndsy_namestr +)) + +;; normal interned static keyword +(defclass class_nrep_datakeyword + :super class_nrep_datasymbol + :fields ( +)) + +;; normal static routine data +(defclass class_nrep_dataroutine + :super class_nrep_data + :fields (ndrou_proc ;associated procedure +)) + +;; normal static closure data +(defclass class_nrep_dataclosure + :super class_nrep_data + :fields (ndclo_proc ;associated procedure + ndclo_closv ;tuple of closed values +)) + +;; normal static start value +;; obtained from an initial binding +(defclass class_nrep_startval + :super class_nrep + :fields (nstart_var ;the variable + )) + +;; normal occurrence of a symbol +(defclass class_nrep_symocc + :super class_nrep + :fields (nocc_symb + nocc_ctyp ;the ctype of the symbol, eg ctype_value + nocc_bind ;the binding of the symbol +)) + +;; normal local occurrence of a symbol +(defclass class_nrep_locsymocc + :super class_nrep_symocc + :fields ( +)) + +;; normal closed occurrence of a symbol +(defclass class_nrep_closedocc + :super class_nrep_symocc + :fields (ncloc_procs ;list of enclosing procedures +)) + +;; normal constant occurrence of a symbol +(defclass class_nrep_constocc + :super class_nrep_closedocc +) + +;; normal constant (.e.g a quoted symbol, a keyword, ...) +(defclass class_nrep_constant + :super class_nrep + :fields (nconst_sval ;source value + nconst_data ;normalized data + nconst_proc ;containing proc +)) + +;; data field accessor (mostly used for defclass initialization) this +;; translates into basilys_field_object(,) of obj is not a +;; datainstance and directly to the field if it is a datainstance +(defclass class_nrep_fieldacc + :super class_nrep + :fields (naccf_obj ;data for the object to be accessed + naccf_fld ;rank or field to be accessoed +)) + +;;; data multiple accessor (mostly used for defclass initialization) +;; this translates into basilys_multiple_nth(,) if mul is not +;; a datatuple and directly to the component if it is a datatuple +(defclass class_nrep_multacc + :super class_nrep + :fields (naccm_mul ;data for the multiple to be accessed + naccm_ix ;index to be accessed (a boxed integer) +)) + + +;;; normalization context +(defclass class_normcontext + :super class_root + :fields (nctx_initproc ;initial procedure + nctx_proclist ;list of procedures + nctx_datalist ;list of data + nctx_symbmap ;stringmap of name to interned symbols + nctx_keywmap ;stringmap of name to interned keywords + nctx_symbcachemap ;objmap of cached symbol -> occurrence + nctx_predefmap ;objmap of predef -> boxedrank or symbols + nctx_valmap ;objmap of values -> data + nctx_valbindmap ;objmap of value binding -> data + nctx_curproc ;current procedure +)) + +;;; add some data to a normalization context and return it +(defun add_nctx_data (nctx ndata) + (assert_msg "check nctx" (is_a nctx class_normcontext)) +; (debug_msg "add_nctx_data initial ndata" ndata (the_callcount)) +; (shortbacktrace_dbg "add_nctx_data" 12) + (if (not (is_a ndata class_nrep_data)) + (debug_msg "add_nctx_data bad ndata" ndata (the_callcount))) + (assert_msg "check ndata" (is_a ndata class_nrep_data)) + (if (unsafe_get_field :ndata_rank ndata) + (debug_msg "add_nctx_data unfresh ndata" ndata (the_callcount))) + (assert_msg "fresh ndata" (null (unsafe_get_field :ndata_rank ndata))) + (let ( (datlis (unsafe_get_field :nctx_datalist nctx)) ) + (assert_msg "check datlis" (is_list datlis)) + (let ( (lastdat (pair_head (list_last datlis))) ) + (if (is_a lastdat class_nrep_data) + (let ( (:long lastrk (get_int (unsafe_get_field :ndata_rank lastdat))) ) + (assert_msg "check lastrk" (>i lastrk 0)) + (let ( (rkbox (make_integerbox discr_integer (+i 1 lastrk))) ) + (unsafe_put_fields ndata :ndata_rank rkbox) + )) + (let ( (rkbox1 (make_integerbox discr_integer 1)) ) + (unsafe_put_fields ndata :ndata_rank rkbox1) + ))) + (list_append datlis ndata) + ; (debug_msg "add_nctx_data final ndata" ndata (the_callcount)) + ndata + )) + + + +;;; create a normalization context +(defun create_normcontext () + (let ( (:long maxpredefix (last_globpredef_index)) + (:long ix 1) + (predefmap (make_mapobject discr_mapobjects (+i 19 (*i 2 maxpredefix)))) + (valmap (make_mapobject discr_mapobjects 350)) + ) + (forever predefloop + (if (>=i ix maxpredefix) (exit predefloop)) + (let ( (curpredef (get_globpredef ix)) ) + (if (is_object curpredef) + (mapobject_put predefmap curpredef (make_integerbox discr_integer ix))) + ) + (setq ix (+i ix 1))) + (debug_msg "creatnormctx predefmapdbg" predefmap (the_callcount)) + (make_instance class_normcontext + :nctx_initproc (make_instance class_nrep_initproc + :ninit_topl (make_list discr_list) + :nrep_loc () + ) + :nctx_proclist (make_list discr_list) + :nctx_datalist (make_list discr_list) + :nctx_symbmap (make_mapstring discr_mapstrings 50) + :nctx_keywmap (make_mapstring discr_mapstrings 40) + :nctx_predefmap predefmap + :nctx_valmap valmap + :nctx_valbindmap (make_mapobject discr_mapobjects 20) +; cold-basilys.lisp don't know how to put a null field, so we comment it out +;; :nctx_symbcachemap () + ))) + +;;; the normal_exp selector +;;;;; expected arguments: +;;; recv = the reciever, eg a sexpr +;;; env = the environment +;;; ncx = the normalization context +;;; psloc = (parent) source location +;;;;; expected results: normalized + binding list +(defselector normal_exp class_selector + :named_name (stringconst2val discr_namestring "NORMAL_EXP")) + +;; many stuff are already normalized +(defun normexp_identical (recv env ncx psloc) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + ;; is a no-op + recv) + +(install_method discr_anyrecv normal_exp normexp_identical) + +;;; catchall for src +(defun normexp_src_catchall (recv env ncx psloc) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (debug_msg "normexp_src_catchall recv" recv (the_callcount)) + (let ( (myclass (discrim recv)) + (myclassname (unsafe_get_field :named_name myclass)) ) + (error_strv (unsafe_get_field :src_loc recv) + "unimplemented normalization for " myclassname) + (assert_msg "normexp_src_catchall unimplemented normexp for src" ()) + )) +(install_method class_src normal_exp normexp_src_catchall) + +;; the selector to compute the ctype of a value in an environment +;;; argument: environment +;;;; sometimes this selector is used with a null environment, for +;;;; instance in the code generation phase +(defselector get_ctype class_selector + :named_name (stringconst2val discr_namestring "GET_CTYPE") +) +;;; most stuff are really ctype_value +(defun gectyp_anyrecv (recv env) ctype_value) +(install_method discr_anyrecv get_ctype gectyp_anyrecv) + +(defun gectyp_root (recv env) ctype_value) +(install_method class_root get_ctype gectyp_root) + +;; integers are ctype_long +(defun gectyp_integer (recv env) + (debug_msg "gectyp_integer recv" recv) + ctype_long) +(install_method discr_integer get_ctype gectyp_integer) + +;; strings are ctype_cstring +(defun gectyp_string (recv env) + ctype_cstring) +(install_method discr_string get_ctype gectyp_string) + +;;; normalize a tuple - returning a tuple & a bindinglist +(defun normalize_tuple (tup env ncx psloc) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (assert_msg "check tup" (is_multiple tup)) + (debug_msg "normalize_tuple tup" tup (the_callcount)) + (let ( (bindlist (make_list discr_list)) + (res (multiple_map + tup + (lambda (comp :long ix) + (debug_msg "normalize_tuple comp" comp (the_callcount)) + (multicall + (norcomp nbinds) + (normal_exp comp env ncx psloc) + (assert_msg "check nbinds" (is_list_or_null nbinds)) + (debug_msg "normalize_tuple norcomp" norcomp (the_callcount)) + (debug_msg "normalize_tuple nbinds" nbinds (the_callcount)) + (if (is_list nbinds) + (list_iterate + nbinds + (lambda (bnd) + (assert_msg "check bnd" (is_a bnd class_any_binding)) + (assert_msg "check bindlist" (is_list bindlist)) + (debug_msg "normalize_tuple bnd" bnd (the_callcount)) + (list_append bindlist bnd) + bnd + )) + ) + norcomp + )))) + ) + (if (not (is_pair (list_first bindlist))) + (setq bindlist ())) + (debug_msg "normalize_tuple res" res (the_callcount)) + (debug_msg "normalize_tuple bindlist" bindlist (the_callcount)) + (return res bindlist) + )) + + +;; wrap a normal let around a tuple of normalized expressions and a bindinglist +(defun wrap_normal_letseq (tupnexp bindlist loc) +; (debug_msg "wrap_normal_letseq tupnexp" tupnexp (the_callcount)) +; (debug_msg "wrap_normal_letseq bindlist" bindlist (the_callcount)) + (assert_msg "check tupnexp" (is_multiple_or_null tupnexp)) + (assert_msg "check bindlist" (is_list_or_null bindlist)) + (list_iterate + bindlist + (lambda (cbind) + (assert_msg "check cbind wrapnormletseq" (is_a cbind class_normlet_binding)) + cbind)) + (let ( (wnlet + (make_instance class_nrep_let + :nrep_loc loc + :nlet_bindings (list_to_multiple bindlist) + :nlet_body tupnexp)) + ) + ; (debug_msg "wrap_normal_letseq wnlet" wnlet (the_callcount)) + wnlet)) + + +;; wrap a normal let around a single normalized expression & a bindinglist +(defun wrap_normal_let1 (nexp bindlist loc) + ; (debug_msg "wrap_normal_let1 nexp" nexp (the_callcount)) + ; (debug_msg "wrap_normal_let1 bindlist" bindlist (the_callcount)) + (assert_msg "check bindlist" (is_list_or_null bindlist)) + (list_iterate + bindlist + (lambda (cbind) + (assert_msg "check cbind wrapnormlet1" (is_a cbind class_normlet_binding)) + cbind)) + (or nexp (shortbacktrace_dbg "wrap_normal_let1 null nexp" 15)) + (if + (and (is_list bindlist) + (is_pair (list_first bindlist))) + (let ( (wnlet + (make_instance class_nrep_let + :nrep_loc loc + :nlet_bindings (list_to_multiple bindlist) + :nlet_body (make_tuple1 discr_multiple nexp))) + ) +; (debug_msg "wrap_normal_let1 wnlet" wnlet (the_callcount)) + wnlet) + nexp +)) + + +; for symbols which are imported from a previous environment (this +; only happens when compiling stuff which is not this warm-basilys) we +; should detect them and generate some special data to fetch them, in +; the start routine, from the given environment (which is the only +; argument to the start routine). Detecting such symbols is easy : their +; binding is a class_value_binding + +;;;; normalize a symbol occurrence +(defun normexp_symbol (recv env ncx psloc) + (multicall + (bind procs) + (find_enclosing_env env recv) + (debug_msg "normexp_symbol recv" recv) + (debug_msg "normexp_symbol psloc" psloc) + (debug_msg "normexp_symbol bind" bind) + (debug_msg "normexp_symbol procs" procs) + (if (null bind) + (progn + (error_strv psloc "unbound symbol to normalize" + (unsafe_get_field :named_name recv)) + (return))) + (let ( (sycmap (unsafe_get_field :nctx_symbcachemap ncx)) + (syca (mapobject_get sycmap recv)) ) + (assert_msg "check sycmap" (is_mapobject sycmap)) + (cond + ;; check if in the cache + (syca syca) ;already cached + ;; value binding, get/put it into the map + ( (is_a bind class_value_binding) + (let ( (bvar (mapobject_get (unsafe_get_field :nctx_valbindmap ncx) bind)) ) + (debug_msg "normexp_symbol value bind" bind (the_callcount)) + (or bvar + (let ( (newbvar + (make_instance class_nrep_startval + :nrep_loc psloc + :nstart_var recv)) ) + (mapobject_put (unsafe_get_field :nctx_valbindmap ncx) bind newbvar) + newbvar) + )) + ) + ;; the procs is a non-empty list, so the symbol is closed + ( (and (is_list procs) + (is_pair (list_first procs))) + ;; check that a closed symbol is always a value + (let ( (bty + (cond ( (is_a bind class_formal_binding) + (unsafe_get_field :fbind_type bind) ) + ( (is_a bind class_let_binding) + (unsafe_get_field :letbind_type bind)) + (:else ()))) + ) + (if bty + (if (!= bty ctype_value) + (error_strv psloc + "closed variable has non value type (boxing required)" + (unsafe_get_field :named_name recv) + ))) + (setq bty ctype_value + ) + (if (is_a bind class_fixed_binding) + (let ( (fxocc + (make_instance class_nrep_constocc + :nrep_loc psloc + :nocc_symb recv + :nocc_bind bind + :nocc_ctyp ctype_value + :ncloc_procs procs)) ) + ;; cache the result + (mapobject_put sycmap recv fxocc) + (debug_msg "normexp_symbol fxocc" fxocc) + ;; put the const occurrence if needed in the const list of each proc + (list_iterate + procs + (lambda (pr) + (assert_msg "check pr" (is_a pr class_nrep_anyproc)) + (let ( (clbox (make_box discr_box fxocc)) + (cnstproc (unsafe_get_field :nrpro_const pr)) ) + (list_iterate + cnstproc + (lambda (cx) (if (== cx fxocc) (progn (box_put clbox ()) ()) cx))) + (let ( (newcl (box_content clbox)) ) + (if newcl (list_append cnstproc newcl))) + ) + pr + ) + ) + fxocc + ) + (let ( (clocc + (make_instance class_nrep_closedocc + :nrep_loc psloc + :nocc_symb recv + :nocc_ctyp ctype_value + :nocc_bind bind + :ncloc_procs procs)) + ) + ;; cache the result + (mapobject_put sycmap recv clocc) + ;; put the closed occurrence if needed in the closed list of each proc + (list_iterate + procs + (lambda (pr) + (debug_msg "normexp_symbol closed pr" pr) + (assert_msg "check pr" (is_a pr class_nrep_anyproc)) + (let ( (clbox (make_box discr_box clocc)) + (clobindl (unsafe_get_field :nrpro_closedb pr)) ) + (list_iterate + clobindl + (lambda (clbnd) (if (== clbnd bind) (progn (box_put clbox ()) ()) clbnd))) + (let ( (newcl (box_content clbox)) ) + (if newcl (list_append clobindl bind))) + ) + pr + ) + ) + clocc + ) ) ) ) + ;; formal arg is a local + ( (is_a bind class_formal_binding) + (let ( (syocc + (make_instance class_nrep_locsymocc + :nrep_loc psloc + :nocc_ctyp (unsafe_get_field :fbind_type bind) + :nocc_symb recv + :nocc_bind bind) ) ) + ;; cache the result & return it + (mapobject_put sycmap recv syocc) + syocc + )) + ;; let binding is a local + ( (is_a bind class_let_binding) + (let ( (syocc + (make_instance class_nrep_locsymocc + :nrep_loc psloc + :nocc_ctyp (unsafe_get_field :letbind_type bind) + :nocc_symb recv + :nocc_bind bind) ) ) + ;; cache the result & return it + (mapobject_put sycmap recv syocc) + syocc + )) + ;; all other cases are constants + (:else + (debug_msg "normexp_symbol const? bind" bind) + (let ( (kocc + (make_instance class_nrep_constocc + :nrep_loc psloc + :nocc_ctyp ctype_value + :nocc_symb recv + :nocc_bind bind) ) ) + ;; cache the result & return it + (mapobject_put sycmap recv kocc) + ;; put the const occurrence if needed in the const list of each proc + (list_iterate + procs + (lambda (pr) + (debug_msg "normexp_symbol const pr" pr) + (assert_msg "check pr" (is_a pr class_nrep_anyproc)) + (let ( (clbox (make_box discr_box kocc)) + (constproc (unsafe_get_field :nrpro_const pr)) ) + (list_iterate + constproc + (lambda (cl) (if (== cl kocc) (progn (box_put clbox ()) ()) cl))) + (let ( (newcl (box_content clbox)) ) + (if newcl (list_append constproc newcl))) + ) + pr + ) + ) + kocc + )))))) + +(install_method class_symbol normal_exp normexp_symbol) + +(defun gectyp_symocc (recv env) + (assert_msg "check recv" (is_a recv class_nrep_symocc)) + (unsafe_get_field :nocc_ctyp recv) +) +(install_method class_nrep_symocc get_ctype gectyp_symocc) + + +;;; normalize a primitive invocation +(defun normexp_primitive (recv env ncx psloc) + (assert_msg "check prim recv" (is_a recv class_src_primitive)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (soper (unsafe_get_field :sprim_oper recv)) + (sargs (unsafe_get_field :sprim_args recv)) + ) + (assert_msg "check soper" (is_a soper class_primitive)) + (multicall + (nargs nbind) + (normalize_tuple sargs env ncx sloc) + (let ( (sopnamstr (unsafe_get_field :named_name soper)) + (sopformals (unsafe_get_field :prim_formals soper)) + (soptype (unsafe_get_field :prim_type soper)) + (sopexp (unsafe_get_field :prim_expansion soper)) + (:long nbarg (multiple_length nargs)) + (:long nbexp (multiple_length sopexp)) + ) + (or (==i nbarg (multiple_length sopformals)) + (progn + (error_strv sloc "length mismatch between formals & actuals in primitive" + sopnamstr) + (return)) + ) + (let ( (bmap (make_mapobject discr_mapobjects (+i 2 (/iraw (*i 3 nbarg) 2)))) + (expargs (make_multiple discr_multiple nbexp)) + ) + (multiple_iterate + sopformals + (lambda (forb :long ix) + (assert_msg "check forb" (is_a forb class_formal_binding)) + (let ( (forarg (unsafe_get_field :binder forb)) + (actarg (multiple_nth nargs ix)) ) + (mapobject_put bmap forarg actarg) + bmap + ))) + (multiple_iterate + sopexp + (lambda (exc :long jx) + (let ( (exval + (if (is_a exc class_symbol) + (let ( (bval (mapobject_get bmap exc)) ) + (or bval (error_strv sloc "unbound symbol in primitive expansion" + (unsafe_get_field :named_name exc)))) + exc)) ) + (multiple_put_nth expargs jx exval)) + sopexp + )) + (let ( (csym (clone_symbol (unsafe_get_field :sdef_name soper))) + (clocc (make_instance class_nrep_locsymocc + :nrep_loc sloc + :nocc_ctyp soptype + :nocc_symb csym)) + (cbind (make_instance class_normlet_binding + :letbind_loc sloc + :binder csym + :letbind_type soptype + :letbind_expr + (make_instance class_nrep_chunk + :nrep_loc sloc + :nchunk_expansion expargs + :nchunk_primitive soper + ))) + ) + (unsafe_put_fields clocc :nocc_bind cbind) + (if (is_list nbind) + (list_append nbind cbind) + (progn + (setq nbind (make_list discr_list)) + (list_append nbind cbind) + )) + (return + clocc + nbind + ))))))) + +(install_method class_src_primitive normal_exp normexp_primitive) +(install_method class_nrep_chunk get_ctype + (lambda (recv env) + (let ( ( prim (unsafe_get_field :nchunk_primitive recv)) ) + (assert_msg "check prim" (is_a prim class_primitive)) + (unsafe_get_field :prim_type prim)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; normalize an application +(defun normexp_apply (recv env ncx psloc) + (assert_msg "check apply recv" (is_a recv class_src_apply)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (sfun (unsafe_get_field :sapp_fun recv)) + (sargs (unsafe_get_field :sapp_args recv)) + (sfusymb (if (is_a sfun class_symbol) sfun '_fun_)) + ) + (multicall + (nfun nbindfun) + (normal_exp sfun env ncx sloc) + (assert_msg "check nbindfun" (is_list_or_null nbindfun)) + (multicall + (nargs nbindargs) + (normalize_tuple sargs env ncx sloc) + (assert_msg "check nbindargs" (is_list_or_null nbindargs)) + (setq nbindargs (list_append2list nbindargs nbindfun)) + (let ( (csym (clone_symbol sfusymb)) + (clocc (make_instance class_nrep_locsymocc + :nrep_loc sloc + :nocc_ctyp ctype_value + :nocc_symb csym)) + (cbind (make_instance class_normlet_binding + :letbind_loc sloc + :binder csym + :letbind_type ctype_value + :letbind_expr + (make_instance class_nrep_apply + :nrep_loc sloc + :napp_fun nfun + :napp_args nargs + ))) ) + (unsafe_put_fields clocc :nocc_bind cbind) + (or (is_list nbindargs) + (setq nbindargs (make_list discr_list))) + (list_append nbindargs cbind) + (return clocc nbindargs) + ))))) +(install_method class_src_apply normal_exp normexp_apply) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; normalize a return +(defun normexp_return (recv env ncx psloc) + (assert_msg "check return recv" (is_a recv class_src_return)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (srets (unsafe_get_field :sreturn_body recv)) + (:long nbrets (multiple_length srets))) + ;; special case for empty return + (if (<=i nbrets 0) + (make_instance class_nrep_return + :nrep_loc sloc + :nret_main () + :nret_rest ()) + (multicall + (nrets nbindrets) + (normalize_tuple srets env ncx sloc) + (let ( (nret0 (multiple_nth nrets 0)) + (toth (make_multiple discr_multiple (-i nrets 1))) + (ctyp0 (get_ctype nret0 env)) + ) + (if (!= ctyp0 ctype_value) + (error_plain sloc "main return is not a value")) + (multiple_iterate + nrets + (lambda (ncomp :long ix) + (if (>i ix 0) + (multiple_put_nth toth (-i ix 1) ncomp)) + toth)) + (return + (make_instance class_nrep_return + :nrep_loc sloc + :nret_main nret0 + :nret_rest (if (>i nbrets 0) toth)) + nbindrets + )))))) +(install_method class_src_return normal_exp normexp_return) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;; normalize an if +(defun normexp_if (recv env ncx psloc) + (assert_msg "check if recv" (is_a recv class_src_if)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (stest (unsafe_get_field :sif_test recv)) + (ctypif ctype_void) + (sthen (unsafe_get_field :sif_then recv)) + (selse (unsafe_get_field :sif_else recv)) + ) +; (debug_msg "normexp_if recv" recv (the_callcount)) + (multicall + (ntest nbindif) ;nbindif is also the whole result binding + (normal_exp stest env ncx sloc) + (assert_msg "check nbindif test" (is_list_or_null nbindif)) +; (debug_msg "normexp_if ntest" ntest (the_callcount)) +; (debug_msg "normexp_if nbindif" nbindif (the_callcount)) + ;; in practice we don't need to make a common super- + ;; environment with nbindif since all relevant bindings there are + ;; generated, with unique cloned symbols, and these bindings + ;; are local to the test part + (multicall + (nthen nbindthen) + (normal_exp sthen env ncx sloc) + (assert_msg "check nbindthen" (is_list_or_null nbindthen)) +; (debug_msg "normexp_if nthen" nthen (the_callcount)) +; (debug_msg "normexp_if nbindthen" nbindthen (the_callcount)) + (let ( (newthenenv (fresh_env env)) ) + (list_iterate + nbindthen + (lambda (b) (put_env newthenenv b) newthenenv)) + ;; the ctyp of the whole if is initialized to the ctype of the then part + (setq ctypif (get_ctype nthen newthenenv)) +; (debug_msg "normexp_if ctypif from then" ctypif (the_callcount)) + (multicall + (nelse nbindelse) + (normal_exp selse env ncx sloc) + (assert_msg "check nbindelse" (is_list_or_null nbindelse)) +; (debug_msg "normexp_if nelse" nelse (the_callcount)) +; (debug_msg "normexp_if nbindelse" nbindelse (the_callcount)) + ;; if we have both then & else branches, + ;; ensure their compatibility of types + (and nthen nelse + (let ( (ctypthen ctypif) ; only for clarity since ctypif initialized from then part + (newelseenv (let ( (nenv (fresh_env env)) ) + (list_iterate + nbindelse + (lambda (b) (put_env nenv b) nenv)) + nenv + )) + (ctypelse (get_ctype nelse newelseenv)) + ) +; (debug_msg "normexp_if ctypelse" ctypelse (the_callcount)) + (and + (!= ctypthen ctype_void) + (!= ctypelse ctype_void) + (!= ctypthen ctypelse) + (progn + (debug_msg "normexp_if incompatyp nthen" nthen) + (debug_msg "normexp_if incompatyp nelse" nelse) + (debug_msg "normexp_if incompatyp ctypthen" ctypthen) + (debug_msg "normexp_if incompatyp ctypelse" ctypelse) + (error_plain sloc + "incompatible types in conditional branches") + ) + ) + )) + (let ( (csym (clone_symbol '_if_)) + (clocc (make_instance class_nrep_locsymocc + :nrep_loc sloc + :nocc_ctyp ctypif + :nocc_symb csym)) + (wthen (wrap_normal_let1 nthen nbindthen sloc)) + (welse (wrap_normal_let1 nelse nbindelse sloc)) + (cbind (make_instance class_normlet_binding + :letbind_loc sloc + :binder csym + :letbind_type ctypif + :letbind_expr + (make_instance class_nrep_if + :nrep_loc sloc + :nif_test ntest + :nif_then wthen + :nif_else welse + :nif_ctyp ctypif + ))) ) + (unsafe_put_fields clocc :nocc_bind cbind) + (or (is_list nbindif) + (setq nbindif (make_list discr_list))) + (list_append nbindif cbind) +; (debug_msg "normexp_if resulting clocc" clocc (the_callcount)) +; (debug_msg "normexp_if resulting nbindif" nbindif (the_callcount)) + (return clocc nbindif) + ))))))) +(install_method class_src_if normal_exp normexp_if) +(install_method class_nrep_if get_ctype + (lambda (recv env) (unsafe_get_field :nif_ctyp recv))) + +;;;;;;;;;;;;;;;; normalize an or +;; (OR a1) is a1 +;; (OR a1 a2) is (IF a1 a1 a2) -- ie let aa1 = a1 in (IF aa1 aa1 a2) +;; (OR a1 a2 a3) is let aa1 = a1 in (IF aa1 aa1 (let aa2=a2 in (IF aa2 aa2 a3))) +(defun normexp_or (recv env ncx psloc) + (assert_msg "check or recv" (is_a recv class_src_or)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (sdisj (unsafe_get_field :sor_disj recv)) + (:long nbdisj (multiple_length sdisj)) + (:long ix (-i nbdisj 1)) + (nor ()) + (ctyp ctype_void) + (nbind (make_list discr_list)) + ) + (forever backloop + (if (i lnbody 1) (make_multiple discr_multiple (-i lnbody 1)))) + (slast (if (>i lnbody 0) (multiple_nth sbody (-i lnbody 1)))) + ) + (multiple_iterate + sbody + (lambda (comp :long ix) + (if (i tuplen 0) (multiple_nth tup (-i tuplen 1)))) ) +; (debug_msg "replacelastret lastcomp" lastcomp (the_callcount)) + (cond +;;; last expression is already a return - do nothing + ( (is_a lastcomp class_nrep_return) + ) +;;; last expression is a symbol occurrence (closed or local) - return it if it is a value + ( (is_a lastcomp class_nrep_symocc) + (if (== (unsafe_get_field :nocc_ctyp lastcomp) ctype_value) + (multiple_put_nth + tup (-i tuplen 1) + (make_instance class_nrep_return + :nrep_loc sloc + :nret_main lastcomp)))) +;;; last expression is a normal data, return it + ( (is_a lastcomp class_nrep_data) + (multiple_put_nth + tup (-i tuplen 1) + (make_instance class_nrep_return + :nrep_loc sloc + :nret_main lastcomp))) +;;; no last expression - don't bother to return + ( (null lastcomp) + ) +;;; last expression is a normalized let, recurse on the body within a new env + ( (is_a lastcomp class_nrep_let) + (let ( (lbody (unsafe_get_field :nlet_body lastcomp)) + (lbinding (unsafe_get_field :nlet_bindings lastcomp)) + (lloc (unsafe_get_field :nrep_loc lastcomp)) + (newenv (fresh_env env)) + ) + (multiple_iterate + lbinding + (lambda (bnd :long ix) + (put_env newenv bnd) + bnd + )) + (if (is_multiple lbody) + (replace_last_by_return lbody newenv lloc)))) +;;; last expression is some more complex normalized stuff +;;; if it is a value wrap it into a normalized let with return + ( (is_a lastcomp class_nrep) + (let ( (lastyp (get_ctype lastcomp env)) + (loc (unsafe_get_field :nrep_loc lastcomp)) + ) + (if (== lastyp ctype_value) + (let ( (rclosym (clone_symbol '_retval_)) + (rclocc (make_instance class_nrep_locsymocc + :nrep_loc loc + :nocc_symb rclosym + :nocc_ctyp ctype_value)) + (retn (make_instance class_nrep_return + :nrep_loc loc + :nret_main rclocc + )) + (rbind (make_instance class_normlet_binding + :binder rclosym + :letbind_type ctype_value + :letbind_expr lastcomp + :letbind_loc loc + )) + (rbintup (make_tuple1 discr_multiple rbind)) + (rlet (make_instance class_nrep_let + :nrep_loc loc + :nlet_bindings rbintup + :nlet_body (make_tuple1 discr_multiple retn))) + ) + (unsafe_put_fields rclocc :nocc_bind rbind) + (multiple_put_nth + tup (-i tuplen 1) + rlet) + ))))) +; (debug_msg "replacelastret final tup" tup (the_callcount)) + tup ; returns the original tuple +;;; general case, do nothing + ) +) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; normalize a DEFUN +(defun normexp_defun (recv env ncx psloc) + (assert_msg "check defun recv" (is_a recv class_src_defun)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (debug_msg "normexp_defun recv" recv (the_callcount)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (snam (unsafe_get_field :sdef_name recv)) + (sformals (unsafe_get_field :sformal_args recv)) + (sbody (unsafe_get_field :sfun_body recv)) + (sfubind (find_env env snam)) + (newenv (fresh_env env)) + (oldproc (unsafe_get_field :nctx_curproc ncx)) + (oldsymbcache (unsafe_get_field :nctx_symbcachemap ncx)) + (closblis (make_list discr_list)) + (nproc (make_instance class_nrep_routproc +;;; dont forget to put the nil fields at end + :nrep_loc sloc + :nproc_body (the_null) ;filled later + :nrpro_name snam + :nrpro_argb sformals + :nrpro_closedb closblis + :nrpro_const (make_list discr_list) + :nrpro_thunklist (make_list discr_list) + :nrpro_datarout (the_null) ; filled below + :nrpro_dataclos (the_null) ; filled below + )) + (ndatarout (make_instance class_nrep_dataroutine + :ndata_name snam + :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine") + :ndrou_proc nproc + )) + (ndataclos (make_instance class_nrep_dataclosure + :ndata_name snam + :ndata_discrx (normal_predef discr_closure ncx sloc "discr_closure") + :ndclo_proc nproc + :ndclo_closv (the_null) ;filled below + )) + ) + (unsafe_put_fields ncx + :nctx_curproc nproc + :nctx_symbcachemap (make_mapobject discr_mapobjects 40)) + (add_nctx_data ncx ndatarout) + (add_nctx_data ncx ndataclos) + (assert_msg "check sfubind" (is_a sfubind class_function_binding)) + (unsafe_put_fields nproc :nrpro_datarout ndatarout :nrpro_dataclos ndataclos) + (multiple_iterate + sformals + (lambda (fbi :long ix) + (assert_msg "check fbi" (is_a fbi class_formal_binding)) + (put_env newenv fbi) + fbi)) + (unsafe_put_fields newenv :env_proc nproc) + ;; add nproc into ncx + (list_append (unsafe_get_field :nctx_proclist ncx) nproc) + (debug_msg "normexp_defun sbody" sbody (the_callcount)) + (multicall + (nbody nbindings) + (normalize_tuple sbody newenv ncx sloc) +; (debug_msg "normexp_defun nbody" nbody (the_callcount)) +; (debug_msg "normexp_defun nbindings" nbindings (the_callcount)) + (multiple_iterate + nbindings + (lambda (nbi :long ix) + (put_env newenv nbi) + nbi)) + (let ( (nrbody (replace_last_by_return nbody newenv sloc)) + (npbody (wrap_normal_letseq nrbody nbindings sloc)) + ) + ; (debug_msg "normexp_defun nrbody" nrbody (the_callcount)) + ; (debug_msg "normexp_defun npbody" npbody (the_callcount)) + (unsafe_put_fields nproc :nproc_body npbody) + ) + (unsafe_put_fields ncx :nctx_curproc oldproc :nctx_symbcachemap oldsymbcache) + (let ( (clovtup + (list_to_multiple + closblis + discr_multiple + (lambda (bnd) + (assert_msg "normexp_defun check bnd" (is_a bnd class_any_binding)) + (let ( (sy (unsafe_get_field :binder bnd)) + ;; since sy is a symbol, its normalized form does not add any binding + ;; we normalize it in the *old* environment, not the new one + (nsy (normal_exp sy env ncx sloc)) + ) + nsy + )))) ) + (unsafe_put_fields ndataclos :ndclo_closv clovtup) + ) + (debug_msg "normexp_defun return nproc" nproc (the_callcount)) + (return nproc ()) + ) + )) +(install_method class_src_defun normal_exp normexp_defun) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; normalize a LAMBDA +(defun normexp_lambda (recv env ncx psloc) + (assert_msg "check lambda recv" (is_a recv class_src_lambda)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (debug_msg "normexp_lambda recv" recv (the_callcount)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (sargs (unsafe_get_field :slam_argbind recv)) + (sbody (unsafe_get_field :slam_body recv)) + (savedcachemap (unsafe_get_field :nctx_symbcachemap ncx)) + (newenv (fresh_env env)) + (oldproc (unsafe_get_field :nctx_curproc ncx)) + (snam (clone_symbol 'lambda)) + (closedblist (make_list discr_list)) + (nproc (make_instance class_nrep_routproc + :nrep_loc sloc + :nproc_body (the_null) ;filled later + :nrpro_name snam + :nrpro_argb sargs + :nrpro_closedb closedblist + :nrpro_const (make_list discr_list) + :nrpro_datarout (the_null) ; filled below + :nrpro_dataclos (the_null) ; not filled + :nrpro_thunklist (make_list discr_list) + )) + (ndatarout (make_instance class_nrep_dataroutine + :ndata_name snam + :ndata_discrx (normal_predef discr_routine ncx sloc "discr_routine") + :ndrou_proc nproc + )) + ) + (add_nctx_data ncx ndatarout) + ;; update the context for the new proc & a fresh symbol cache map + (unsafe_put_fields ncx + :nctx_curproc nproc + :nctx_symbcachemap (make_mapobject discr_mapobjects 40)) + (unsafe_put_fields nproc :nrpro_datarout ndatarout) + (multiple_iterate + sargs + (lambda (fbi :long ix) + (assert_msg "check fbi" (is_a fbi class_formal_binding)) + (put_env newenv fbi) + fbi)) + (unsafe_put_fields newenv :env_proc nproc) + ;; add nproc into ncx + (list_append (unsafe_get_field :nctx_proclist ncx) nproc) + (multicall + (nbody nbindings) + (normalize_tuple sbody newenv ncx sloc) + (debug_msg "normexp_lambda closedblist became" closedblist (the_callcount)) + (multiple_iterate + nbindings + (lambda (nbi :long ix) + (put_env newenv nbi) + nbi)) + (unsafe_put_fields + nproc + :nproc_body (wrap_normal_letseq (replace_last_by_return nbody newenv sloc) nbindings sloc) + ) + ;; restore the previous symbol cache map & the old proc and return the normalized lambda + (unsafe_put_fields ncx + :nctx_symbcachemap savedcachemap + :nctx_curproc oldproc + ) + (debug_msg "normexp_lambda nproc" nproc (the_callcount)) + (let ( + ;; we make an anonymous constant for the routine unless in toplevel + (:long insideflag (is_a oldproc class_nrep_routproc)) + (krout (if insideflag + (make_instance class_nrep_constant + :nrep_loc sloc + :nconst_sval recv + :nconst_data ndatarout + :nconst_proc oldproc))) + (clovtup + (list_to_multiple closedblist + discr_multiple + (lambda (bnd) + (debug_msg "normexp_lambda bnd" bnd) + (assert_msg "normexp_lambda check bnd" (is_a bnd class_any_binding)) + (let ( (sy (unsafe_get_field :binder bnd)) + ;; since sy is a symbol, its normalized form does not add any binding + ;; we normalize it in the *old* environment, not the new one + (nsy (normal_exp sy env ncx sloc)) + ) + nsy)))) + (nlambda (make_instance class_nrep_lambda + :nrep_loc sloc + :nlambda_proc nproc + :nlambda_constrout (if insideflag krout ndatarout) + :nlambda_closedv clovtup + )) + ) + (if insideflag + (list_append (unsafe_get_field :nrpro_const oldproc) ndatarout)) + (debug_msg "normexp_lambda nlambda" nlambda (the_callcount)) + (return nlambda ()) + )))) +(install_method class_src_lambda normal_exp normexp_lambda) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + +;;; create the normal predef (or fail with a msg) +(defun normal_predef (pred ncx sloc msg) + (assert_msg "check pred" (is_object pred)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (predefmap (unsafe_get_field :nctx_predefmap ncx)) + (brk (mapobject_get predefmap pred)) ) + (if (or (is_integerbox brk) (is_a brk class_symbol)) + (make_instance class_nrep_predef + :nrep_loc sloc + :nrpredef brk) + (if (is_string msg) + (progn + (debug_msg "normalpredef predefmap" predefmap (the_callcount)) + (debug_msg "normalpredef pred" pred (the_callcount)) + (error_strv sloc "not a predef:" msg)) + )))) + + +;; retrieve or create the normalized datasym for a symbol +(defun normal_symbol_data (sym ncx sloc) + ;; sym should be strictly a symbol (not be in a subclass of class_symbol!) + (assert_msg "check symb" (== (discrim sym) class_symbol)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (valmap (unsafe_get_field :nctx_valmap ncx)) + (osydata (mapobject_get valmap sym)) ) + (or osydata + (let ( (:long syhash (obj_hash sym)) + (synamstr (unsafe_get_field :named_name sym)) + ;; make the datastring from synamstr + (synamstrdata + (make_instance class_nrep_datastring + :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") + :nstr_string synamstr + )) + (syslots (make_multiple discr_multiple + (multiple_length (unsafe_get_field :class_fields class_symbol)))) + (sydata (make_instance class_nrep_datasymbol + :ndata_name sym + :ndata_discrx (normal_predef class_symbol ncx sloc "class_symbol") + :ninst_hash (make_integerbox discr_integer syhash) + :ninst_slots syslots + :ndsy_namestr synamstr)) + ) + (multiple_put_nth syslots (obj_num named_name) synamstrdata) + (add_nctx_data ncx sydata) + (add_nctx_data ncx synamstrdata) + (mapobject_put valmap sym sydata) + (mapstring_putstr (unsafe_get_field :nctx_symbmap ncx) synamstr sydata) + sydata + )))) + + + +;; retrieve or create the normalized datakeyword for a keyword +(defun normal_keyword_data (keyw ncx sloc) + ;; keyw should be strictly a keyword (not be in a subclass of class_keyword!) + (assert_msg "check keywb" (== (discrim keyw) class_keyword)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (valmap (unsafe_get_field :nctx_valmap ncx)) + (osydata (mapobject_get valmap keyw)) ) + (or osydata + (let ( (:long syhash (obj_hash keyw)) + (synamstr (unsafe_get_field :named_name keyw)) + ;; make the datastring from synamstr + (synamstrdata + (make_instance class_nrep_datastring + :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") + :nstr_string synamstr + )) + (syslots (make_multiple discr_multiple + (multiple_length (unsafe_get_field :class_fields class_keyword)))) + (sydata (make_instance class_nrep_datakeyword + :ndata_name keyw + :ndata_discrx (normal_predef class_keyword ncx sloc "class_keyword") + :ninst_hash (make_integerbox discr_integer syhash) + :ninst_slots syslots + :ndsy_namestr synamstr)) + ) + (multiple_put_nth syslots (obj_num named_name) synamstrdata) + (add_nctx_data ncx sydata) + (add_nctx_data ncx synamstrdata) + (mapobject_put valmap keyw sydata) + (mapstring_putstr (unsafe_get_field :nctx_keywmap ncx) synamstr sydata) + sydata + )))) + + +;; create the tuples of slots of a datainstance for a particular class +(defun create_data_slots (cla) + (assert_msg "check cla" (is_a cla class_class)) + (debug_msg "create_data_slots cla" cla (the_callcount)) + (let ( (tupslo + (make_multiple discr_multiple (multiple_length (unsafe_get_field :class_fields cla)))) + ) + (debug_msg "create_data_slots tupslo" tupslo (the_callcount)) + tupslo + )) + +;; fill a slot of a datainstance +(defun fill_data_slot (di field val) + (assert_msg "check di" (is_a di class_nrep_datainstance)) + (assert_msg "check field" (is_a field class_field)) + (let ( (:long fix (obj_num field)) + (slots (unsafe_get_field :ninst_slots di)) ) + (multiple_put_nth slots fix val) +)) + +;;;;;; normalize a QUOTE-d symbol + +(defun normexp_quote (recv env ncx psloc) + (assert_msg "check quote recv" (is_a recv class_src_quote)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (debug_msg "normexp_quote ncx" ncx (the_callcount)) + (debug_msg "normexp_quote recv" recv (the_callcount)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (quotedsy (unsafe_get_field :squoted recv)) ) + (assert_msg "check quotedsy" (== (discrim quotedsy) class_symbol)) + (let ( (sdata (normal_symbol_data quotedsy ncx psloc)) + (curproc (unsafe_get_field :nctx_curproc ncx)) + (constlist (unsafe_get_field :nrpro_const curproc)) + (nconst (make_instance class_nrep_constant + :nrep_loc sloc + :nconst_sval quotedsy + :nconst_data sdata + :nconst_proc curproc + )) + ) + (assert_msg "check curproc" (is_a curproc class_nrep_routproc)) + (list_append constlist sdata) + (debug_msg "normexp_quote nconst" nconst (the_callcount)) + nconst + ))) +(install_method class_src_quote normal_exp normexp_quote) + +;;;;;; normalize a keyword +(defun normexp_keyword (recv env ncx psloc) + (assert_msg "check keyword recv" (is_a recv class_keyword)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (debug_msg "normexp_keyword ncx" ncx (the_callcount)) + (debug_msg "normexp_keyword recv" recv (the_callcount)) + (let ( (kdata (normal_keyword_data recv ncx psloc)) + (curproc (unsafe_get_field :nctx_curproc ncx)) + (constlist (unsafe_get_field :nrpro_const curproc)) + (nconst (make_instance class_nrep_constant + :nrep_loc psloc + :nconst_sval recv + :nconst_data kdata + :nconst_proc curproc)) + ) + (assert_msg "check curproc" (is_a curproc class_nrep_anyproc)) + (list_append constlist kdata) + (debug_msg "normexp_keyword nconst" nconst (the_callcount)) + nconst +)) +(install_method class_keyword normal_exp normexp_keyword) + +;;;;;; normalize a DEFPRIMITIVE +(defun normexp_defprimitive (recv env ncx psloc) + (assert_msg "check defprimitive recv" (is_a recv class_src_defprimitive)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (sname (unsafe_get_field :sdef_name recv)) + (sargs (unsafe_get_field :sformal_args recv)) + (stype (unsafe_get_field :sprim_type recv)) + (sexp (unsafe_get_field :sprim_expansion recv)) + (sprimbind (find_env env sname)) + ;; we compile to the making of an instance of class_primitive + (nslotuple (create_data_slots class_primitive)) + (nexptuple (make_multiple discr_multiple + (multiple_length sexp))) + (nargtuple (make_multiple discr_multiple + (multiple_length sargs))) + (nexpdata (make_instance class_nrep_datatuple + :nrep_loc sloc + :ndata_name sname + :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") + :ntup_comp nexptuple)) + (nargdata (make_instance class_nrep_datatuple + :nrep_loc sloc + :ndata_name sname + :ndata_discrx (normal_predef discr_multiple ncx sloc "discr_multiple") + :ntup_comp nargtuple)) + (nprimdata (make_instance class_nrep_datainstance + :nrep_loc sloc + :ndata_name sname + :ndata_discrx (normal_predef class_primitive ncx sloc "class_primitive") + :ninst_hash (make_integerbox discr_integer (nonzero_hash)) + :ninst_slots nslotuple)) + (nsymdata (normal_symbol_data sname ncx sloc)) + ;; map of formal symbol -> data of formal_binding + (formsymbmap (make_mapobject discr_mapobjects (*i (multiple_length sargs) 2))) + ) + (add_nctx_data ncx nprimdata) + (add_nctx_data ncx nexpdata) + (add_nctx_data ncx nargdata) + ;; dont add nsymdata, it has already been added + ;; fill the formal arguments of the data + (multiple_iterate + sargs + (lambda (fargb :long ix) + (assert_msg "check fargb" (is_a fargb class_formal_binding)) + (let ( (ftyp (unsafe_get_field :fbind_type fargb)) + (fsymb (unsafe_get_field :binder fargb)) + (fdataslot (create_data_slots class_formal_binding)) + (fargdata + (make_instance + class_nrep_datainstance + :nrep_loc sloc + :ndata_discrx (normal_predef class_formal_binding ncx sloc "class_formal_binding") + :ninst_hash (make_integerbox discr_integer (nonzero_hash)) + :ninst_slots fdataslot + :ninst_objnum (make_integerbox discr_integer ix) + )) + (fsymbdata (normal_symbol_data fsymb ncx sloc)) + (ftypdata (normal_predef ftyp ncx sloc "primitive arg type")) + ) + (assert_msg "check ftyp" (is_a ftyp class_ctype)) + (add_nctx_data ncx fargdata) + (fill_data_slot fargdata binder fsymbdata) + (fill_data_slot fargdata fbind_type ftypdata) + (multiple_put_nth nargtuple ix fargdata) + (mapobject_put formsymbmap fsymb fargdata) + fargb + ))) + ;; fill the expansion of the data + (multiple_iterate + sexp + (lambda (expcomp :long ix) + (debug_msg "normexp_defprimitive expcomp" expcomp) + (let ( (discrcomp (discrim expcomp)) + (compdata + (cond ( (== discrcomp discr_verbatimstring) + (add_nctx_data ncx + (make_instance + class_nrep_datastring + :ndata_discrx (normal_predef discr_verbatimstring ncx sloc "discr_verbatimstring") + :nstr_string expcomp + ))) + ( (== discrcomp class_symbol) + (normal_symbol_data expcomp ncx sloc) + ) + ( :else + (error_plain sloc "unexpected component in primitive expansion")))) + ) + (multiple_put_nth nexptuple ix compdata) + compdata + ))) +;;; fill the primitive data + (fill_data_slot nprimdata named_name + (add_nctx_data + ncx + (make_instance + class_nrep_datastring + :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") + :nstr_string (unsafe_get_field :named_name sname)))) + (fill_data_slot nprimdata prim_formals nargdata) + (fill_data_slot nprimdata prim_expansion nexpdata) +;;; put the data into the primitive binding + (if (is_a sprimbind class_primitive_binding) + (unsafe_put_fields sprimbind :pbind_primdata nprimdata)) + (return ()) ;normalized defprimitive is empty + )) +(install_method class_src_defprimitive normal_exp normexp_defprimitive) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; normalize a DEFCLASS +(defun normexp_defclass (recv env ncx psloc) + (assert_msg "check defclass recv" (is_a recv class_src_defclass)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (sname (unsafe_get_field :sdef_name recv)) + (spredef (unsafe_get_field :sobj_predef recv)) + (sclabind (unsafe_get_field :sclass_clabind recv)) + (superbind (unsafe_get_field :sclass_superbind recv)) + (sfldbinds (unsafe_get_field :sclass_fldbinds recv)) + ) + (assert_msg "check sclabind" (is_a sclabind class_class_binding)) + (let ( (claobj (unsafe_get_field :cbind_class sclabind)) + (namsymdata (normal_symbol_data sname ncx sloc)) + (namstrdata + (make_instance class_nrep_datastring + :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") + :nstr_string (unsafe_get_field :named_name sname) + )) + (claslots (make_multiple discr_multiple (obj_len claobj))) + (cladata + (make_instance class_nrep_datainstance + :nrep_loc sloc + :ndata_name sname + :ndata_discrx (normal_predef class_class ncx sloc "class_class") + :ninst_hash (make_integerbox discr_integer (obj_hash claobj)) + :ninst_predef spredef + :ninst_slots claslots + :ninst_objnum 'OBMAG_OBJECT + )) + (ancseq (unsafe_get_field :class_ancestors claobj)) + (:long nbanc (multiple_length ancseq)) + (anctup (make_multiple discr_multiple nbanc)) + (ancdata (make_instance + class_nrep_datatuple + :nrep_loc sloc + :ndata_name sname + :ndata_discrx (normal_predef discr_seqclass ncx sloc "discr_seqclass") + :ntup_comp anctup + )) + (fldseq (unsafe_get_field :class_fields claobj)) + (:long nbfld (multiple_length fldseq)) ;total number of fields + (:long nbownfld (multiple_length sfldbinds)) ;number of own fields + (:long nbsupfld (-i nbfld nbownfld)) ;number of super(ie inherited) fields + (:long ix 0) ;temporary index + (fldtup (make_multiple discr_multiple nbfld)) + (flddata (make_instance + class_nrep_datatuple + :nrep_loc sloc + :ndata_name sname + :ndata_discrx (normal_predef discr_seqfield ncx sloc "discr_seqfield") + :ntup_comp fldtup + )) + ;; the data representing the superclass + (superdata (if (is_a superbind class_any_binding) + (normal_exp (unsafe_get_field :binder superbind) env ncx sloc))) + ) + (assert_msg "check claobj" (is_a claobj class_class)) + (add_nctx_data ncx cladata) + (add_nctx_data ncx namstrdata) + (add_nctx_data ncx ancdata) + (add_nctx_data ncx flddata) + (fill_data_slot cladata named_name namstrdata) + (fill_data_slot cladata class_ancestors ancdata) + (fill_data_slot cladata class_fields flddata) + (assert_msg "check sclabind" (is_a sclabind class_class_binding)) + (unsafe_put_fields sclabind :cbind_cladata cladata) + ;; for each field which is not own, make a data to copy it from the superclass + (setq ix 0) + (forever loopsuperfield + (if (>=i ix nbsupfld) (exit loopsuperfield)) + (let ( (supfldata + (make_instance class_nrep_multacc + :nrep_loc sloc + :naccm_mul + (make_instance class_nrep_fieldacc + :nrep_loc sloc + :naccf_obj superdata + :naccf_fld class_fields + ) + :naccm_ix (make_integerbox discr_integer ix) + )) + ) + (multiple_put_nth fldtup ix supfldata) + ) + (setq ix (+i ix 1)) + ) + (setq ix 0) + ;; for each own field, make an instance of it + (forever loopownfield + (if (>=i ix nbownfld) (exit loopownfield)) + (let ( (ownfldbind (multiple_nth sfldbinds ix)) ) + (assert_msg "check ownfldbind" (is_a ownfldbind class_field_binding)) + (let ( (ownfldsym (unsafe_get_field :binder ownfldbind)) + (ownfld (unsafe_get_field :flbind_field ownfldbind)) + ) + (assert_msg "check ownfldsym" (is_a ownfldsym class_symbol)) + (assert_msg "check ownfld" (is_a ownfld class_field)) + (let ( (ownfldsymdata (normal_symbol_data ownfldsym ncx sloc)) + (ownfldslots (make_multiple discr_multiple (obj_len ownfld))) + (ownflstrdata + (make_instance class_nrep_datastring + :ndata_discrx (normal_predef discr_string ncx sloc "discr_string") + :nstr_string (unsafe_get_field :named_name ownfld) + )) + (ownfldata (make_instance class_nrep_datainstance + :nrep_loc sloc + :ndata_name ownfldsym + :ndata_discrx (normal_predef class_field ncx sloc "class_field") + :ninst_hash (make_integerbox discr_integer (obj_hash ownfld)) + :ninst_objnum (make_integerbox discr_integer (obj_num ownfld)) + :ninst_slots ownfldslots)) + ) + (add_nctx_data ncx ownfldata) + (add_nctx_data ncx ownflstrdata) + (fill_data_slot ownfldata named_name ownflstrdata) + (fill_data_slot ownfldata fld_ownclass cladata) + (multiple_put_nth fldtup (+i ix nbsupfld) ownfldata) + ;; fill the field binding with its compiled data + (unsafe_put_fields ownfldbind :flbind_fdata ownfldata) + ))) + (setq ix (+i ix 1)) + ) + ;; set the disc_super field to the superclass + (if superdata (fill_data_slot cladata disc_super superdata)) + ;; compute the class_ancestors into anctup + (setq ix 0) + ;; loop on the ancestors of the superclass + (forever loopancestorsuper + (if (>=i ix (-i nbanc 1)) (exit loopancestorsuper)) + (let ( (supancdata + (make_instance class_nrep_multacc + :nrep_loc sloc + :naccm_mul + (make_instance class_nrep_fieldacc + :nrep_loc sloc + :naccf_obj superdata + :naccf_fld class_ancestors) + :naccm_ix (make_integerbox discr_integer ix))) ) + (multiple_put_nth anctup ix supancdata) + ) + (setq ix (+i ix 1)) + ) + ;; add the superdata as the last component of anctup + (if superdata (multiple_put_nth anctup (-i nbanc 1) superdata)) + ;; the normalized form of the defclass is the classdata + cladata + ))) +(install_method class_src_defclass normal_exp normexp_defclass) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;; normalize a DEFINSTANCE +(defun normexp_definstance (recv env ncx psloc) + (assert_msg "check definstance recv" (is_a recv class_src_definstance)) + (assert_msg "check env" (is_a env class_environment)) + (assert_msg "check nctxt" (is_a ncx class_normcontext)) + (debug_msg "normexp definstance recv" recv (the_callcount)) + (let ( (sloc (unsafe_get_field :src_loc recv)) + (sname (unsafe_get_field :sdef_name recv)) + (spredef (unsafe_get_field :sobj_predef recv)) + (sdocstr (unsafe_get_field :sobj_docstr recv)) + (sinstclass (unsafe_get_field :sinst_class recv)) + (sinstclabnd (unsafe_get_field :sinst_clabind recv)) + (sinstclasym (if (is_a sinstclabnd class_any_binding) (unsafe_get_field :binder sinstclabnd))) + (sinstobjnum (unsafe_get_field :sinst_objnum recv)) + (sinstfields (unsafe_get_field :sinst_fields recv)) + (nbindlist (make_list discr_list)) + (nbindbox (make_box discr_box nbindlist)) + (namdata (normal_symbol_data sname ncx sloc)) + ;; data representing the class + (icladata (if (is_a sinstclasym class_symbol) + (normal_exp sinstclasym env ncx sloc))) + ) + (if (not (is_a icladata class_nrep)) + (progn + (error_strv sloc "invalid class in definstance" (unsafe_get_field :named_name sname)) + (return))) + (if spredef + (or (is_integerbox spredef) (is_a spredef class_symbol) + (progn (error_strv sloc "bad predef in definstance" (unsafe_get_field :named_name sname)) + (return)))) + (assert_msg "check sinstclass" (is_a sinstclass class_class)) + (assert_msg "check sinstclasym" (is_a sinstclasym class_symbol)) + (let ( + (slotup (make_multiple discr_multiple + (multiple_length (unsafe_get_field :class_fields sinstclass)))) + (insdata (make_instance class_nrep_datainstance + :nrep_loc sloc + :ndata_name sname + :ndata_discrx icladata + :ninst_hash (make_integerbox discr_integer (nonzero_hash)) + :ninst_predef spredef + :ninst_slots slotup + )) + ) + (add_nctx_data ncx insdata) + ;; scan the fields initialization + (multiple_iterate + sinstfields + (lambda (flda :long ix) + (assert_msg "check flda" (is_a flda class_src_fieldassign)) + (let ( (curfld (unsafe_get_field :sfla_field flda)) + (curexp (unsafe_get_field :sfla_expr flda)) + (:long curoff (obj_num curfld)) + ) + (assert_msg "check curfld" (is_a curfld class_field)) + (assert_msg "good curfld" + (== (multiple_nth (unsafe_get_field :class_fields sinstclass) curoff) + curfld)) + (multicall + (ncur nbindcur) + (normal_exp curexp env ncx sloc) + (multiple_put_nth slotup curoff ncur) + (if (is_list nbindcur) + (let ( (nbindlist (box_content nbindbox))) + (setq nbindlist (list_append2list nbindlist nbindcur)) + (box_put nbindbox nbindlist))) + flda ;result of lambda + )))) +;;; put the binding into the data + (let ( (nbindlist (box_content nbindbox)) + (nbindtup (list_to_multiple nbindlist discr_multiple)) + ) + (if (>i (multiple_length nbindtup) 0) + (unsafe_put_fields insdata :ndata_locbind nbindtup)) + ;; return the data + insdata + )))) +(install_method class_src_definstance normal_exp normexp_definstance) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;; selector to compile a normalized stuff into an object +;;; reciever: the normalized stuff +;;; arguments: +;;;; * GCX the code generation context +;;; result = the obj instruction or value + +(defselector compile_obj class_selector + :named_name (stringconst2val discr_namestring "COMPILE_OBJ")) +;; a catchall method for nrep-s (normal representations) each should +;; be separately compiled with its own method so this should never be +;; called +(defun compilobj_catchall_nrep (recv gcx) + (debug_msg "class_rep compile_obj gcx" gcx (the_callcount)) + (debug_msg "class_rep compile_obj recv" recv (the_callcount)) + (assert_msg "@@compile_obj should be implemented in nrep-s subclasses" ()) + ) +(install_method class_nrep compile_obj compilobj_catchall_nrep) + +;;; selector to put a destination into an objcode +;;; reciever: the objcode +;;; argument: the destination value +;;; result: the (modified) recieving objcode or its replacement +(defselector put_objdest class_selector + :named_name (stringconst2val discr_namestring "PUT_OBJDEST")) + +;;; classes for code generation + + +;;; code generation context +(defclass class_genercontext + :super class_root + :fields ( gncx_objrout ;the containing object routine + gncx_locmap ;objmap from normal bindings to locals + gncx_freeptrlist ;list of freed local pointers + gncx_freelonglist ;list of freed local longs + gncx_freeothermaps ;map keyed by ctypes of list of freed local others + gncx_retloc ;return location + gncx_compicache ;cache map of procedure to compiled routines +)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; common superclass for objcode +(defclass class_objcode + :super class_root + :fields ( +)) +(defun putobjdest_catchall_objcode (recv desto) + (debug_msg "putobjdest_catchall_objcode recv@@ " recv (the_callcount)) + (debug_msg "putobjdest_catchall_objcode desto@@ " desto (the_callcount)) + (shortbacktrace_dbg "putobjdest_catchall_objcode" 15) + (assert_msg "@@ unexpected catchall putobjdest" ())) +(install_method class_objcode put_objdest putobjdest_catchall_objcode) + +;;;; value like objects +(defclass class_objvalue + :super class_objcode + :fields ( obv_type ;the ctype +)) + +(defun getctype_objvalue (recv env) + (assert_msg "check recv objvalue" (is_a recv class_objvalue)) + obv_type) +(install_method class_objvalue get_ctype getctype_objvalue) + +;; object local variable +(defclass class_objlocv + :super class_objvalue + :fields (obl_off ;offset in frame + obl_proc ;containing procedure + obl_cname ;symbolic cname string +)) + + +;; closed occurrence +(defclass class_objcloccv + :super class_objvalue + :fields (obc_off ;offset in closure + obc_proc ;containing procedure + obc_name ;symbolic name +)) + +;; constant [closed] occurrence +(defclass class_objconstv + :super class_objcloccv + :fields ( +)) + +;; predefined object +(defclass class_objpredef + :super class_objvalue + :fields (obpredef +)) + +;; initial element +(defclass class_objinitelem + :super class_objvalue + :fields (oie_cname ;symbolic cname string - fieldname in cdat + oie_data ;normal data + oie_discr ;compiled discriminant + oie_locvar ;initial routine's local variable + ;; the size, if any is the obj_num +)) + +;;;; selector to generate the declaration of an initial +;;; reciever some objinielem +;;; argument strbuf +(defselector output_c_declinit class_selector + :named_name (stringconst2val discr_namestring "OUTPUT_C_DECLINIT") +) +(defun outdeclinit_root (recv sbuf) + (debug_msg "outdeclinit_root recv" recv (the_callcount)) + (assert_msg "outdeclinit_root unimplemented catchall" ()) +) +(install_method class_root output_c_declinit outdeclinit_root) + + +;;; selector to generate the c code for an object +;;; reciever: the object to output +;;; arguments: +;;;; * DECLBUF the stringbuffer for the declarations +;;;; * IMPLBUF the stringbuffer for implementations +;;;; * DEPTH an unboxed integer for indentation... +;;; result is not used + +(defselector output_c_code class_selector + :named_name (stringconst2val discr_namestring "OUTPUT_C_CODE")) + + +(defun outpucod_objinielem (obielem declbuf implbuf :long depth) + (assert_msg "check obelem" (is_a obielem class_objinitelem)) + ;;(debug_msg "outpucod_objinielem obielem" obielem (the_callcount)) + (let ( (olocvar (unsafe_get_field :oie_locvar obielem)) + (cnam (unsafe_get_field :oie_cname obielem)) ) + (assert_msg "check cnam" (is_string cnam)) + (assert_msg "check olocvar" olocvar) + (add2sbuf_strconst implbuf "/*obielem ") + (add2sbuf_string implbuf cnam) + (add2sbuf_strconst implbuf "*/ ") + (output_c_code olocvar declbuf implbuf depth) + ) +) +(install_method class_objinitelem output_c_code outpucod_objinielem) + +;;;; selector to generate the initial fill of some objinit +;;; reciever some objinitelem +;;; argument a stringbuffer +(defselector output_c_initfill class_selector + :named_name (stringconst2val discr_namestring "OUTPUT_C_INITFILL")) +(defun outcinitfill_root (recv declbuf implbuf :long depth) + (debug_msg "outcinitfill_root recv" recv (the_callcount)) + (assert_msg "outcinitfill_root unimplemented catchall" ()) +) +(install_method class_root output_c_initfill outcinitfill_root) + + +(defun outpucod_predef (obpred declbuf implbuf :long depth) + (assert_msg "check obpredef" (is_a obpred class_objpredef)) + (let ( (obpr (unsafe_get_field :obpredef obpred)) ) + (cond + ( (is_integerbox obpr) + (add2sbuf_strconst implbuf "basilys_globpredef(") + (add2sbuf_longdec implbuf (get_int obpr)) + (add2sbuf_strconst implbuf ")") + ) + ( (is_a obpr class_symbol) + (add2sbuf_strconst implbuf "BASILYSG(") + (add2sbuf_string implbuf (unsafe_get_field :named_name obpr)) + (add2sbuf_strconst implbuf ")") + ) + ( :else + (debug_msg "bad obpredef" obpredef (the_callcount)) + (assert_msg "invalid obpredef" ()) + ) + ))) +(install_method class_objpredef output_c_code outpucod_predef) + +;;; initial object - see BASILYS_OBJECT_STRUCT in basilys.h +(defclass class_objinitobject + :super class_objinitelem + :fields ( + oio_predef ;the predef name or number to contain this object +)) +(defun outdeclinit_objinitobject (recv sbuf) + (add2sbuf_strconst sbuf " struct BASILYS_OBJECT_STRUCT(") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ") ") + (add2sbuf_string sbuf (unsafe_get_field :named_name recv)) + (add2sbuf_strconst sbuf ";") ; +) +(install_method class_objinitobject output_c_declinit outdeclinit_objinitobject) + +(defun outcinitfill_objinitobject (recv sbuf) + (assert_msg "outcinitfill_objinitobject check recv" (is_a recv class_objinitobject)) + (debug_msg "outcinitfill_objinitobject recv" recv (the_callcount)) + (let ( (odata (unsafe_get_field :oie_data recv)) + (odiscr (unsafe_get_field :oie_discr recv)) + (oname (unsafe_get_field :oie_cname recv)) + (olocvar (unsafe_get_field :oie_locvar recv)) + (oiopredef (unsafe_get_field :oio_predef recv)) + ) + (assert_msg "check odata" (is_a odata class_nrep_datainstance)) + (let ( (odloc (unsafe_get_field :nrep_loc odata)) + (odhash (unsafe_get_field :ninst_hash odata)) + (odslots (unsafe_get_field :ninst_slots odata)) + ) + (output_location odloc sbuf 1) + (add2sbuf_strconst sbuf "/*iniobj ") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf "*/") + (add2sbuf_indentnl sbuf 1) + (if olocvar + (progn + (add2sbuf_strconst sbuf "/*inioblocvar*/ ") + (output_c_code olocvar (the_null) sbuf 1) + (add2sbuf_strconst sbuf " = (void*)&cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + )) + (if oiopredef + (cond + ( (is_a oiopredef class_symbol) + (add2sbuf_strconst sbuf "/*iniobpredefsym*/ BASILYSG(") + (add2sbuf_string sbuf (unsafe_get_field :named_name oiopredef)) + (add2sbuf_strconst sbuf ") = (void*)&cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + ) + ( (is_integerbox oiopredef) + (add2sbuf_strconst sbuf "/*iniobpredefnum*/ basilys_globarr[") + (add2sbuf_longdec sbuf (get_int oiopredef)) + (add2sbuf_strconst sbuf "] = (void*)&cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + ) + ( :else + (debug_msg "outcinitfill_objinitobject unexpected oiopredef" oiopredef (the_callcount)) + (assert_msg "outcinitfill_objinitobject unexpected oiopredef" ()) + ))) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ".obj_class = ") + (output_c_code odiscr (the_null) sbuf 1) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ".obj_hash = ") + (add2sbuf_longdec sbuf (get_int odhash)) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ".obj_len = ") + (add2sbuf_longdec sbuf (multiple_length odslots)) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ".obj_vartab = ") + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf oname) + (add2sbuf_strconst sbuf ".obj__tabfields;") + (add2sbuf_indentnl sbuf 1) + ;; output the fill + ) + ) + ) +(install_method class_objinitobject output_c_initfill outcinitfill_objinitobject) + +;;; initial multiple - see BASILYS_MULTIPLE_STRUCT in basilys.h +(defclass class_objinitmultiple + :super class_objinitelem + :fields ( +)) +(defun outdeclinit_objinitmultiple (recv sbuf) + (add2sbuf_strconst sbuf " struct BASILYS_MULTIPLE_STRUCT(") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ") ") + (add2sbuf_string sbuf (unsafe_get_field :named_name recv)) + (add2sbuf_strconst sbuf ";") +) +(install_method class_objinitmultiple output_c_declinit outdeclinit_objinitmultiple) + + +(defun outcinitfill_objinitmultiple (recv sbuf) + (assert_msg "outcinitfill_objinitmultiple check recv" (is_a recv class_objinitmultiple)) + (debug_msg "outcinitfill_objinitmultiple recv" recv (the_callcount)) + (let ( (cnam (unsafe_get_field :oie_cname recv)) + (olocvar (unsafe_get_field :oie_locvar recv)) + ) + (add2sbuf_strconst sbuf "/*inimult ") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf "*/") + (add2sbuf_indentnl sbuf 1) + (if olocvar + (progn + (add2sbuf_strconst sbuf "/*inimulocvar*/ ") + (output_c_code olocvar (the_null) sbuf 1) + (add2sbuf_strconst sbuf " = (void*)&cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + )) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".discr = ") + (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".nbval = ") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ";") + )) +(install_method class_objinitmultiple output_c_initfill outcinitfill_objinitmultiple) + +;;; initial closure - see BASILYS_CLOSURE_STRUCT in basilys.h +(defclass class_objinitclosure + :super class_objinitelem + :fields ( +)) +(defun outdeclinit_objinitclosure (recv sbuf) + (add2sbuf_strconst sbuf " struct BASILYS_CLOSURE_STRUCT(") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ") ") + (add2sbuf_string sbuf (unsafe_get_field :oie_cname recv)) + (add2sbuf_strconst sbuf ";") +) +(install_method class_objinitclosure output_c_declinit outdeclinit_objinitclosure) + +(defun outcinitfill_objinitclosure (recv sbuf) + (assert_msg "outcinitfill_objinitclosure check recv" (is_a recv class_objinitclosure)) + (debug_msg "outcinitfill_objinitclosure recv" recv (the_callcount)) + (let ( (cnam (unsafe_get_field :oie_cname recv)) + (olocvar (unsafe_get_field :oie_locvar recv)) + ) + (add2sbuf_strconst sbuf "/*iniclos ") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf "*/") + (add2sbuf_indentnl sbuf 1) + (if olocvar + (progn + (add2sbuf_strconst sbuf "/*inicloslocvar*/ ") + (output_c_code olocvar (the_null) sbuf 1) + (add2sbuf_strconst sbuf " = (void*)&cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + )) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".discr = ") + (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".nbval = ") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + )) +(install_method class_objinitclosure output_c_initfill outcinitfill_objinitclosure) + + +;;; initial routine - see BASILYS_ROUTINE_STRUCT in basilys.h +(defclass class_objinitroutine + :super class_objinitelem + :fields ( + oir_procroutine ;the procroutine associated +)) +(defun outdeclinit_objinitroutine (recv sbuf) + (add2sbuf_strconst sbuf " struct BASILYS_ROUTINE_STRUCT(") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ") ") + (add2sbuf_string sbuf (unsafe_get_field :oie_cname recv)) + (add2sbuf_strconst sbuf ";") +) +(install_method class_objinitroutine output_c_declinit outdeclinit_objinitroutine) + + +(defun outcinitfill_objinitroutine (recv sbuf) + (assert_msg "outcinitfill_objinitroutine check recv" (is_a recv class_objinitroutine)) + (debug_msg "outcinitfill_objinitroutine recv" recv (the_callcount)) + (let ( (cnam (unsafe_get_field :oie_cname recv)) + (ipro (unsafe_get_field :oir_procroutine recv)) + (olocvar (unsafe_get_field :oie_locvar recv)) + (ndatr (unsafe_get_field :oie_data recv)) + ) + (add2sbuf_strconst sbuf "/*inirout ") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf "*/") + (add2sbuf_indentnl sbuf 1) + (if olocvar + (progn + (add2sbuf_strconst sbuf "/*iniroutlocvar*/ ") + (output_c_code olocvar (the_null) sbuf 1) + (add2sbuf_strconst sbuf " = (void*)&cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + )) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".discr = ") + (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " strncpy(cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".routdescr, \"") + (if (is_a ndatr class_nrep_dataroutine) + (let ( (dnam (unsafe_get_field :ndata_name ndatr)) + (dpro (unsafe_get_field :ndrou_proc ndatr)) + ) + (debug_msg "outcinitfill_objinitroutine ndatr" ndatr (the_callcount)) + (debug_msg "outcinitfill_objinitroutine dpro" dpro (the_callcount)) + (if (is_a dnam class_named) + (add2sbuf_cencstring sbuf (unsafe_get_field :named_name dnam))) + (if (is_a dpro class_nrep_routproc) + (let ( (dloc (unsafe_get_field :nrep_loc dpro)) + (locfil (mixint_val dloc)) ) + (add2sbuf_strconst sbuf " @") + (add2sbuf_cencstring sbuf locfil) + (add2sbuf_strconst sbuf ":") + (add2sbuf_longdec sbuf (get_int dloc)) + ) + ) + ) + (add2sbuf_cencstring sbuf cnam)) + (add2sbuf_strconst sbuf "\", BASILYS_ROUTDESCR_LEN - 1);") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".nbval = ") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (if ipro + (progn + (debug_msg "outcinitfill_objinitroutine ipro" ipro (the_callcount)) + (assert_msg "check ipro" (is_a ipro class_named)) + (add2sbuf_strconst sbuf "*(basilysroutfun_t **) (cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".routaddr) = ") + (add2sbuf_string sbuf (unsafe_get_field :named_name ipro)) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + ) + (progn + (debug_msg "outcinitfill_objinitroutine (noipro) recv" recv (the_callcount)) + (add2sbuf_strconst sbuf "#warning no procedure in objinitroutine ") + (add2sbuf_string sbuf cnam) + (add2sbuf_indentnl sbuf 1) + ) + ) + )) +(install_method class_objinitroutine output_c_initfill outcinitfill_objinitroutine) + +;;; initial string - see BASILYS_STRING_STRUCT in basilys.h +(defclass class_objinitstring + :super class_objinitelem + :fields ( +)) +(defun outdeclinit_objinitstring (recv sbuf) + (add2sbuf_strconst sbuf " struct BASILYS_STRING_STRUCT(") + (add2sbuf_longdec sbuf (get_int recv)) + (add2sbuf_strconst sbuf ") ") + (add2sbuf_string sbuf (unsafe_get_field :named_name recv)) + (add2sbuf_strconst sbuf ";") +) +(install_method class_objinitstring output_c_declinit outdeclinit_objinitstring) + + +(defun outcinitfill_objinitstring (recv sbuf) + (assert_msg "outcinitfill_objinitstring check recv" (is_a recv class_objinitstring)) + (debug_msg "outcinitfill_objinitstring recv" recv (the_callcount)) + (let ( (cnam (unsafe_get_field :oie_cname recv)) + (olocvar (unsafe_get_field :oie_locvar recv)) + ) + (add2sbuf_strconst sbuf "/*inistring ") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf "*/") + (add2sbuf_indentnl sbuf 1) + (if olocvar + (progn + (add2sbuf_strconst sbuf "/*inistrlocvar*/ ") + (output_c_code olocvar (the_null) sbuf 1) + (add2sbuf_strconst sbuf " = (void*)&cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + )) + (add2sbuf_strconst sbuf " cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".discr = ") + (output_c_code (unsafe_get_field :oie_discr recv) (the_null) sbuf 1) + (add2sbuf_strconst sbuf ";") + (add2sbuf_indentnl sbuf 1) + (add2sbuf_strconst sbuf " strcpy(cdat->") + (add2sbuf_string sbuf cnam) + (add2sbuf_strconst sbuf ".val, \"") + (add2sbuf_cencstring sbuf (unsafe_get_field :oie_data recv)) + (add2sbuf_strconst sbuf "\");") + (add2sbuf_indentnl sbuf 1) + )) +(install_method class_objinitstring output_c_initfill outcinitfill_objinitstring) + +;; expanded value +(defclass class_objexpv + :super class_objvalue + :fields (obx_cont +)) + +;;;; instructions +(defclass class_objinstr + :super class_objcode + :fields (obi_loc ;src location +)) + +;;; compute instruction +(defclass class_objcompute + :super class_objinstr + :fields (obcpt_dest ;destination list + obcpt_expr ;expression list +)) + +;; get argument instruction +(defclass class_objgetarg + :super class_objinstr + :fields (obarg_obloc ;objlocation + obarg_bind ;formal binding +)) + + +;; put extra result instruction +(defclass class_objputxtraresult + :super class_objinstr + :fields (obxres_rank ;boxed rank + obxres_obloc ;objlocation +)) + +;; final return +(defclass class_objfinalreturn + :super class_objinstr + :fields ( ;no argument +)) + +;; clear instruction +(defclass class_objclear + :super class_objinstr + :fields (oclr_vloc ;varlocation to clear +)) + +;; block instruction +(defclass class_objblock + :super class_objinstr + :fields ( oblo_bodyl ;body list + oblo_epil ;epilogue list +)) + +;; looping block +(defclass class_objloop + :super class_objblock ;the body is looped, not the epilogue + :fields (obloop_label ;cloned symbol + obloop_resv ;the result of the loop +)) + +;; exit a loop (with a single body) +(defclass class_objexit + :super class_objinstr + :fields (obexit_label ;cloned symbol for goto destination + obexit_prolog ;single instruction prolog +)) + +;; conditional instruction +(defclass class_objcond + :super class_objinstr + :fields (obcond_test + obcond_then + obcond_else +)) + +;;; apply instruction +(defclass class_objapply + :super class_objinstr + :fields (obapp_dest ;destination list + obapp_clos ;closure to be applied + obapp_args ;argument tuple +)) + +;; raw object allocation instruction +(defclass class_objrawallocobj + :super class_objinstr + :fields (obrallobj_class ;the class data + obrallobj_len ;the boxed integer length + obrallobj_dest ;the list of destinations +)) + + +;; new closure allocation +(defclass class_objnewclosure + :super class_objinstr + :fields (obnclo_discr ;the discriminant + obnclo_rout ;the routine + obnclo_len ;the boxed integer length + obnclo_dest ;the list of destinations +)) + +;; put a component inside a tuple +(defclass class_objputuple + :super class_objinstr + :fields (oputu_tupled ;the tuple data + oputu_offset ;numerical offset + oputu_value ;the new value +)) + +;; put a slot inside an object +(defclass class_objputslot + :super class_objinstr + :fields ( oslot_odata ;the object data to put + oslot_offset ;numerical offset + oslot_value ;the new value +)) + +;; put the routine inside a closure +(defclass class_objputclosurout + :super class_objinstr + :fields (opclor_clos ;the closure data + opclor_rout ;the routine data +)) + +;; put a closed value inside a closure +(defclass class_objputclosedv + :super class_objinstr + :fields (opclov_clos ;the closure data or local + opclov_off ;the boxed offset + opclov_cval ;the closed value +)) + +;; put a constant value inside a routine +(defclass class_objputroutconst + :super class_objinstr + :fields (oprconst_rout ;the routine data + oprconst_off ;the boxed offset + oprconst_cval ;the constant value +)) + +;; touch a value, with a tiny comment +(defclass class_objtouch + :super class_objinstr + :fields (otouch_val + otouch_comment +)) + +;; set a predef +(defclass class_objsetpredef + :super class_objinstr + :fields ( ospr_object ;the object + ospr_predef ;its predef rank +)) + + +;;; routines +(defclass class_routineobj + :super class_named + :fields (obrout_proc ;the associated procedure + obrout_body ;the body (a list) + obrout_nbval ;the boxed number of value pointers + obrout_nblong ;the boxed number of longs + obrout_others ;the list of other (nonvalue, nonlongs) locals + obrout_retval ;the main return value +)) + +;; procedure routine +(defclass class_procroutineobj + :super class_routineobj + :fields (oprout_getargs ;the get arguments tuple of instructions +)) + +;; initial routine +(defclass class_initialroutineobj + :super class_routineobj + :fields ( + oirout_data ;the tuple of initial data + oirout_fill ;the fill of the data (a list of instr) +)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; notes about code generation +;;; +;;; in addition of the code structure generated by cold-basilys we +;;; need to be able to import values (hence bindings) from a start +;;; environment which is the only argument given to the generated +;;; start routine of the module + +(defun outpucod_anydiscr (any declbuf implbuf :long depth) + (debug_msg "outpucod_anydiscr any" any (the_callcount)) + (assert_msg "@@ outpucod_anydiscr not able to output" ()) +) +(install_method discr_anyrecv output_c_code outpucod_anydiscr) + +(defun outpucod_null (nul declbuf implbuf :long depth) + (add2sbuf_strconst implbuf "NULL") +) +(install_method discr_nullrecv output_c_code outpucod_null) + +;;; catchall for outputting any stuff +(defun outpucod_root (anyr declbuf implbuf :long depth) + (debug_msg "outpucod_root anyr" anyr (the_callcount)) + (assert_msg "@@ outpucod_root not able to output" ()) +) +(install_method class_root output_c_code outpucod_root) + + +;;; output the code for declaring and initializing the current frame +(defun output_curframe_init (rou implbuf) + (debug_msg "output_curframe_init rou" rou (the_callcount)) + (let ( + (obody (unsafe_get_field :obrout_body rou)) + (onbval (unsafe_get_field :obrout_nbval rou)) + (onblong (unsafe_get_field :obrout_nblong rou)) + (:long nbval (get_int onbval)) + (:long nblong (get_int onblong)) + (others (unsafe_get_field :obrout_others rou)) + ) + ;; output call counter for debugging + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#if ENABLE_CHECKING") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " static long call_counter__;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " long thiscallcounter__ ATTRIBUTE_UNUSED = ++ call_counter__;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#define callcount thiscallcounter__") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#else") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#define callcount 0L") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#endif") + ;; output the current frame + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " struct { unsigned nbvar;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " struct basilysclosure_st *clos;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " struct excepth_basilys_st *exh;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " struct callframe_basilys_st *prev;") + (add2sbuf_indentnl implbuf 0) + (if (>i nbval 0) + (progn + (add2sbuf_strconst implbuf " void* varptr[") + (add2sbuf_longdec implbuf nbval) + (add2sbuf_strconst implbuf "];") + (add2sbuf_indentnl implbuf 0)) + (progn + (add2sbuf_strconst implbuf "/*no varptr*/") + (add2sbuf_indentnl implbuf 0))) + (if (>i nblong 0) + (progn + (add2sbuf_strconst implbuf " long varnum[") + (add2sbuf_longdec implbuf nblong) + (add2sbuf_strconst implbuf "];") + (add2sbuf_indentnl implbuf 0)) + (progn + (add2sbuf_strconst implbuf "/*no varnum*/") + (add2sbuf_indentnl implbuf 0)) + ) + (if others + (progn + (debug_msg "output_curframe_init others" others (the_callcount)) + (assert_msg "output_curframe_init @@ handling of others not implemented" ()) + )) + (add2sbuf_strconst implbuf " long _spare_; } curfram__ = {") + (add2sbuf_longdec implbuf nbval) + (add2sbuf_strconst implbuf ", ") + (add2sbuf_strconst implbuf " (struct basilysclosure_st *)0, ") + (add2sbuf_strconst implbuf " (struct excepth_basilys_st *)0, ") + (add2sbuf_strconst implbuf " (struct callframe_basilys_st *) 0, ") + (if (>i nbval 0) + (let ( (:long ix 0) ) + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " /*ptrvars*/{") + (forever ptrloop + (if (>=i ix nbval) (exit ptrloop)) + (if (>i ix 0) (add2sbuf_strconst implbuf ",")) + (if (==i 0 (%iraw ix 8)) + (add2sbuf_indentnl implbuf 2)) + (add2sbuf_strconst implbuf " (void*)0") + (setq ix (+i ix 1)) + ) + (add2sbuf_strconst implbuf "},") ; + )) + (if (>i nblong 0) + (let ( (:long ix 0) ) + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " /*numvars*/{") + (forever ptrloop + (if (>=i ix nblong) (exit ptrloop)) + (if (>i ix 0) (add2sbuf_strconst implbuf ",")) + (if (==i 0 (%iraw ix 8)) + (add2sbuf_indentnl implbuf 2)) + (add2sbuf_strconst implbuf " 0L") + (setq ix (+i ix 1)) + ) + (add2sbuf_strconst implbuf "},") ; + )) + (assert_msg "output_curframe_init @@ initialization of others not implemented" (null others)) + (add2sbuf_strconst implbuf " 0L };") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " curfram__.prev = (void*) basilys_topframe;") + (add2sbuf_indentnl implbuf 0) + (if (is_a rou class_initialroutineobj) + (progn + (add2sbuf_strconst implbuf " curfram__.clos = NULL /*since initroutine*/;") + (add2sbuf_indentnl implbuf 0) + ) + (progn + (add2sbuf_strconst implbuf " curfram__.clos = closp_;") + (add2sbuf_indentnl implbuf 0) + )) + (add2sbuf_strconst implbuf " basilys_topframe = (void*) &curfram__;") + (add2sbuf_indentnl implbuf 0) + )) + +;;; output code for a procroutine +(defun outpucod_procroutine (prou declbuf implbuf :long depth) + (assert_msg "check prou" (is_a prou class_procroutineobj)) + (let ( (onam (unsafe_get_field :named_name prou)) + (obody (unsafe_get_field :obrout_body prou)) + (onbval (unsafe_get_field :obrout_nbval prou)) + (onblong (unsafe_get_field :obrout_nblong prou)) + (:long nbval (get_int onbval)) + (:long nblong (get_int onblong)) + (others (unsafe_get_field :obrout_others prou)) + (ogargs (unsafe_get_field :oprout_getargs prou)) + (oretval (unsafe_get_field :obrout_retval prou)) + ) + (debug_msg "outpucod_procroutine prou" prou (the_callcount)) + ;; output the declaration + (add2sbuf_indentnl declbuf 0) + (add2sbuf_strconst declbuf "static basilys_ptr_t ") + (add2sbuf_string declbuf onam) + (add2sbuf_strconst declbuf "(basilysclosure_ptr_t closp_,") + (add2sbuf_strconst declbuf " basilys_ptr_t firstargp_,") + (add2sbuf_strconst declbuf " const char xargdescr_[],") + (add2sbuf_strconst declbuf " union basilysparam_un *xargtab_,") + (add2sbuf_strconst declbuf " const char xresdescr_[],") + (add2sbuf_strconst declbuf " union basilysparam_un *xrestab_);") + (add2sbuf_indentnl declbuf 0) + ;; output the implementation + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "static basilys_ptr_t ") + (add2sbuf_string implbuf onam) + (add2sbuf_strconst implbuf "(basilysclosure_ptr_t closp_,") + (add2sbuf_strconst implbuf " basilys_ptr_t firstargp_,") + (add2sbuf_strconst implbuf " const char xargdescr_[],") + (add2sbuf_strconst implbuf " union basilysparam_un *xargtab_,") + (add2sbuf_strconst implbuf " const char xresdescr_[],") + (add2sbuf_strconst implbuf " union basilysparam_un *xrestab_) {") + (output_curframe_init prou implbuf) + ;; output the argument getting + (add2sbuf_strconst implbuf "/*getargs*/") + (add2sbuf_indentnl implbuf 0) + (debug_msg "outpucod_procroutine output ogargs" ogargs (the_callcount)) + (assert_msg "check ogargs" (is_multiple ogargs)) + (multiple_iterate + ogargs + (lambda (curget :long curank) + (add2sbuf_indentnl implbuf 1) + (add2sbuf_strconst implbuf "/*getarg#") + (add2sbuf_longdec implbuf curank) + (add2sbuf_strconst implbuf "*/") + (add2sbuf_indentnl implbuf 1) + (output_c_code curget declbuf implbuf 1) + ogargs + )) + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " goto lab_endgetargs;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "lab_endgetargs:;") + (add2sbuf_indentnl implbuf 0) + ;; output the body + (debug_msg "outpucod_procroutine output obody" obody (the_callcount)) + (assert_msg "check obody" (is_list obody)) + (add2sbuf_strconst implbuf "/*body*/") + (add2sbuf_indentnl implbuf 0) + (list_iterate + obody + (lambda (curbody) + (output_c_code curbody declbuf implbuf 0) + (add2sbuf_indentnl implbuf 0) + obody)) + ;; end of implementation + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " goto labend_rout;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "labend_rout: basilys_topframe = (void *) curfram__.prev;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " return ") + (if oretval + (output_c_code oretval declbuf implbuf 1) + (add2sbuf_strconst implbuf "/*noretval*/ NULL")) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#undef callcount") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "} /*end ") + (add2sbuf_string implbuf onam) + (add2sbuf_strconst implbuf "*/") + (add2sbuf_indentnl implbuf 0) + )) +(install_method class_procroutineobj output_c_code outpucod_procroutine) + + +;; output code for the initial routine +(defun outpucod_initialroutine (pini declbuf implbuf :long depth) + (assert_msg "check pini" (is_a pini class_initialroutineobj)) + (add2sbuf_indentnl declbuf 0) + (add2sbuf_strconst declbuf "void* start_module_basilys(void*);") + (add2sbuf_indentnl declbuf 0) + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "void* start_module_basilys(void* modatap_) {") + (add2sbuf_indentnl implbuf 0) + (debug_msg "outpucod_initialroutine pini" pini (the_callcount)) + ;; generate the initial data structure + (let ( + (idatup (unsafe_get_field :oirout_data pini)) + (irfill (unsafe_get_field :oirout_fill pini)) + (oretval (unsafe_get_field :obrout_retval pini)) + ) + (debug_msg "outpucod_initialroutine start idatup" idatup (the_callcount)) + (debug_msg "outpucod_initialroutine start irfill" irfill (the_callcount)) + (add2sbuf_indentnl implbuf 1) + (add2sbuf_strconst implbuf "struct cdata_st {") + (multiple_iterate + idatup + (lambda (curdat :long curk) + (debug_msg "outpucod_initialroutine curdat" curdat (the_callcount)) + (add2sbuf_indentnl implbuf 1) + (output_c_declinit curdat implbuf) + idatup + ) + ) + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " long spare_;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "} *cdat = NULL;") + (add2sbuf_indentnl implbuf 1) + ;; generate the initial frame + (output_curframe_init pini implbuf) + ;; generate the allocation of cdat + (add2sbuf_strconst implbuf " cdat = basilysgc_allocate(sizeof(*cdat),0);") + (add2sbuf_indentnl implbuf 1) + (add2sbuf_strconst implbuf " basilys_prohibit_garbcoll = TRUE;") + (add2sbuf_indentnl implbuf 1) +;;; generate the initial filling of cdat + (multiple_iterate + idatup + (lambda (curfil :long curk) + (debug_msg "outpucod_initialroutine curfil" curfil (the_callcount)) + (add2sbuf_indentnl implbuf 1) + (output_c_initfill curfil implbuf) + idatup + ) + ) +;;; initialize the variables + (debug_msg "outpucod_initialroutine irfill" irfill) + (list_iterate + irfill + (lambda (curifil) + (debug_msg "outpucod_initialroutine curifil" curifil (the_callcount)) + irfill)) +;;; clear the cdat for safety and renable GC + (add2sbuf_strconst implbuf " cdat = NULL;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " basilys_prohibit_garbcoll = FALSE;") + (add2sbuf_indentnl implbuf 0) +;;; output the body + (add2sbuf_strconst implbuf "/*initroutbody*/") + (add2sbuf_indentnl implbuf 0) + (let ( (ibody (unsafe_get_field :obrout_body pini)) + ) + (debug_msg "outpucod_initialroutine ibody" ibody) + (list_iterate + ibody + (lambda (curbody) + (debug_msg "outpucod_initialroutine curbody" curbody (the_callcount)) + (output_c_code curbody declbuf implbuf 1) + ibody) + )) + ;; end of implementation + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " goto labend_rout;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "labend_rout: basilys_topframe = (void *) curfram__.prev;") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf " return ") + (if oretval + (output_c_code oretval declbuf implbuf 1) + (add2sbuf_strconst implbuf "/*noretval*/ NULL")) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "#undef callcount") + (add2sbuf_indentnl implbuf 0) + (add2sbuf_strconst implbuf "} /* end start_module_basilys */") + (add2sbuf_indentnl implbuf 0)) + + ) +(install_method class_initialroutineobj output_c_code outpucod_initialroutine) + + + +;; output code for argument getter +(defun outpucod_getarg (garg declbuf implbuf :long depth) + (assert_msg "check garg" (is_a garg class_objgetarg)) + (debug_msg "outpucod_getarg garg" garg (the_callcount)) + (let ( (oloc (unsafe_get_field :obarg_obloc garg)) + (obind (unsafe_get_field :obarg_bind garg)) + (:long rkbind (get_int obind)) + (ctybind (unsafe_get_field :fbind_type obind)) + ) + (assert_msg "check obind" (is_a obind class_formal_binding)) + (assert_msg "check oloc" (is_a oloc class_objlocv)) + (assert_msg "check ctybind" (is_a ctybind class_ctype)) + (if (==i rkbind 0) + (progn + (assert_msg "check ctybind first" (== ctybind ctype_value)) + (output_c_code oloc declbuf implbuf depth) + (add2sbuf_strconst implbuf " = firstargp_;") + (add2sbuf_indentnl implbuf depth) + ) + (let ( + ;; use the ctype_parchar ctype_argfield + (parc (unsafe_get_field :ctype_parchar ctybind)) + (argf (unsafe_get_field :ctype_argfield ctybind)) + ) + (if (not (is_string parc)) + (error_strv () "impossible argument ctype" + (unsafe_get_field :named_name ctybind))) + (add2sbuf_strconst implbuf "if (xargdescr_[") + (add2sbuf_longdec implbuf (-i rkbind 1)) + (add2sbuf_strconst implbuf "] != ") + (add2sbuf_string implbuf parc) + (add2sbuf_strconst implbuf ") goto lab_endgetargs;") + (add2sbuf_indentnl implbuf depth) + (if (== ctybind ctype_value) + (progn + (output_c_code oloc declbuf implbuf depth) + (add2sbuf_strconst implbuf " = *(xargtab_[") + (add2sbuf_longdec implbuf (-i rkbind 1)) + (add2sbuf_strconst implbuf "].bp_aptr);") + ) + (progn + (output_c_code oloc declbuf implbuf depth) + (add2sbuf_strconst implbuf " = xargtab_[") + (add2sbuf_longdec implbuf (-i rkbind 1)) + (add2sbuf_strconst implbuf "].") + (add2sbuf_string implbuf argf) + (add2sbuf_strconst implbuf ";") + ) + ) + (add2sbuf_indentnl implbuf depth) + )) + (debug_msg "outpucod_getarg done garg" garg (the_callcount)) + )) +(install_method class_objgetarg output_c_code outpucod_getarg) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; output code for objlocv +(defun outpucod_objlocv (locv declbuf implbuf :long depth) + (assert_msg "check locv" (is_a locv class_objlocv)) + ;; (debug_msg "outpucod_objlocv locv" locv (the_callcount)) + (let ( + (ltyp (unsafe_get_field :obv_type locv)) + (loff (unsafe_get_field :obl_off locv)) + (lcnam (unsafe_get_field :obl_cname locv)) + ) + (cond + ( (== ltyp ctype_value) + (add2sbuf_strconst implbuf "/*lptr:") + (add2sbuf_string implbuf lcnam) + (add2sbuf_strconst implbuf "*/curfram__.varptr[") + (add2sbuf_longdec implbuf (get_int loff)) + (add2sbuf_strconst implbuf "]") ) + ( (== ltyp ctype_long) + (add2sbuf_strconst implbuf "/*llng:") + (add2sbuf_string implbuf lcnam) + (add2sbuf_strconst implbuf "*/curfram__.varnum[") + (add2sbuf_longdec implbuf (get_int loff)) + (add2sbuf_strconst implbuf "]") ) + (:else + (add2sbuf_strconst implbuf "/*lother*/curfram__.") + (add2sbuf_string implbuf lcnam))) + ) + ) +(install_method class_objlocv output_c_code outpucod_objlocv) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; output code for object closed occurrence +(defun outpucod_objcloccv (occv declbuf implbuf :long depth) + (assert_msg "check occv" (is_a occv class_objcloccv)) + (let ( (ooff (unsafe_get_field :obc_off occv)) + (onam (unsafe_get_field :obc_name occv)) ) + (assert_msg "check valueness of closed occurrence" + (== (unsafe_get_field :obv_type occv) ctype_value)) + (add2sbuf_strconst implbuf "(/*~") + (add2sbuf_string implbuf onam) + (add2sbuf_strconst implbuf "*/ curfram__.clos->tabval[") + (add2sbuf_longdec implbuf (get_int ooff)) + (add2sbuf_strconst implbuf "])") +)) +(install_method class_objcloccv output_c_code outpucod_objcloccv) + + +;;;;;;;;;;;;;;;; +;; output code for object const [closed] occurrence +(defun outpucod_objconstv (ocnstv declbuf implbuf :long depth) + (assert_msg "check ocnstv" (is_a ocnstv class_objconstv)) + (debug_msg "outpucod_objconstv ocnstv" ocnstv (the_callcount)) + (let ( (ooff (unsafe_get_field :obc_off ocnstv)) + (onam (unsafe_get_field :obc_name ocnstv)) ) + (assert_msg "check valueness of const occurrence" + (== (unsafe_get_field :obv_type ocnstv) ctype_value)) + (add2sbuf_strconst implbuf "(/*!") + (add2sbuf_string implbuf onam) + (add2sbuf_strconst implbuf "*/ curfram__.clos->rout->tabval[") + (add2sbuf_longdec implbuf (get_int ooff)) + (add2sbuf_strconst implbuf "])") +)) +(install_method class_objconstv output_c_code outpucod_objconstv) + +;;; common code to output a location +(defun output_location (loc implbuf :long depth) + (if (is_mixint loc) + (progn + (add2sbuf_indentnl implbuf depth) + (add2sbuf_strconst implbuf "#line ") + (add2sbuf_longdec implbuf (get_int loc)) + (add2sbuf_strconst implbuf " \"") + (add2sbuf_string implbuf (mixint_val loc)) + (add2sbuf_strconst implbuf "\"") + (add2sbuf_indentnl implbuf depth) + ))) + + +;; output code for objblock +(defun outpucod_objblock (oblo declbuf implbuf :long depth) + (assert_msg "check oblo" (is_a oblo class_objblock)) + (debug_msg "outpucod_objblock oblo" oblo (the_callcount)) + (output_location (unsafe_get_field :obi_loc oblo) implbuf depth) + (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo)) + (epil (unsafe_get_field :oblo_epil oblo)) + (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) + ) + (add2sbuf_strconst implbuf "/*block*/{") + (if (is_list bodyl) + (progn + (add2sbuf_indentnl implbuf (+i depth 1)) + (list_iterate + bodyl + (lambda (curbody) + (let ( (:long depthp1 (get_int boxdepthp1)) ) + (if (is_a curbody class_objinstr) + (progn + (output_c_code curbody declbuf implbuf depthp1) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depthp1))) + bodyl))))) + (if (is_list epil) + (progn + (add2sbuf_strconst implbuf "/*epilog*/") + (add2sbuf_indentnl implbuf (+i depth 1)) + (list_iterate + epil + (lambda (curepil) + (let ( (:long depthp1 (get_int boxdepthp1)) ) + (if (is_a curepil class_objinstr) + (progn + (output_c_code curepil declbuf implbuf depthp1) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depthp1)))) + epil)))) + (add2sbuf_strconst implbuf "}") + (add2sbuf_indentnl implbuf depth) + ) + (debug_msg "outpucod_objblock done oblo" oblo (the_callcount)) + ) +(install_method class_objblock output_c_code outpucod_objblock) + + +;;; add a cname for a cloned identifier into a buffer +(defun add2sbuf_clonsym (sbuf csy) + (assert_msg "check sbuf" (is_strbuf sbuf)) + (assert_msg "check csy" (is_a csy class_clonedsymbol)) + (let ( (cnam (unsafe_get_field :named_name csy)) + (:long rk (get_int (unsafe_get_field :csym_urank csy))) ) + (add2sbuf_cident sbuf cnam) + (add2sbuf_strconst sbuf "_") + (add2sbuf_longdec sbuf rk) +)) + +;;; output code for objloop +(defun outpucod_objloop (oblo declbuf implbuf :long depth) + (assert_msg "check oblo" (is_a oblo class_objloop)) + (debug_msg "outpucod_objloop oblo" oblo (the_callcount)) + (output_location (unsafe_get_field :obi_loc oblo) implbuf depth) + (let ( (bodyl (unsafe_get_field :oblo_bodyl oblo)) + (epil (unsafe_get_field :oblo_epil oblo)) + (lab (unsafe_get_field :obloop_label oblo)) + (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) + ) + (assert_msg "check lab" (is_a lab class_clonedsymbol)) + (add2sbuf_strconst implbuf "/*loop*/{ labloop_") + (add2sbuf_clonsym implbuf lab) + (add2sbuf_strconst implbuf ":;") + (if (is_list bodyl) + (progn + (add2sbuf_indentnl implbuf (+i depth 1)) + (list_iterate + bodyl + (lambda (curbody) + (let ( (:long depthp1 (get_int boxdepthp1)) ) + (output_c_code curbody declbuf implbuf depthp1) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depthp1)) + bodyl)))) + (add2sbuf_indentnl implbuf (+i depth 1)) + (add2sbuf_strconst implbuf " goto labloop_") + (add2sbuf_clonsym implbuf lab) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf (+i depth 1)) + (add2sbuf_strconst implbuf " labexit_") + (add2sbuf_clonsym implbuf lab) + (add2sbuf_strconst implbuf ":;") + (if (is_list epil) + (progn + (add2sbuf_strconst implbuf "/*loopepilog*/") + (add2sbuf_indentnl implbuf (+i depth 1)) + (list_iterate + epil + (lambda (curepil) + (let ( (:long depthp1 (get_int boxdepthp1)) ) + (output_c_code curepil declbuf implbuf depthp1) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depthp1)) + epil)))) + (add2sbuf_strconst implbuf "}") + (add2sbuf_indentnl implbuf depth) + ) + (debug_msg "outpucod_objloop done oblo" oblo (the_callcount)) + ) +(install_method class_objloop output_c_code outpucod_objloop) + + +;;; output code for objexit +(defun outpucod_objexit (obxi declbuf implbuf :long depth) + (assert_msg "check obxi" (is_a obxi class_objexit)) + (debug_msg "outpucod_objexit obxi" obxi (the_callcount)) + (output_location (unsafe_get_field :obi_loc obxi) implbuf depth) + (let ( (olab (unsafe_get_field :obexit_label obxi)) + (oprolog (unsafe_get_field :obexit_prolog obxi)) ) + (assert_msg "check olab" (is_a olab class_clonedsymbol)) + (add2sbuf_strconst implbuf "/*exit*/{") + (add2sbuf_indentnl implbuf depth) + (if (is_a oprolog class_objinstr) + (progn + (output_c_code oprolog declbuf implbuf (+i depth 1)) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf (+i depth 1)) + )) + (add2sbuf_strconst implbuf " goto labexit_") + (add2sbuf_clonsym implbuf olab) + (add2sbuf_strconst implbuf ";}") + (add2sbuf_indentnl implbuf depth) +)) +(install_method class_objexit output_c_code outpucod_objexit) + +;;; output code for objcompute +(defun outpucod_objcompute (obcomp declbuf implbuf :long depth) + (assert_msg "check obcomp" (is_a obcomp class_objcompute)) + (let ( (cdest (unsafe_get_field :obcpt_dest obcomp)) ; destination list + (cloc (unsafe_get_field :obi_loc obcomp)) + (cexp (unsafe_get_field :obcpt_expr obcomp)) + (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) + ) + (output_location cloc implbuf depth) + (list_iterate + cdest + (lambda (destcur) + (output_c_code destcur declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf " = ") + cdest)) + (if (is_list cexp) + (list_iterate + cexp + (lambda (expcur) + (output_c_code expcur declbuf implbuf (get_int boxdepthp1)) + cexp)) + (output_c_code cexp declbuf implbuf (+i depth 1)) + ))) +(install_method class_objcompute output_c_code outpucod_objcompute) + + +;; output a conditional +(defun outpucod_objcond (ocond declbuf implbuf :long depth) + (assert_msg "check ocond" (is_a ocond class_objcond)) + (debug_msg "outpucod_objcond ocond" ocond (the_callcount)) + (let ( (cloc (unsafe_get_field :obi_loc ocond)) + (ctest (unsafe_get_field :obcond_test ocond)) + (cthen (unsafe_get_field :obcond_then ocond)) + (celse (unsafe_get_field :obcond_else ocond)) + ) + (output_location cloc implbuf depth) + (add2sbuf_strconst implbuf "/*cond*/ if (") + (output_c_code ctest declbuf implbuf (+i depth 1)) + (add2sbuf_strconst implbuf ") /*then*/ {") + (add2sbuf_indentnl implbuf depth) + (output_c_code cthen declbuf implbuf (+i depth 1)) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depth) + (if celse + (progn + (add2sbuf_indentnl implbuf depth) + (add2sbuf_strconst implbuf "} else {") + (add2sbuf_indentnl implbuf (+i depth 1)) + (output_c_code celse declbuf implbuf (+i depth 1)) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf (+i depth 1)) + (add2sbuf_strconst implbuf "}") ; + ) + (add2sbuf_strconst implbuf "} /*noelse*/") + ) + (add2sbuf_indentnl implbuf depth) + ) + (debug_msg "outpucod_objcond end ocond" ocond (the_callcount)) + ) +(install_method class_objcond output_c_code outpucod_objcond) + +;; output an application +(defun outpucod_objapply (oapp declbuf implbuf :long depth) + (assert_msg "check oapp" (is_a oapp class_objapply)) + (debug_msg "outpucod_objapply oapp" oapp (the_callcount)) + (let ( + (aloc (unsafe_get_field :obi_loc oapp)) + (adest (unsafe_get_field :obapp_dest oapp)) + (oclos (unsafe_get_field :obapp_clos oapp)) + (oargs (unsafe_get_field :obapp_args oapp)) + (:long nbarg (multiple_length oargs)) + (paramdesclist (make_list discr_list)) + (boxdepthp1 (make_integerbox discr_integer (+i 1 depth))) + ) + (output_location aloc implbuf depth) + (add2sbuf_strconst implbuf "/*apply*/{") + (add2sbuf_indentnl implbuf (+i 1 depth)) + (if (>i nbarg 1) + (progn + (add2sbuf_strconst implbuf "union basilysparam_un argtab[") + (add2sbuf_longdec implbuf (-i nbarg 1)) + (add2sbuf_strconst implbuf "];") + (add2sbuf_indentnl implbuf (+i 1 depth)) + (add2sbuf_strconst implbuf "memset(&argtab, 0, sizeof(argtab));") + (add2sbuf_indentnl implbuf (+i 1 depth)) + ;; output the initialization of argtab and fill the paramdesclist + (multiple_iterate + oargs + (lambda (curarg :long curank) + (debug_msg "outputcod_objapply curarg" curarg) + (debug_msg "outputcod_objapply curarg discr" (discrim curarg)) + (cbreak_msg "outputcod_objapply curarg") + (if (>i curank 0) + (let ( (curctyp (get_ctype curarg (the_null))) ) + (debug_msg "outputcod_objapply curctyp" curctyp) + (assert_msg "check curctyp" (is_a curctyp class_ctype)) + (output_location aloc implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf "argtab[") + (add2sbuf_longdec implbuf (-i curank 1)) + (add2sbuf_strconst implbuf "].") + (list_append paramdesclist (unsafe_get_field :ctype_parstring curctyp)) + (if (== curctyp ctype_value) + (progn + (add2sbuf_strconst implbuf "bp_aptr = (basilys_ptr_t*) &") + (output_c_code curarg declbuf implbuf (get_int boxdepthp1)) + ) + (progn + (add2sbuf_string implbuf (unsafe_get_field :ctype_argfield curctyp)) + (add2sbuf_strconst implbuf " = ") + (output_c_code curarg declbuf implbuf (get_int boxdepthp1)) + )) + (add2sbuf_strconst implbuf ";") + )) + oargs + )) + (add2sbuf_indentnl implbuf (get_int boxdepthp1)) + )) +;;; output the destination(s) + (list_iterate + adest + (lambda (curdest) + (output_c_code curdest declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf " = ") + adest + ) + ) + ;; output the apply and the closure + (add2sbuf_strconst implbuf " basilysgc_apply ((void*)(") + (output_c_code oclos declbuf implbuf (+i 1 depth)) + (add2sbuf_strconst implbuf "), (") + ;; output the first argument + (let ( (firstarg (multiple_nth oargs 0)) ) + (output_c_code firstarg declbuf implbuf (+i 1 depth)) + ) + (add2sbuf_strconst implbuf "), (") + ;; output the argdescr string + (list_iterate + paramdesclist + (lambda (pard) + (add2sbuf_string implbuf pard) + (add2sbuf_strconst implbuf " ") + paramdesclist)) + (add2sbuf_strconst implbuf "\"\"), ") + ;; output the argtab (or null if none) + (if (>i nbarg 1) + (add2sbuf_strconst implbuf "argtab,") + (add2sbuf_strconst implbuf "(union basilysparam_un*)0,")) + ;; no extra results + (add2sbuf_strconst implbuf " \"\", (union basilysparam_un*)0") + (add2sbuf_strconst implbuf ");") + (add2sbuf_indentnl implbuf (+i 1 depth)) + (add2sbuf_strconst implbuf "}") + (add2sbuf_indentnl implbuf depth) + ) + ) +(install_method class_objapply output_c_code outpucod_objapply) + +;; output a clear +(defun outpucod_objclear (oclear declbuf implbuf :long depth) + (assert_msg "check oclear" (is_a oclear class_objclear)) + (debug_msg "outpucod_objclear oclear" oclear (the_callcount)) + (let ( (cloc (unsafe_get_field :obi_loc oclear)) + (cvl (unsafe_get_field :oclr_vloc oclear)) + ) + (output_location cloc implbuf depth) + (add2sbuf_strconst implbuf "/*clear*/ ") + (output_c_code cvl declbuf implbuf (+i depth 1)) + (add2sbuf_strconst implbuf " = 0 ") + ) + ) +(install_method class_objclear output_c_code outpucod_objclear) + +;; output a raw object allocation +(defun outpucod_objrawallocobj (oralob declbuf implbuf :long depth) + (assert_msg "check oralob" (is_a oralob class_objrawallocobj)) + (debug_msg "outpucod_objrawallocobj oralob" oralob) + (let ( (iloc (unsafe_get_field :obi_loc oralob)) + (iclass (unsafe_get_field :obrallobj_class oralob)) + (ilen (unsafe_get_field :obrallobj_len oralob)) + (destlist (unsafe_get_field :obrallobj_dest oralob)) + (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) + ) + (output_location iloc implbuf depth) + (add2sbuf_strconst implbuf "/*rawallocobj*/") + (list_iterate + destlist + (lambda (dst) + (output_c_code dst declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf " = ") + destlist)) + (add2sbuf_strconst implbuf "basilysgc_new_raw_object((") + (output_c_code iclass declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf "), (") + (output_c_code ilen declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf "));") + (add2sbuf_indentnl implbuf depth) +)) +(install_method class_objrawallocobj output_c_code outpucod_objrawallocobj) + + +;; output a closure allocation +(defun outpucod_objnewclosure (obnclo declbuf implbuf :long depth) + (assert_msg "check oralob" (is_a obnclo class_objnewclosure)) + (debug_msg "outpucod_objnewclosure obnclo" obnclo) + (let ( (iloc (unsafe_get_field :obi_loc obnclo)) + (odiscr (unsafe_get_field :obnclo_discr obnclo)) + (orout (unsafe_get_field :obnclo_rout obnclo)) + (olen (unsafe_get_field :obnclo_len obnclo)) + (destlist (unsafe_get_field :obnclo_dest obnclo)) + (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) + ) + (output_location iloc implbuf depth) + (add2sbuf_strconst implbuf "/*newclosure*/") + (list_iterate + destlist + (lambda (dst) + (output_c_code dst declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf " = ") + destlist)) + (add2sbuf_strconst implbuf "basilysgc_new_closure((basilysobject_ptr_t)(") + (output_c_code odiscr declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf "), (basilysroutine_ptr_t)(") + (output_c_code orout declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf "), (") + (output_c_code olen declbuf implbuf (get_int boxdepthp1)) + (add2sbuf_strconst implbuf "));") + (add2sbuf_indentnl implbuf depth) +)) +(install_method class_objnewclosure output_c_code outpucod_objnewclosure) + +;; output a touch +(defun outpucod_objtouch (otouch declbuf implbuf :long depth) + (assert_msg "check oclear" (is_a otouch class_objtouch)) + (let ( (iloc (unsafe_get_field :obi_loc otouch)) + (touched (unsafe_get_field :otouch_val otouch)) + (comm (unsafe_get_field :otouch_comment otouch)) + ) + (output_location iloc implbuf depth) + (if comm + (progn + (add2sbuf_strconst implbuf "/*touch:") + (add2sbuf_cident implbuf comm) + (add2sbuf_strconst implbuf "*/"))) + (add2sbuf_strconst implbuf " basilysgc_touch(") + (output_c_code touched declbuf implbuf depth) + (add2sbuf_strconst implbuf ");") + (add2sbuf_indentnl implbuf depth) + ) +) +(install_method class_objtouch output_c_code outpucod_objtouch) + + + +;;; output a put tuple (mostly used in initial data content filling) +(defun outpucod_objputuple (optup declbuf implbuf :long depth) + (assert_msg "check optyp" (is_a optup class_objputuple)) + (debug_msg "outpucod_objputuple optup" optup (the_callcount)) + (let ( (iloc (unsafe_get_field :obi_loc optup)) + (otup (unsafe_get_field :oputu_tupled optup)) + (ooff (unsafe_get_field :oputu_offset optup)) + (oval (unsafe_get_field :oputu_value optup)) ) + (output_location iloc implbuf depth) + (add2sbuf_strconst implbuf "/*putuple*/ ((basilysmultiple_ptr_t)(") + (output_c_code otup declbuf implbuf depth) + (add2sbuf_strconst implbuf "))->tabval[") + (output_c_code ooff declbuf implbuf depth) + (add2sbuf_strconst implbuf "] = ") + (output_c_code oval declbuf implbuf depth) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depth) + ) + ) +(install_method class_objputuple output_c_code outpucod_objputuple) + + +;;; output a put slot (mostly used in initial data content filling) +(defun outpucod_objputslot (opslo declbuf implbuf :long depth) + (assert_msg "check opslo" (is_a opslo class_objputslot)) + (debug_msg "outpucod_objputslot opslo" opslo (the_callcount)) + (let ( (iloc (unsafe_get_field :obi_loc opslo)) + (odata (unsafe_get_field :oslot_odata opslo)) + (ooff (unsafe_get_field :oslot_offset opslo)) + (oval (unsafe_get_field :oslot_value opslo)) + ) + (output_location iloc implbuf depth) + (add2sbuf_strconst implbuf "/*putslot*/ ((basilysobject_ptr_t)(") + (output_c_code odata declbuf implbuf depth) + (add2sbuf_strconst implbuf "))->obj_vartab[") + (output_c_code ooff declbuf implbuf depth) + (add2sbuf_strconst implbuf "] = ") + (output_c_code oval declbuf implbuf depth) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depth) + )) +(install_method class_objputslot output_c_code outpucod_objputslot) + + +;;; output the putting of the routine in a closure +(defun outpucod_objputclosurout (opclor declbuf implbuf :long depth) + (assert_msg "check opclor" (is_a opclor class_objputclosurout)) + (debug_msg "outpucod_objputclosurout opclor" opclor) + (let ( (oloc (unsafe_get_field :obi_loc opclor)) + (oclos (unsafe_get_field :opclor_clos opclor)) + (orout (unsafe_get_field :opclor_rout opclor)) ) + (output_location oloc implbuf depth) + (add2sbuf_strconst implbuf "/*putclosrout*/ ((basilysclosure_ptr_t)") + (output_c_code oclos declbuf implbuf depth) + (add2sbuf_strconst implbuf ")->rout = ") + (output_c_code orout declbuf implbuf depth) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depth) + ) +) +(install_method class_objputclosurout output_c_code outpucod_objputclosurout) + +;;; output the putting of a closed value +(defun outpucod_objputclosedv (opclov declbuf implbuf :long depth) + (assert_msg "check opclor" (is_a opclov class_objputclosedv)) + (debug_msg "outpucod_objputclosedv" opclov) + (let ( (oloc (unsafe_get_field :obi_loc opclov)) + (oclos (unsafe_get_field :opclov_clos opclov)) + (ooff (unsafe_get_field :opclov_off opclov)) + (ocval (unsafe_get_field :opclov_cval opclov)) ) + (output_location oloc implbuf depth) + (add2sbuf_strconst implbuf "/*putclosval*/ ((basilysclosure_ptr_t)") + (output_c_code oclos declbuf implbuf depth) + (add2sbuf_strconst implbuf ")->tabval[") + (output_c_code ooff declbuf implbuf depth) + (add2sbuf_strconst implbuf "] = ") + (output_c_code ocval declbuf implbuf depth) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depth) + )) +(install_method class_objputclosedv output_c_code outpucod_objputclosedv) + + +;; output the putting of a constant value inside a routine +(defun outpucod_objputroutconst (oprconst declbuf implbuf :long depth) + (assert_msg "check oprconst" (is_a oprconst class_objputroutconst)) + (let ( (oloc (unsafe_get_field :obi_loc oprconst)) + (orout (unsafe_get_field :oprconst_rout oprconst)) + (ooff (unsafe_get_field :oprconst_off oprconst)) + (ocval (unsafe_get_field :oprconst_cval oprconst)) ) + (output_location oloc implbuf depth) + (add2sbuf_strconst implbuf "/*putroutconst*/ ((basilysroutine_ptr_t)") + (output_c_code orout declbuf implbuf depth) + (add2sbuf_strconst implbuf ")->tabval[") + (output_c_code ooff declbuf implbuf depth) + (add2sbuf_strconst implbuf "] = ") + (output_c_code ocval declbuf implbuf depth) + (add2sbuf_strconst implbuf ";") + (add2sbuf_indentnl implbuf depth) + ) + ) +(install_method class_objputroutconst output_c_code outpucod_objputroutconst) + +;;; output an expression +(defun outpucod_objexpv (oexp declbuf implbuf :long depth) + (assert_msg "check oexp" (is_a oexp class_objexpv)) + (let ( (cont (unsafe_get_field :obx_cont oexp)) + (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) + ) + (assert_msg "check cont" (is_multiple cont)) + (multiple_iterate + cont + (lambda (comp :long ix) + (output_c_code comp declbuf implbuf (get_int boxdepthp1)) + cont))) +) +(install_method class_objexpv output_c_code outpucod_objexpv) + +;;; output a verbatim string +(defun outpucod_verbatimstring (vstr declbuf implbuf :long depth) + (assert_msg "check vstr" (== (discrim vstr) discr_verbatimstring)) + (add2sbuf_string implbuf vstr) +) +(install_method discr_verbatimstring output_c_code outpucod_verbatimstring) + +;; output a string (cstring constant) +(defun outpucod_string (vstr declbuf implbuf :long depth) + (assert_msg "check vstr" (== (discrim vstr) discr_string)) + (add2sbuf_strconst implbuf " \"") + (add2sbuf_cencstring implbuf vstr) + (add2sbuf_strconst implbuf "\"") +) +(install_method discr_string output_c_code outpucod_string) + +;;; output an integer +(defun outpucod_integer (vint declbuf implbuf :long depth) + (assert_msg "check vint" (is_integerbox vint)) + (add2sbuf_longdec implbuf (get_int vint)) +) +(install_method discr_integer output_c_code outpucod_integer) + +;;; output a finalreturn +(defun outpucod_finalreturn (fret declbuf implbuf :long depth) + (assert_msg "check fret" (is_a fret class_objfinalreturn)) + (output_location (unsafe_get_field :obi_loc fret)) + (add2sbuf_strconst implbuf "/*finalret*/ goto labend_rout ") +) +(install_method class_objfinalreturn output_c_code outpucod_finalreturn) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; compile a single procedure +(defun compile2obj_procedure (pro compicache :long num) + (debug_msg "compilproc pro" pro (the_callcount)) + (debug_msg "compilproc compicache" compicache (the_callcount)) + (assert_msg "check pro" (is_a pro class_nrep_routproc)) + (assert_msg "check compicache" (is_mapobject compicache)) + (let ( (namsbuf (make_strbuf discr_strbuf)) ) + (add2sbuf_strconst namsbuf "rout_") + (add2sbuf_longdec namsbuf num) + (if (is_a pro class_nrep_routproc) + (let ( (pronam (unsafe_get_field :nrpro_name pro)) + ) + (if (is_a pronam class_named) + (progn + (add2sbuf_strconst namsbuf "_") + (add2sbuf_cident namsbuf (unsafe_get_field :named_name pronam))) + ))) + (let ( + (nbody (unsafe_get_field :nproc_body pro)) + (nargb (unsafe_get_field :nrpro_argb pro)) + (obodylist (make_list discr_list)) + (obrout (make_instance class_procroutineobj + :named_name (strbuf2string discr_string namsbuf) + :obrout_proc pro + :obrout_body obodylist + :obrout_nbval (make_integerbox discr_integer 0) + :obrout_nblong (make_integerbox discr_integer 0) + )) + (locmap (make_mapobject discr_mapobjects (+i 20 (*i 3 (multiple_length nargb))))) + (gcx (make_instance class_genercontext + :gncx_objrout obrout + :gncx_locmap locmap + :gncx_freeptrlist (make_list discr_list) + :gncx_freelonglist (make_list discr_list) + :gncx_freeothermaps (make_mapobject discr_mapobjects 20) + :gncx_compicache compicache + )) + (retloc + (let ( (retl (get_free_objlocptr gcx '_retval_)) ) + (unsafe_put_fields gcx :gncx_retloc retl) + retl)) + (gtatup + (multiple_map + nargb + (lambda (bnd :long ix) + (assert_msg "check bnd" (is_a bnd class_formal_binding)) + ; (debug_msg "compilproc bnd" bnd (the_callcount)) + (let ( (bctyp (unsafe_get_field :fbind_type bnd)) + (bnam (unsafe_get_field :binder bnd)) + (oloc + (cond ( (== bctyp ctype_value) + (get_free_objlocptr gcx bnam) ) + ( (== bctyp ctype_long) + (get_free_objloclong gcx bnam) ) + (:else + (get_free_objloctyped gcx bnam bctyp))) + ) + (ogarg + (make_instance class_objgetarg + :obi_loc (unsafe_get_field :nrep_loc pro) + :obarg_obloc oloc + :obarg_bind bnd)) + ) + (mapobject_put locmap bnd oloc) + ogarg + )) + )) + ) + ;; associate the procedure with its objroutine in the compiler cache + (mapobject_put compicache pro obrout) + (unsafe_put_fields obrout :oprout_getargs gtatup) + (debug_msg "compile2obj_procedure obrout" obrout (the_callcount)) + (debug_msg "compile2obj_procedure nbody" nbody (the_callcount)) + (assert_msg "check nbody" (is_a nbody class_nrep)) + (if (is_a pro class_nrep_routproc) + (let ( (pthuls (unsafe_get_field :nrpro_thunklist pro)) ) + (debug_msg "compile2obj_procedure pthuls" pthuls (the_callcount)) + (list_iterate + pthuls + (lambda (pthu) + (debug_msg "compile2obj_procedure pthu" pthu) + (assert_msg "compile2obj_procedure check pthu" (is_closure pthu)) + (pthu gcx) + pthu + ) + ))) + (let ( (obody (compile_obj nbody gcx)) + ) + (debug_msg "compile2obj_procedure obody" obody (the_callcount)) + (list_append obodylist obody) + ) + (debug_msg "compile2obj_procedure return obrout" obrout (the_callcount)) + obrout + ))) + +;;;; compile the initial procedure into an object +(defun compile2obj_initproc (ipro idata compicache) + (assert_msg "check ipro" (is_a ipro class_nrep_initproc)) + (assert_msg "check idata" (is_list idata)) + (assert_msg "check compicache" (is_mapobject compicache)) + (debug_msg "compile2obj_initproc ipro" ipro (the_callcount)) + (debug_msg "compile2obj_initproc compicache" compicache (the_callcount)) + (let ( (locmap (make_mapobject discr_mapobjects 50)) + (oinibody (make_list discr_list)) + (oinitrout + (make_instance class_initialroutineobj + :named_name (make_stringconst discr_string "start_module_basilys") + :obrout_proc ipro + :obrout_body oinibody + :obrout_nbval (make_integerbox discr_integer 0) + :obrout_nblong (make_integerbox discr_integer 0) + :oirout_fill (make_list discr_list) + )) + (gcx (make_instance class_genercontext + :gncx_objrout oinitrout + :gncx_locmap locmap + :gncx_freeptrlist (make_list discr_list) + :gncx_freelonglist (make_list discr_list) + :gncx_freeothermaps (make_mapobject discr_mapobjects 20) + :gncx_compicache compicache + )) + (retloc + (let ( (retl (get_free_objlocptr gcx '_retinit_)) ) + (unsafe_put_fields gcx :gncx_retloc retl) + retl)) + (odatatup + (list_to_multiple + idata discr_multiple + (lambda (curdat) + (debug_msg "compile2obj_initproc curdat" curdat (the_callcount)) + (assert_msg "check curdat" (is_a curdat class_nrep_data)) + (let ( (curobd (compile_obj curdat gcx)) ) + (debug_msg "compile2obj_initproc curobd" curobd (the_callcount)) + curobd)))) + (toplis (unsafe_get_field :ninit_topl ipro)) + ) + (unsafe_put_fields oinitrout + :oirout_data odatatup) + (assert_msg "check toplis" (is_list_or_null toplis)) + (list_iterate + toplis + (lambda (curtop) + (let ( (otop (compile_obj curtop gcx)) ) + (debug_msg "compile2obj_initproc otop" otop (the_callcount)) + (list_append oinibody otop) + toplis + ))) + (debug_msg "compile2obj_initproc final gcx" gcx (the_callcount)) + (debug_msg "compile2obj_initproc final oinitrout" oinitrout (the_callcount)) +; (assert_msg "compile2obj_initproc @@@ A COMPLETER" ()) + oinitrout + )) + +;; compile a list of sexpressions as a module starting from a given environment +(defun compile_list_sexpr (lsexp inienv modnamstr) + (debug_msg "\n\n*compile_list_sexpr lsexp" lsexp (the_callcount)) ;list of sexpr + (debug_msg "compile_list_sexpr inienv" inienv (the_callcount)) ;initial environment + (debug_msg "compile_list_sexpr modnamstr" modnamstr (the_callcount)) ;module name + (assert_msg "check lsexp" (is_list lsexp)) + (assert_msg "check modnamstr" (is_string modnamstr)) + (assert_msg "check inienv" (is_a inienv class_environment)) + (let ( (ncx (create_normcontext)) ) + (debug_msg "compile_list_sexpr initial ncx" ncx (the_callcount)) + (assert_msg "check ncx" (is_a ncx class_normcontext)) + (let ( (xlist (macroexpand_toplevel_list lsexp inienv)) + (iniproc (unsafe_get_field :nctx_initproc ncx)) + ) + (debug_msg "after macroexpansion compile_list_sexpr seq" xlist (the_callcount)) + (debug_msg "after macroexpansion compile_list_sexpr inienv" inienv (the_callcount)) + (assert_msg "check iniproc" (is_a iniproc class_nrep_initproc)) + (list_iterate + xlist + (lambda (sexp :long ix) + (debug_msg "compile_list_sexpr sexp" sexp (the_callcount)) + (let ( + (psloc (if (is_a sexp class_located) (unsafe_get_field :loca_location sexp))) + ) + (multicall + (nexp nbind) + (normal_exp sexp inienv ncx psloc) + (debug_msg "compile_list_sexpr nexp" nexp (the_callcount)) + (debug_msg "compile_list_sexpr nbind" nbind (the_callcount)) + (if (and (is_a nexp class_nrep) + (not (is_a nexp class_nrep_anyproc))) + (let ( (wnexp (wrap_normal_let1 nexp nbind psloc)) ) + (debug_msg "compile_list_sexpr wnexp" wnexp (the_callcount)) + (list_append (unsafe_get_field :ninit_topl iniproc) + wnexp) + )) + sexp + )))) + (let ( (prolist (unsafe_get_field :nctx_proclist ncx)) + (objlist (make_list discr_list)) + (compicache (make_mapobject discr_mapobjects (+i 10 (*i 20 (list_length xlist))))) + (countbox (make_integerbox discr_integer 0)) + ) + (assert_msg "check prolist" (is_list prolist)) + (list_iterate + prolist + (lambda (pro) + (assert_msg "check pro" (is_a pro class_nrep_anyproc)) + (debug_msg "compile_list_sexpr pro" pro (the_callcount)) + (put_int countbox (+i (get_int countbox) 1)) + (let ( (objpro (compile2obj_procedure pro compicache (get_int countbox))) ) + (debug_msg "compile_list_sexpr objpro" objpro (the_callcount)) + (debug_msg "compile_list_sexpr done pro" pro (the_callcount)) + (list_append objlist objpro) + (debug_msg "compile_list_sexpr compicache" compicache (the_callcount)) + objpro + )) + ) + (debug_msg "compilistsexpr ncx avant inipro" ncx (the_callcount)) + (let ( (inipro (unsafe_get_field :nctx_initproc ncx)) + (inidata (unsafe_get_field :nctx_datalist ncx)) + ) + (assert_msg "check inipro" (is_a inipro class_nrep_initproc)) + (debug_msg "compilistsexpr avant compilinitproc compicache" compicache (the_callcount)) + (let ( (iniobj (compile2obj_initproc inipro inidata compicache)) ) + (debug_msg "compile_list_sexpr iniobj" iniobj (the_callcount)) + (let ( (declbuf (make_strbuf discr_strbuf)) + (implbuf (make_strbuf discr_strbuf)) + ) + (list_iterate + objlist + (lambda (obel) + (debug_msg "compile_list_sexpr obel" obel (the_callcount)) + (output_c_code obel declbuf implbuf 0) + objlist)) + (debug_msg "compile_list_sexpr final modnamstr" modnamstr (the_callcount)) + (debug_msg "compile_list_sexpr outputting iniobj" iniobj (the_callcount)) + (output_c_code iniobj declbuf implbuf 0) + (output_cfile_decl_impl modnamstr declbuf implbuf) + ))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; function to get a free local value pointer for some name +(defun get_free_objlocptr (gcx nam) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (orout (unsafe_get_field :gncx_objrout gcx)) + (freeli (unsafe_get_field :gncx_freeptrlist gcx)) + (pfree (list_popfirst freeli)) + ) + (if (not (is_a orout class_routineobj)) + (progn + (debug_msg "get_free_objlocptr bad orout" orout (the_callcount)) + (shortbacktrace_dbg "get_free_objlocptr bad orout" 15))) + (assert_msg "check orout" (is_a orout class_routineobj)) + (if (is_a pfree class_objlocv) + (let ( (nambuf (make_strbuf discr_strbuf)) ) + (assert_msg "check pfreetyo" (== ctype_value (unsafe_get_field :obv_type pfree))) + (if (is_a nam class_named) + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) + (add2sbuf_strconst nambuf "__V") + (add2sbuf_longdec nambuf (get_int (unsafe_get_field :obl_off pfree))) + (unsafe_put_fields pfree :obl_cname (strbuf2string discr_string nambuf)) + pfree) + (let ( (nbvalbox (unsafe_get_field :obrout_nbval orout)) + (:long nbval (get_int nbvalbox)) + (nambuf (make_strbuf discr_strbuf)) + ) + (if (is_a nam class_named) + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) + (add2sbuf_strconst nambuf "__V") + (add2sbuf_longdec nambuf (+i nbval 1)) + (put_int nbvalbox (+i nbval 1)) + (let ( (nloc (make_instance class_objlocv + :obv_type ctype_value + :obl_off (make_integerbox discr_integer nbval) + :obl_proc orout + :obl_cname (strbuf2string discr_string nambuf))) ) + nloc + ))))) + +;;; function to get a free local long for some name +(defun get_free_objloclong (gcx nam) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (orout (unsafe_get_field :gncx_objrout gcx)) + (freeli (unsafe_get_field :gncx_freelonglist gcx)) + (pfree (list_popfirst freeli)) + ) + (assert_msg "check orout" (is_a orout class_routineobj)) + (if (is_a pfree class_objlocv) + (let ( (nambuf (make_strbuf discr_strbuf)) ) + (assert_msg "check pfreetyo" (== ctype_long (unsafe_get_field :obv_type pfree))) + (if (is_a nam class_named) + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) + (add2sbuf_strconst nambuf "__L") + (add2sbuf_longdec nambuf (get_int (unsafe_get_field :obl_off pfree))) + (unsafe_put_fields pfree :obl_cname (strbuf2string discr_string nambuf)) + pfree) + (let ( (nblongbox (unsafe_get_field :obrout_nblong orout)) + (:long nblong (get_int nblongbox)) + (nambuf (make_strbuf discr_strbuf)) + ) + (if (is_a nam class_named) + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) + (add2sbuf_strconst nambuf "__L") + (add2sbuf_longdec nambuf (+i nblong 1)) + (put_int nblongbox (+i nblong 1)) + (let ( (nloc (make_instance class_objlocv + :obv_type ctype_long + :obl_off (make_integerbox discr_integer nblong) + :obl_cname (strbuf2string discr_string nambuf))) ) + nloc + ))))) + +;;; function to get a free local otherstuff for some name and ctype +;;; @@ NOT IMPLEMENTED YET for arbitrary ctypes +(defun get_free_objloctyped (gcx nam ctyp) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + ;; (assert_msg "check ctyp" (is_a ctyp class_ctype)) + (cond ( (== ctyp ctype_long) + (get_free_objloclong gcx nam)) + ( (== ctyp ctype_value) + (get_free_objlocptr gcx nam)) + ;; return null for the void ctype + ( (== ctyp ctype_void) + ()) + (:else + (debug_msg "getfreeobjloctyped nam" nam (the_callcount)) + (debug_msg "getfreeobjloctyped ctyp" ctyp (the_callcount)) + (assert_msg "@@@ unimplemented get_free_objloctyped for other ctyp" ()) +))) + + + +;; function to dispose, i.e. mark as free, a binding +(defun dispose_bnd_obj (bnd gcx) + (assert_msg "check bnd" (is_a bnd class_any_binding)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (locmap (unsafe_get_field :gncx_locmap gcx)) + (oldloc (mapobject_get locmap bnd)) ) + (if (null oldloc) + (progn + ;; special hack to dispose a void let binding - return immediately in that case + (and (is_a bnd class_let_binding) + (== (unsafe_get_field :letbind_type bnd) ctype_void) + (return)) + (debug_msg "dispose_bnd_obj nulloldloc bnd" bnd (the_callcount)) + )) + (assert_msg "check oldloc" (is_a oldloc class_objlocv)) + (mapobject_remove locmap bnd) + (let ( (oldcty (unsafe_get_field :obv_type oldloc)) ) + (cond ( (== oldcty ctype_value) + (let ( (freepl (unsafe_get_field :gncx_freeptrlist gcx)) ) + (list_append freepl oldloc))) + ( (== oldcty ctype_long) + (let ( (freenl (unsafe_get_field :gncx_freelonglist gcx)) ) + (list_append freenl oldloc))) + (:else + ;; we have a map from ctypes to free list, add it there! + (assert_msg "@@@ unimplemented dispose_bnd_obj non-value non-long" ()))) +))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_chunk (nchk gcx) + (assert_msg "check nchk" (is_a nchk class_nrep_chunk)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj nrepchunk nchk" nchk (the_callcount)) +; (debug_msg "compilobj nrepchunk gcx" gcx (the_callcount)) +; (debug_msg "compilobj nrepchunk env" env (the_callcount)) + (let ( (loc (unsafe_get_field :nrep_loc nchk)) + (nexp (unsafe_get_field :nchunk_expansion nchk)) + (nprim (unsafe_get_field :nchunk_primitive nchk)) + ) + (assert_msg "check nprim" (is_a nprim class_primitive)) + (assert_msg "check nexp" (is_multiple nexp)) + (let ( (otup (multiple_map + nexp + (lambda (comp :long ix) + (debug_msg "compobj nrepchunk comp" comp (the_callcount)) + (if (== (discrim comp) discr_verbatimstring) + comp + (compile_obj comp gcx))) + )) + (oexp (make_instance class_objexpv + :obv_type (unsafe_get_field :prim_type nprim) + :obx_cont otup + )) + ) + (debug_msg "compiobj nrepchunk oexp" oexp (the_callcount)) + oexp) + )) +(install_method class_nrep_chunk compile_obj compilobj_nrep_chunk) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_locsymocc (lsyo gcx) + (assert_msg "check nchk" (is_a lsyo class_nrep_locsymocc)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (loc (unsafe_get_field :nrep_loc lsyo)) + (locmap (unsafe_get_field :gncx_locmap gcx)) + (sym (unsafe_get_field :nocc_symb lsyo)) + (oty (unsafe_get_field :nocc_ctyp lsyo)) + (sbnd (unsafe_get_field :nocc_bind lsyo)) + (ovar (mapobject_get locmap sbnd)) + ) +; (debug_msg "compilobj locsymocc gcx" gcx (the_callcount)) + (debug_msg "compilobj locsymocc lsyo" lsyo (the_callcount)) +; (debug_msg "compilobj locsymocc sbnd" sbnd (the_callcount)) + (debug_msg "compilobj locsymocc oty" oty (the_callcount)) + (debug_msg "compilobj locsymocc ovar" ovar (the_callcount)) + (if (null sbnd) + (progn + (debug_msg "compilobj locsymocc null sbnd for sym" sym (the_callcount)) + (shortbacktrace_dbg "compilobj locsymocc null sbnd" 16) + )) + (if (null ovar) + (assert_msg "compilocsy null ovar with ctype_void" (== oty ctype_void)) + (assert_msg "compilocsy check ovar" (is_a ovar class_objlocv))) + ovar +)) +(install_method class_nrep_locsymocc compile_obj compilobj_nrep_locsymocc) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_closedocc (nclo gcx) + (assert_msg "check nclo" (is_a nclo class_nrep_closedocc)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj closedocc nclo" nclo (the_callcount)) + (debug_msg "compilobj closedocc gcx" gcx (the_callcount)) + (let ( + (orout (unsafe_get_field :gncx_objrout gcx)) + (osym (unsafe_get_field :nocc_symb nclo)) + (obind (unsafe_get_field :nocc_bind nclo)) + (cprocs (unsafe_get_field :ncloc_procs nclo)) + (lastcproc (pair_head (list_last cprocs))) + (nloc (unsafe_get_field :nrep_loc nclo)) + ) + (debug_msg "compilobj closedocc orout" orout (the_callcount)) + (assert_msg "check lastcproc" (is_a lastcproc class_nrep_routproc)) + (let ( (cloblis (unsafe_get_field :nrpro_closedb lastcproc)) + (:long clorank -1) + ) + (assert_msg "check cloblis" (is_list cloblis)) + (let ( (curpair (list_first cloblis)) + (:long curank 0) + ) + (forever + looplis + (if (not (is_pair curpair)) (exit looplis)) + (let ( (curbind (pair_head curpair)) ) + (if (== curbind obind) + (progn + (setq clorank curank) + (exit looplis))) + (setq curpair (pair_tail curpair)) + (setq curank (+i curank 1)) + )) + (assert_msg "check good closed rank" (>=i clorank 0)) + (let ( (ocloccv + (make_instance class_objcloccv + :obv_type (unsafe_get_field :nocc_ctyp nclo) + :obc_off (make_integerbox discr_integer + clorank) + :obc_proc lastcproc + :obc_name (unsafe_get_field :named_name osym))) ) + (debug_msg "compilobj closedocc result ocloccv" ocloccv (the_callcount)) + ocloccv + ))))) + +(install_method class_nrep_closedocc compile_obj compilobj_nrep_closedocc) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_constocc (ncnst gcx) + (assert_msg "check ncnst" (is_a ncnst class_nrep_constocc)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj constocc ncnst" ncnst (the_callcount)) + (debug_msg "compilobj constocc gcx" gcx (the_callcount)) + (let ( + (orout (unsafe_get_field :gncx_objrout gcx)) + (osym (unsafe_get_field :nocc_symb ncnst)) + (cprocs (unsafe_get_field :ncloc_procs ncnst)) + (lastcproc (pair_head (list_last cprocs))) + (nloc (unsafe_get_field :nrep_loc ncnst)) + ) + (debug_msg "compilobj constocc orout" orout (the_callcount)) + (assert_msg "check lastcproc" (is_a lastcproc class_nrep_routproc)) + (let ( (cnstlis (unsafe_get_field :nrpro_const lastcproc)) + (:long cnstrank -1) + ) + (assert_msg "check cnstlis" (is_list cnstlis)) + (let ( (curpair (list_first cnstlis)) + (:long curank 0) + ) + (forever + looplis + (if (not (is_pair curpair)) (exit looplis)) + (let ( (curelem (pair_head curpair)) ) + (if (== curelem ncnst) + (progn + (setq cnstrank curank) + (exit looplis))) + (setq curpair (pair_tail curpair)) + (setq curank (+i curank 1)) + )) + (assert_msg "check good const rank" (>=i cnstrank 0)) + (let ( (oconstv + (make_instance class_objconstv + :obv_type (unsafe_get_field :nocc_ctyp ncnst) + :obc_off (make_integerbox discr_integer + cnstrank) + :obc_proc lastcproc + :obc_name (unsafe_get_field :named_name osym))) ) + (debug_msg "compilobj constocc result oconstv" oconstv (the_callcount)) + oconstv + ))))) + +(install_method class_nrep_constocc compile_obj compilobj_nrep_constocc) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; compile a constant +(defun compilobj_nrep_constant (nconst gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (assert_msg "check nconst" (is_a nconst class_nrep_constant)) + (debug_msg "compilobj constant nconst" nconst (the_callcount)) + (let ( (nloc (unsafe_get_field :nrep_loc nconst)) + (sval (unsafe_get_field :nconst_sval nconst)) + (data (unsafe_get_field :nconst_data nconst)) + (proc (unsafe_get_field :nconst_proc nconst)) + ) + (if (is_a proc class_nrep_routproc) + (let ( (constlist (unsafe_get_field :nrpro_const proc)) + (curpair (list_first constlist)) + (:long coff -1) + (:long curank 0) + (nambuf (make_strbuf discr_strbuf)) + ) + (forever + constloop + (if (is_pair curpair) + (let ((curconst (pair_head curpair))) + (if (== curconst data) + (progn + (setq coff curank) + (exit constloop))) + ) + (exit constloop)) + (setq curpair (pair_tail curpair)) + (setq curank (+i curank 1)) + ) + (assert_msg "check coff" (>=i coff 0)) + (add2sbuf_strconst nambuf "konst_") + (add2sbuf_longdec nambuf coff) + (if (is_a sval class_named) + (progn + (add2sbuf_strconst nambuf "_") + (add2sbuf_cident nambuf (unsafe_get_field :named_name sval)) + ) + ) + (let ( (constv + (make_instance class_objconstv + :obv_type ctype_value + :obc_off (make_integerbox discr_integer coff) + :obc_proc proc + :obc_name (strbuf2string discr_string nambuf) + )) ) + (debug_msg "compilobj constant constv" constv (the_callcount)) + constv + ) + ) + (progn + ;; not inside a proc, just return the data + (debug_msg "compilobj constant just data" data (the_callcount)) + (return data) + ) + ) + ) + ) +(install_method class_nrep_constant compile_obj compilobj_nrep_constant) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; compile a forever +(defun compilobj_nrep_forever (nfor gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (assert_msg "check nfor" (is_a nfor class_nrep_forever)) + (debug_msg "compilobj_nrep_forever nfor" nfor (the_callcount)) + (debug_msg "compilobj_nrep_forever gcx" gcx (the_callcount)) + (let ( (nloc (unsafe_get_field :nrep_loc nfor)) + (nbind (unsafe_get_field :nforever_bind nfor)) + (nbody (unsafe_get_field :nforever_body nfor)) + (nres (unsafe_get_field :nforever_result nfor)) + (oresv (get_free_objlocptr gcx nres)) + ) + (assert_msg "check nbind" (is_a nbind class_label_binding)) + (unsafe_put_fields nbind :labind_res oresv) + (let ( (closy (unsafe_get_field :labind_clonsy nbind)) + (bodyl (make_list discr_list)) + (epilogl (make_list discr_list)) + (oloop (make_instance class_objloop + :obi_loc nloc + :oblo_bodyl bodyl + :oblo_epil epilogl + :obloop_label closy + :obloop_resv oresv)) + ) + (assert_msg "check closy" (is_a closy class_clonedsymbol)) + (multiple_iterate + nbody + (lambda (ncomp :long ix) + (list_append bodyl (compile_obj ncomp gcx)) + nbody)) + (debug_msg "compilobj loop result oloop" oloop (the_callcount)) + oloop + ) + ) +) +(install_method class_nrep_forever compile_obj compilobj_nrep_forever) + +;;;; compile an exit +(defun compilobj_nrep_exit (nexi gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (assert_msg "check nexi" (is_a nexi class_nrep_exit)) + (debug_msg "compilobj_nrep_exit nexi" nexi (the_callcount)) + (debug_msg "compilobj_nrep_exit gcx" gcx (the_callcount)) + (let ( (nloc (unsafe_get_field :nrep_loc nexi)) + (nbindx (unsafe_get_field :nexit_bind nexi)) + (nval (unsafe_get_field :nexit_val nexi)) ) + (assert_msg "check nbindx" (is_a nbindx class_label_binding)) + (let ( (obex (make_instance class_objexit + :obi_loc nloc + :obexit_label (unsafe_get_field :labind_clonsy nbindx) + :obexit_prolog (compile_obj nval gcx))) ) + obex +))) +(install_method class_nrep_exit compile_obj compilobj_nrep_exit) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_discrany (anyv gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) +; (debug_msg "compilobj_discrany anyv" anyv (the_callcount)) + anyv +) +(install_method discr_anyrecv compile_obj compilobj_discrany) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_let (rlet gcx) + (assert_msg "check rlet" (is_a rlet class_nrep_let)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (loc (unsafe_get_field :nrep_loc rlet)) + (bnd (unsafe_get_field :nlet_bindings rlet)) + (bdy (unsafe_get_field :nlet_body rlet)) + (locmap (unsafe_get_field :gncx_locmap gcx)) + (obodl (make_list discr_list)) + (oepil (make_list discr_list)) + (oblock (make_instance class_objblock + :obi_loc loc + :oblo_bodyl obodl + :oblo_epil oepil)) + ) + ;; (debug_msg "compilobj_nrep_let rlet" rlet (the_callcount)) + ;; (debug_msg "compilobj_nrep_let gcx" gcx (the_callcount)) + ;; (debug_msg "compilobj_nrep_let bnd" bnd (the_callcount)) + ;; for each normalexp in the bnd tuple + ;; add the binding and the setting in the body and the clear in the epilogue + (assert_msg "compilobj_nrep_let check bnd multiple" (is_multiple_or_null bnd)) + ;; iterate on source bindings + (multiple_iterate + bnd + (lambda (nlbnd :long ix) + ;; (debug_msg "compilobj_nrep_let nlbnd" nlbnd (the_callcount)) + (assert_msg "check nlbnd in compilobj_nrep_let" (is_a nlbnd class_normlet_binding)) + (let ( (bder (unsafe_get_field :binder nlbnd)) + (cty (unsafe_get_field :letbind_type nlbnd)) + (nexp (unsafe_get_field :letbind_expr nlbnd)) + (obva (get_free_objloctyped gcx bder cty)) + (obnx (compile_obj nexp gcx)) + ) + ;; (debug_msg "compilobj_nrep_let obnx" obnx (the_callcount)) + ;; link nlbnd to obva in locmap + (if obva (mapobject_put locmap nlbnd obva)) + ;; put destination obva in obnx + (let ( (obmy (if obva (put_objdest obnx obva) obnx)) ) + ;; add the modified obmy in the bodypart of oblock + (list_append obodl obmy) + ) + ;; add clearing of obva to epilogue part of oblock + (if obva + (let ( (obcl (make_instance class_objclear + :obi_loc loc + :oclr_vloc obva)) + ) + (list_append oepil obcl) + ))) + nlbnd ;; result of lambda in multiple_iterate + )) + ;; compile each body component + (multiple_iterate + bdy + (lambda (bdycomp :long ix) + ;; (debug_msg "compilobj_nrep_let bdycomp" bdycomp (the_callcount)) + (let ( (objcomp (compile_obj bdycomp gcx)) + ) + ;; (debug_msg "compilobj_nrep_let objcomp" objcomp (the_callcount)) + (list_append obodl objcomp) + ) + bdy ;result of lambda in multiple_iterate + )) + ;; dispose each binding + (multiple_iterate + bnd + (lambda (obnd :long ix) + (dispose_bnd_obj obnd gcx) + obnd)) + ; (debug_msg "compilobj_nrep_let oblock" oblock (the_callcount)) + oblock ;return it + )) + +(install_method class_nrep_let compile_obj compilobj_nrep_let) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_apply (napp gcx) + (assert_msg "check napp" (is_a napp class_nrep_apply)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (loc (unsafe_get_field :nrep_loc napp)) + (fun (unsafe_get_field :napp_fun napp)) + (args (unsafe_get_field :napp_args napp)) + ) +; (debug_msg "compilobj_nrep_apply napp" napp (the_callcount)) + (let ( (oclos (compile_obj fun gcx)) + (oargs (multiple_map args + (lambda (comp :long ix) + (compile_obj comp gcx)))) + (oapp + (make_instance + class_objapply + :obi_loc loc + :obapp_dest (make_list discr_list) + :obapp_clos oclos + :obapp_args oargs)) + ) +; (debug_msg "compilobj_nrep_apply oapp" oapp (the_callcount)) + oapp + ))) +(install_method class_nrep_apply compile_obj compilobj_nrep_apply) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun putobjdest_objvalue (recv desto) + (assert_msg "check recv" (is_a recv class_objvalue)) + (assert_msg "check desto" (is_a desto class_objlocv)) + (assert_msg "check typcomp" (== (unsafe_get_field :obv_type recv) + (unsafe_get_field :obv_type desto))) + (let ( (destlis (make_list discr_list)) + (explis (make_list discr_list)) + (obc (make_instance class_objcompute + ;; dont fill :obi_loc + :obcpt_dest destlis + :obcpt_expr explis + )) ) + (list_append destlis desto) + (list_append explis recv) +; (debug_msg "putobjdest objval obc" obc (the_callcount)) + obc +)) + +(install_method class_objvalue put_objdest putobjdest_objvalue) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun putobjdest_objblock (recv desto) + (assert_msg "check recv" (is_a recv class_objblock)) + (assert_msg "check desto" (is_a desto class_objlocv)) +; (debug_msg "putobjdest block recv" recv (the_callcount)) +; (debug_msg "putobjdest block desto" desto (the_callcount)) + (let ( (obl (unsafe_get_field :oblo_bodyl recv)) + (oep (unsafe_get_field :oblo_epil recv)) + ) + (assert_msg "check obl" (is_list_or_null obl)) + (assert_msg "check oep" (is_list_or_null oep)) + ;; maybe we should remove in the epilogue any clear of same ctype & offset + (let ( (lpby (list_last obl)) + (lasbp (pair_head lpby)) + ) + (if lasbp + (let ( (uplasb (put_objdest lasbp desto)) ) + (pair_set_head lpby uplasb) + ) + ) + ) +; (debug_msg "putobjdest block updated recv" recv (the_callcount)) + recv + )) + +(install_method class_objblock put_objdest putobjdest_objblock) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun putobjdest_objloop (recv desto) + (assert_msg "check recv" (is_a recv class_objloop)) + (assert_msg "check desto" (is_a desto class_objlocv)) + (let ( (epil (unsafe_get_field :oblo_epil recv)) + (resv (unsafe_get_field :obloop_resv recv)) + (obc (make_instance class_objcompute + ;; dont fill :obi_loc + :obcpt_dest desto + :obcpt_expr resv + )) + ) + (assert_msg "check epil" (is_list epil)) + (assert_msg "check resv" (is_a resv class_objlocv)) + (list_append epil obc) + ) + ;; (debug_msg "putobjdest loop updated recv" recv (the_callcount)) + recv + ) +(install_method class_objloop put_objdest putobjdest_objloop) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun putobjdest_objexit (recv desto) + (assert_msg "check recv" (is_a recv class_objexit)) + (assert_msg "check desto" (is_a desto class_objlocv)) + (let ( (oxpro (unsafe_get_field :obexit_prolog recv)) + (npro (put_objdest oxpro desto)) ) + (if (!= npro oxpro) + (unsafe_put_fields recv :obexit_prolog npro)) + recv +)) +(install_method class_objexit put_objdest putobjdest_objexit) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; put a destination inside a raw object allocation +(defun putobjdest_objrawallocobj (recv desto) + (assert_msg "check recv" (is_a recv class_objrawallocobj)) + (list_append (unsafe_get_field :obrallobj_dest recv) desto) + recv +) +(install_method class_objrawallocobj put_objdest putobjdest_objrawallocobj) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; put a destination inside a closure allocation +(defun putobjdest_objnewclosure (recv desto) + (assert_msg "check recv" (is_a recv class_objnewclosure)) + (list_append (unsafe_get_field :obnclo_dest recv) desto) + recv +) +(install_method class_objnewclosure put_objdest putobjdest_objnewclosure) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_nrep_if (rif gcx) + (assert_msg "check rif" (is_a rif class_nrep_if)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (let ( (loc (unsafe_get_field :nrep_loc rif)) + (ntest (unsafe_get_field :nif_test rif)) + (nthen (unsafe_get_field :nif_then rif)) + (nelse (unsafe_get_field :nif_else rif)) + (nctyp (unsafe_get_field :nif_ctyp rif)) + ) + (assert_msg "check nctyp" (is_a nctyp class_ctype)) + (let ( (otest (compile_obj ntest gcx)) + (othen (compile_obj nthen gcx)) + (oelse (compile_obj nelse gcx)) + (obif (make_instance class_objcond + :obi_loc loc + :obcond_test otest + :obcond_then othen + :obcond_else oelse)) + ) +; (debug_msg "compilobj_nrep_if obif" obif (the_callcount)) + obif + ))) +(install_method class_nrep_if compile_obj compilobj_nrep_if) +;;;;;;;;;;;;; +(defun putobjdest_objcond (recv desto) +; (debug_msg "putobjdest objcond recv" recv (the_callcount)) +; (debug_msg "putobjdest objcond desto" desto (the_callcount)) + (assert_msg "check recv" (is_a recv class_objcond)) + (assert_msg "check desto" (is_a desto class_objlocv)) + (let ( (othen (unsafe_get_field :obcond_then recv)) + (oelse (unsafe_get_field :obcond_else recv)) + ) + ; (debug_msg "putobjdest objcond othen" othen (the_callcount)) + ; (debug_msg "putobjdest objcond oelse" oelse (the_callcount)) + (let ( (dthen (put_objdest othen desto)) + (delse (put_objdest oelse desto)) ) +; (debug_msg "putobjdest objcond dthen" dthen (the_callcount)) +; (debug_msg "putobjdest objcond delse" delse (the_callcount)) + (unsafe_put_fields recv + :obcond_then dthen + :obcond_else delse) +; (debug_msg "putobjdest objcond updated recv" recv (the_callcount)) + recv + ))) + +(install_method class_objcond put_objdest putobjdest_objcond) +;;;;;;;;;;;;;;;; +(defun putobjdest_objapply (recv desto) + (debug_msg "putobjdest objapply recv" recv (the_callcount)) +; (debug_msg "putobjdest objapply desto" desto (the_callcount)) + (assert_msg "check recv" (is_a recv class_objapply)) + (assert_msg "check desto" (is_a desto class_objlocv)) + (let ( (adest (unsafe_get_field :obapp_dest recv)) ) + (assert_msg "check adest" (is_list adest)) + (list_prepend adest desto) + recv +)) +(install_method class_objapply put_objdest putobjdest_objapply) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +(defun compilobj_nrep_return (nret gcx) + (assert_msg "check nret" (is_a nret class_nrep_return)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) +; (debug_msg "compilobj_nrep_return gcx" gcx (the_callcount)) +; (debug_msg "compilobj_nrep_return nret" nret (the_callcount)) + (let ( (rloc (unsafe_get_field :nrep_loc nret)) + (rmain (unsafe_get_field :nret_main nret)) + (rrest (unsafe_get_field :nret_rest nret)) ;; a tuple or nil + (retloc (unsafe_get_field :gncx_retloc gcx)) + (orout (unsafe_get_field :gncx_objrout gcx)) + (olis (make_list discr_list)) + (oblock (make_instance class_objblock + :obi_loc rloc + :oblo_bodyl olis)) + (omainv (compile_obj rmain gcx)) + ) + (assert_msg "check orout" (is_a orout class_routineobj)) + (if (null (unsafe_get_field :obrout_retval orout)) + (unsafe_put_fields orout :obrout_retval retloc)) + (list_append olis (put_objdest omainv retloc)) + (multiple_iterate + rrest + (lambda (rxtra :long ix) +; (debug_msg "compilobj_nrep_return rxtra" rxtra (the_callcount)) + (let ( (oxres + (make_instance class_objputxtraresult + :obi_loc rloc + :obxres_rank (make_integerbox discr_integer ix) + :obxres_obloc (compile_obj rxtra gcx))) ) + ;; maybe we need to compute the ctype of the extra result.... +; (debug_msg "compilobj_nrep_return oxres" oxres (the_callcount)) + (list_append olis oxres) + ) + rrest ;return of lamda to continue iteration + ) + ) + (list_append olis + (make_instance class_objfinalreturn + :obi_loc rloc)) +; (debug_msg "compilobj_nrep_return final oblock" oblock (the_callcount)) + oblock + ) + ) +(install_method class_nrep_return compile_obj compilobj_nrep_return) + +;; all the closures generated by lambda share the same ... +(definstance discrclosure_objpredef class_objpredef + :obv_type ctype_value + :obpredef 'DISCR_CLOSURE + ) + +(defun compilobj_nrep_lambda (nlam gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (assert_msg "check nlam" (is_a nlam class_nrep_lambda)) + (debug_msg "compilobj_nrep_lambda nlam" nlam (the_callcount)) + (let ( (nloc (unsafe_get_field :nrep_loc nlam)) + (npro (let + ( (checkpro (unsafe_get_field :nlambda_proc nlam)) ) + (assert_msg "check checkpro" (is_a checkpro class_nrep_routproc)) + checkpro)) + (nam (unsafe_get_field :nrpro_name npro)) + (nclovtup (unsafe_get_field :nlambda_closedv nlam)) + (:long nbclosed (multiple_length nclovtup)) + (locv (get_free_objlocptr gcx nam)) + (nrou (unsafe_get_field :nlambda_constrout nlam)) + (orout (unsafe_get_field :gncx_objrout gcx)) + (olis (make_list discr_list)) + (oblock (make_instance class_objblock + :obi_loc nloc + :oblo_bodyl olis)) + (destlist (make_list discr_list)) + ) + (list_append destlist locv) + (list_append olis + (make_instance + class_objnewclosure + :obi_loc nloc + :obnclo_discr discrclosure_objpredef + :obnclo_rout + (progn + (debug_msg "compilobj_nrep_lambda should use nrpro_thunklist nrou" nrou (the_callcount)) + (let ( (crou (compile_obj nrou gcx)) ) + (debug_msg "compilobj_nrep_lambda crou" crou (the_callcount)) + crou) + ) + :obnclo_len (make_integerbox discr_integer nbclosed) + :obnclo_dest destlist)) + (multiple_iterate + nclovtup + (lambda (clov :long ix) + (debug_msg "compilobj_nrep_lambda clov" clov) + (list_append + olis + (make_instance class_objputclosedv + :obi_loc nloc + :opclov_clos locv + :opclov_off (make_integerbox discr_integer ix) + :opclov_cval (compile_obj clov gcx))) + nclovtup + )) + (list_append olis locv) ;;; last instruction is just the value, which can be set to some dest + (debug_msg "compilobj_nrep_lambda result oblock" oblock (the_callcount)) + oblock + )) +(install_method class_nrep_lambda compile_obj compilobj_nrep_lambda) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; compile a procedure should not be called +(defun compilobj_routproc (npro gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (assert_msg "check npro" (is_a npro class_nrep_routproc)) + (debug_msg "compilobj_routproc gcx" gcx (the_callcount)) + (debug_msg "compilobj_routproc npro" npro (the_callcount)) + (assert_msg "UNEXPECTED CALL TO compilobj_routproc" ()) +) +(install_method class_nrep_routproc compile_obj compilobj_routproc) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; +(defun compilobj_predef (npr gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) +; (debug_msg "compilobj_predef npr" npr (the_callcount)) + (let ( (opr (make_instance class_objpredef + :obv_type ctype_value + :obpredef (unsafe_get_field :nrpredef npr))) ) +; (debug_msg "compilobj_predef opr" opr (the_callcount)) + opr) +) + +(install_method class_nrep_predef compile_obj compilobj_predef) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; common code to compilobj_datasymbol & compilobj_datainstance +;;; to add the initial data fill and the slots filling +(defun compil_data_and_slots_fill (ndat obj odiscr irout gcx) + (assert_msg "compil_data_and_slots_fill check ndat" (is_a ndat class_nrep_data)) + (assert_msg "compil_data_and_slots_fill check obj" (is_a obj class_objinitobject)) + (assert_msg "compil_data_and_slots_fill check odiscr" (is_a odiscr class_objvalue)) + (assert_msg "compil_data_and_slots_fill check irout" (is_a irout class_initialroutineobj)) + (assert_msg "compil_data_and_slots_fill check gcx" (is_a gcx class_genercontext)) +;; (debug_msg "compil_data_and_slots_fill ndat" ndat (the_callcount)) +;; (debug_msg "compil_data_and_slots_fill obj" obj (the_callcount)) +;; (debug_msg "compil_data_and_slots_fill odiscr" odiscr (the_callcount)) +;; (debug_msg "compil_data_and_slots_fill irout un" irout (the_callcount)) + (let ( + (ibodylis (unsafe_get_field :obrout_body irout)) + (ifilllis (unsafe_get_field :oirout_fill irout)) + (locvar (get_free_objlocptr gcx '_valdata_)) + (comm (unsafe_get_field :named_name '_valuedata_)) + (nloc (unsafe_get_field :nrep_loc ndat)) + ) + (assert_msg "compil_data_and_slots_fill check ibodylis" (is_list ibodylis)) + (assert_msg "compil_data_and_slots_fill check fresh obj" (null (unsafe_get_field :oie_locvar obj))) + (unsafe_put_fields obj :oie_locvar locvar) + (assert_msg "check ifilllis" (is_list ifilllis)) + (assert_msg "check ibodylis" (is_list ibodylis)) + ;; for every non nil slot, append its initialization to the body of irout + (multiple_iterate + (unsafe_get_field :ninst_slots ndat) + (lambda (sloval :long slork) + ;; (debug_msg "compil_data_and_slots_fill sloval" sloval (the_callcount)) + (if sloval + (let ( (slobj (compile_obj sloval gcx)) + ) + ;; (debug_msg "compil_data_and_slots_fill slobj" slobj (the_callcount)) + (let ( (oput + (make_instance class_objputslot + :obi_loc nloc + :oslot_odata obj + :oslot_offset (make_integerbox discr_integer slork) + :oslot_value slobj + )) ) + (list_append ibodylis oput) + ) + ) +;;; add to list inifill the filling in dai of slot#slork by slobj + ) + ) + ndat ;return in iteration + ) + (list_append ibodylis + (make_instance class_objtouch + :obi_loc nloc + :obi_loc (unsafe_get_field :nrep_loc ndat) + :otouch_comment comm + :otouch_val obj)) + ) +;; (debug_msg "compil_data_and_slots_fill final irout" irout (the_callcount)) + (return) ;force a nil return + ) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(defun compilobj_datasymbol (syv gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (assert_msg "check syv" (is_a syv class_nrep_datasymbol)) + (debug_msg "compilobj_datasymbol syv" syv (the_callcount)) + (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) + (chobj (mapobject_get compicache syv)) + (inirout (unsafe_get_field :gncx_objrout gcx)) + ) + ;; datasymbol compiled only in initial routines + (assert_msg "check inirout" (is_a inirout class_initialroutineobj)) + (if chobj + (progn + (debug_msg "compilobj_datasymbol found chobj" chobj) + (return chobj))) + (let ( + (odiscr (compile_obj (unsafe_get_field :ndata_discrx syv) gcx)) + (obsym + (make_instance class_objinitobject + :obv_type ctype_value + :oie_data syv + :oie_discr odiscr + )) + ) + (mapobject_put compicache syv obsym) + (debug_msg "compilobj_datasymbol inirout" inirout (the_callcount)) + ;; make a cname + (let ( (nambuf (make_strbuf discr_strbuf)) + (:long syrk (get_int (unsafe_get_field :ndata_rank syv))) + ) + (add2sbuf_strconst nambuf "dsym_") + (add2sbuf_longdec nambuf syrk) + (add2sbuf_strconst nambuf "__") + (add2sbuf_cident nambuf (unsafe_get_field :ndsy_namestr syv)) + (unsafe_put_fields obsym + :oie_cname (strbuf2string discr_string nambuf))) + ;; put the length as obj_num of obsym + (put_int obsym (multiple_length (unsafe_get_field :ninst_slots syv))) + (debug_msg "compilobj_datasymbol gcx" gcx (the_callcount)) + (debug_msg "compilobj_datasymbol obsym beforfill" obsym (the_callcount)) + (compil_data_and_slots_fill syv obsym odiscr inirout gcx) + (debug_msg "compilobj_datasymbol obsym final" obsym (the_callcount)) + obsym + ))) +(install_method class_nrep_datasymbol compile_obj compilobj_datasymbol) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;; compilobj of datainstance +(defun compilobj_datainstance (dai gcx) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj_datainstance gcx" gcx (the_callcount)) + (debug_msg "compilobj_datainstance dai" dai (the_callcount)) + (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) + (chobj (mapobject_get compicache dai)) + (inirout (unsafe_get_field :gncx_objrout gcx)) + ) + ;; datainstance compiled only in initial routines + (assert_msg "check inirout" (is_a inirout class_initialroutineobj)) + (if chobj + (progn + (debug_msg "compilobj_datainstance found chobj" chobj) + (return chobj))) + (let ( (loc (unsafe_get_field :nrep_loc dai)) + (nam (unsafe_get_field :ndata_name dai)) + ;; nam is a symbol, not a string + (disx (unsafe_get_field :ndata_discrx dai)) + (drank (unsafe_get_field :ndata_rank dai)) + (dhash (unsafe_get_field :ninst_hash dai)) + (dslots (unsafe_get_field :ninst_slots dai)) + (ininsl (unsafe_get_field :ninit_topl inirout)) + (inifill (unsafe_get_field :oirout_fill inirout)) + ) + ;; if the drank is invalid or nil, the data has never been added + ;; with add_nctx_data (should not happen) + (assert_msg "compilobj_datainstance check drank" (is_integerbox drank)) + (debug_msg "compilobj_datainstance disx" disx (the_callcount)) + (debug_msg "compilobj_datainstance avant gcx" gcx (the_callcount)) + (let ( (cdisx (compile_obj disx gcx)) + ) + (debug_msg "compilobj_datainstance cdisx" cdisx (the_callcount)) + (let ( + ;; make a cname + (oini (make_instance class_objinitobject + :obv_type ctype_value + :oie_data dai + :oie_discr cdisx)) + (nambuf (make_strbuf discr_strbuf)) + (:long drk (get_int drank)) + ) + (mapobject_put compicache dai oini) + (add2sbuf_strconst nambuf "dobj_") + (add2sbuf_longdec nambuf drk) + (if nam (progn + (add2sbuf_strconst nambuf "__") + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))) + (let ( (cnam (strbuf2string discr_string nambuf)) ) + (unsafe_put_fields oini :oie_cname cnam) + (debug_msg "compilobj_datainstance cnam" cnam (the_callcount)) + ) + (put_int oini (multiple_length dslots)) + (debug_msg "compilobj_datainstance apres gcx" gcx (the_callcount)) + (debug_msg "compilobj_datainstance oini" oini (the_callcount)) + (compil_data_and_slots_fill dai oini cdisx inirout gcx) + (debug_msg "compilobj_datainstance final oini" oini (the_callcount)) + oini + ) + ) + ) + ) + ) +(install_method class_nrep_datainstance compile_obj compilobj_datainstance) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;; compile a data tuple +(defun compilobj_datatuple (nti gcx) + (assert_msg "check nti" (is_a nti class_nrep_datatuple)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj_datatuple gcx" gcx (the_callcount)) + (debug_msg "compilobj_datatuple nti" nti (the_callcount)) + (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) + (chobj (mapobject_get compicache nti)) + (inirout (unsafe_get_field :gncx_objrout gcx)) + ) + ;; datatuples compiled only in initial routines + (assert_msg "check inirout" (is_a inirout class_initialroutineobj)) + (if chobj + (progn + (debug_msg "compilobj_datatuple found chobj" chobj) + (return chobj))) + (let ( (ncompi (unsafe_get_field :ntup_comp nti)) + (disx (unsafe_get_field :ndata_discrx nti)) + (drank (unsafe_get_field :ndata_rank nti)) + (odiscr (compile_obj disx gcx)) + (nam (unsafe_get_field :ndata_name nti)) + (nambuf (make_strbuf discr_strbuf)) + (locvar (get_free_objlocptr gcx '_valtup_)) + (:long drk (get_int drank)) + (inibody (unsafe_get_field :obrout_body inirout)) + (comm (unsafe_get_field :named_name '_initup_)) + ) + (add2sbuf_strconst nambuf "dtup_") + (add2sbuf_longdec nambuf drk) + (if nam (progn + (add2sbuf_strconst nambuf "__") + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))) + (let ( (otup (make_instance class_objinitmultiple + :obv_type ctype_value + :oie_discr odiscr + :oie_locvar locvar + :oie_cname (strbuf2string discr_string nambuf) + )) + ) + (mapobject_put compicache nti otup) + (put_int otup (multiple_length ncompi)) + (multiple_iterate + ncompi + (lambda (scomp :long srk) + (if scomp + (let ( (ocomp (compile_obj scomp gcx)) ) + (list_append inibody + (make_instance class_objputuple + :oputu_tupled otup + :oputu_offset (make_integerbox discr_integer srk) + :oputu_value ocomp))) + ) + ncompi + )) + (list_append inibody + (make_instance class_objtouch + :otouch_val otup + :otouch_comment comm)) + (debug_msg "compilobj datatuple otup" otup (the_callcount)) + otup + ) + ) + ) + ) + +(install_method class_nrep_datatuple compile_obj compilobj_datatuple) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;; compile a data string +(defun compilobj_datastring (nds gcx) + (assert_msg "check nds" (is_a nds class_nrep_datastring)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj_datastring gcx" gcx (the_callcount)) + (debug_msg "compilobj_datastring nds" nds (the_callcount)) + (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) + (inirout (unsafe_get_field :gncx_objrout gcx)) + (chobj (mapobject_get compicache nds)) + ) + ;; datastring compiled only in initial routines + (assert_msg "check inirout" (is_a inirout class_initialroutineobj)) + (if chobj + (progn + (debug_msg "compilobj_datastring found chobj" chobj) + (return chobj))) + (let ( + (nambuf (make_strbuf discr_strbuf)) + (ndisx (unsafe_get_field :ndata_discrx nds)) + (odiscr (compile_obj ndisx gcx)) + (odata (unsafe_get_field :nstr_string nds)) + (drank (unsafe_get_field :ndata_rank nds)) + (nam (unsafe_get_field :ndata_name nds)) + (locvar (get_free_objlocptr gcx '_valstr_)) + (:long drk (get_int drank)) + (ostr (make_instance class_objinitstring + :oie_data odata + :oie_discr odiscr + :oie_locvar locvar + )) + ) + (mapobject_put compicache nds ostr) + (add2sbuf_strconst nambuf "dstr_") + (add2sbuf_longdec nambuf drk) + (add2sbuf_strconst nambuf "__") + (add2sbuf_cidentprefix nambuf odata 16) + (put_int ostr (string_length odata)) + (if nam + (progn + (add2sbuf_strconst nambuf "__") + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))) + (unsafe_put_fields ostr :oie_cname (strbuf2string discr_string nambuf)) + (debug_msg "compilobj_datastring ostr" ostr (the_callcount)) + ostr + ) + )) +(install_method class_nrep_datastring compile_obj compilobj_datastring) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;; compile a data closure +(defun compilobj_dataclosure (ncl gcx) + (assert_msg "check ncl" (is_a ncl class_nrep_dataclosure)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj_dataclosure gcx" gcx (the_callcount)) + (debug_msg "compilobj_dataclosure ncl" ncl (the_callcount)) + (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) + (inirout (unsafe_get_field :gncx_objrout gcx)) + (inibody (unsafe_get_field :obrout_body inirout)) + (chobj (mapobject_get compicache ncl)) + ) + (assert_msg "check inirout" (is_a inirout class_initialroutineobj)) + (if chobj + (progn + (debug_msg "compilobj_dataclosure found chobj" chobj) + (return chobj))) + (let ( + (nam (unsafe_get_field :ndata_name ncl)) + (discx (unsafe_get_field :ndata_discrx ncl)) + (nrank (unsafe_get_field :ndata_rank ncl)) + (nloc (unsafe_get_field :nrep_loc ncl)) + (npro (unsafe_get_field :ndclo_proc ncl)) + (nclov (unsafe_get_field :ndclo_closv ncl)) + (:long nbclos (multiple_length nclov)) + (nambuf (make_strbuf discr_strbuf)) + (odiscr (compile_obj discx gcx)) + (locvar (get_free_objlocptr gcx '_valclo_)) + (comm (unsafe_get_field :named_name '_dataclosure_)) + ) + (assert_msg "check npro" (is_a npro class_nrep_routproc)) + (add2sbuf_strconst nambuf "dclo_") + (add2sbuf_longdec nambuf (get_int nrank)) + (if nam (progn + (add2sbuf_strconst nambuf "__") + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))) + ; (debug_msg "compilobj_dataclosure encore ncl" ncl (the_callcount)) + (let ( + (ndatarou (unsafe_get_field :nrpro_datarout npro)) + (oiclo + (make_instance class_objinitclosure + :obv_type ctype_value + :oie_discr odiscr + :oie_data ncl + :oie_locvar locvar + :oie_cname (strbuf2string discr_string nambuf) + )) + ) + (put_int oiclo nbclos) + (mapobject_put compicache ncl oiclo) + (assert_msg "check ndatarou" (is_a ndatarou class_nrep_dataroutine)) + (let ( + ;; npro should already have been compiled, so should be in the compiler cache + (ocrout (mapobject_get compicache npro)) + (ocputrout (make_instance class_objputclosurout + :obi_loc nloc + :opclor_clos oiclo + :opclor_rout (mapobject_get compicache ndatarou))) + (bxoff (make_integerbox discr_integer 0)) + ) + (assert_msg "check ocrout" (is_a ocrout class_procroutineobj)) + (list_append inibody ocputrout) + (debug_msg "compilobj_dataclosure nclov" nclov (the_callcount)) + (multiple_iterate + nclov + (lambda (clov :long ix) + (let ( (cloval (compile_obj clov gcx)) + (ocputclos (make_instance class_objputclosedv + :obi_loc nloc + :opclov_clos oiclo + :opclov_off (make_integerbox discr_integer (get_int bxoff)) + :opclov_cval cloval)) + ) + (list_append inibody ocputclos) + ) + (put_int bxoff (+i (get_int bxoff) 1)) + nclov + ) + ) + (list_append inibody (make_instance class_objtouch + :obi_loc nloc + :otouch_comment comm + :otouch_val oiclo)) + oiclo + )) + )) + ) +(install_method class_nrep_dataclosure compile_obj compilobj_dataclosure) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;; compile a data routine +(defun compilobj_dataroutine (ndrou gcx) + (assert_msg "check ndrou" (is_a ndrou class_nrep_dataroutine)) + (assert_msg "check gcx" (is_a gcx class_genercontext)) + (debug_msg "compilobj_dataroutine+ gcx" gcx (the_callcount)) + (debug_msg "compilobj_dataroutine+ ndrou" ndrou (the_callcount)) + (shortbacktrace_dbg "compilobj_dataroutine+" 12) + (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) + (inirout (unsafe_get_field :gncx_objrout gcx)) + (chobj (mapobject_get compicache ndrou)) + ) + ;; dataroutine compiled only in initial routines + (assert_msg "check inirout" (is_a inirout class_initialroutineobj)) + (if chobj + (progn + (debug_msg "compilobj_dataroutine+ found chobj" chobj) + (return chobj))) + (let ( (nam (unsafe_get_field :ndata_name ndrou)) + (disx (unsafe_get_field :ndata_discrx ndrou)) + (nloc (unsafe_get_field :nrep_loc ndrou)) + (drank (unsafe_get_field :ndata_rank ndrou)) + (nam (unsafe_get_field :ndata_name ndrou)) + (npro (unsafe_get_field :ndrou_proc ndrou)) + (inibody (unsafe_get_field :obrout_body inirout)) + (locvar (get_free_objlocptr gcx '_valrout_)) + ) + (assert_msg "check compicache" (is_mapobject compicache)) + (let ( + (nambuf (make_strbuf discr_strbuf)) + (:long drk (get_int drank)) + (odiscr (compile_obj disx gcx)) + ) + (add2sbuf_strconst nambuf "drout_") + (add2sbuf_longdec nambuf drk) + (if nam (progn + (add2sbuf_strconst nambuf "__") + (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))) + (debug_msg "compilobj_dataroutine encore ndrou" ndrou (the_callcount)) + (let ( + (oirout + (make_instance class_objinitroutine + :obv_type ctype_value + :oie_discr odiscr + :oie_data ndrou + :oie_locvar locvar + :oie_cname (strbuf2string discr_string nambuf) + :oir_procroutine (mapobject_get compicache npro) + )) + ) + (mapobject_put compicache ndrou oirout) + (debug_msg "compilobj_dataroutine+ npro" npro (the_callcount)) + (if (is_a npro class_nrep_routproc) + (let ( (pconstl (unsafe_get_field :nrpro_const npro)) + (:long nbconst (list_length pconstl)) + (bxoff (make_integerbox discr_integer 0)) + (comm (unsafe_get_field :named_name '_iroutval_)) + ) + (debug_msg "compilobj_dataroutine pconstl" pconstl (the_callcount)) + (put_int oirout nbconst) + (list_iterate + pconstl + (lambda (constx) + (let ( (oconstx (compile_obj constx gcx)) + (:long off (get_int bxoff)) + ) + (if oconstx + (let ( (iput (make_instance class_objputroutconst + :obi_loc nloc + :oprconst_rout oirout + :oprconst_off (make_integerbox discr_integer off) + :oprconst_cval oconstx)) ) + (list_append inibody iput) + (put_int bxoff (+i off 1)))) + ) + pconstl + ) + ) + (if (>i (get_int bxoff) 0) + (list_append inibody (make_instance class_objtouch + :obi_loc nloc + :otouch_val oirout + :otouch_comment comm + ))) + ) + ) + (debug_msg "compilobj_dataroutine here npro" npro (the_callcount)) + (debug_msg "compilobj_dataroutine here fresh oirout" oirout (the_callcount)) + oirout) + )))) +(install_method class_nrep_dataroutine compile_obj compilobj_dataroutine) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;; initial commands +(definstance initial_command_dispatcher class_command_dispatcher + :predef INITIAL_COMMAND_DISPATCHER + :named_name (stringconst2val discr_namestring "INITIAL_COMMAND_DISPATCHER") + :cmd_fundict (make_mapstring discr_mapstrings 40) +) + +(defun install_initial_command (nam fun) + (if (is_closure fun) + (if (is_string nam) + (mapstring_putstr (unsafe_get_field :cmd_fundict initial_command_dispatcher) + nam fun)))) +;;;; +(defun readseq_command (dispatcher arg) + (message_dbg "starting readseq") + (debug_msg "start readseq_command" arg (the_callcount)) + (let ( (rlist (read_file arg)) ) + (message_dbg "ending readseq") + (debug_msg "done readseq_command" rlist (the_callcount)) +)) + +(install_initial_command (stringconst2val discr_string "readseq") readseq_command) + +;;;; + +(defun expandseq_command (dispatcher arg) + (message_dbg "starting expandseq") + (debug_msg "start expandseq_command" arg (the_callcount)) + (debug_msg "start expandseq_command initial_environment" initial_environment (the_callcount)) + (debug_msg "start expandseq_command class_root" class_root (the_callcount)) + (debug_msg "start expandseq_command class_class" class_class (the_callcount)) + (debug_msg "start expandseq_command class_field" class_field (the_callcount)) + (let ( (rlist (read_file arg)) + (inienv initial_environment) ) + (debug_msg "after read expandseq_command rlist" rlist (the_callcount)) + (debug_msg "after read expandseq_command inienv" inienv (the_callcount)) + (let ( (xlist (macroexpand_toplevel_list rlist inienv)) ) + (debug_msg "after macroexpansion expandseq_command seq" xlist (the_callcount)) + (debug_msg "after macroexpansion expandseq_command inienv" inienv (the_callcount)) + ))) + +(install_initial_command (stringconst2val discr_string "expandseq") expandseq_command) +;;;; + +(defun normexpseq_command (dispatcher arg) + (message_dbg "starting normexpseq_command") + (debug_msg "start normexpseq_command" arg (the_callcount)) + (let ( (rlist (read_file arg)) ) + (debug_msg "after read normexpseq_command rlist" rlist (the_callcount)) + (debug_msg "after read normexpseq_command initial_environment" initial_environment (the_callcount)) + (let ( (xlist (macroexpand_toplevel_list rlist initial_environment)) ) + (debug_msg "after macroexpand normexpseq_command xlist" xlist (the_callcount)) + (debug_msg "after macroexpand normexpseq_command initial_environment" initial_environment (the_callcount)) + (let ( (ncx (create_normcontext)) ) + (debug_msg "before normalization normexpseq_command ncx" ncx (the_callcount)) + (list_iterate + xlist + (lambda (sexp :long ix) + (debug_msg "normexpseq_command sexp" sexp (the_callcount)) + (let ( + (psloc (if (is_a sexp class_located) (unsafe_get_field :loca_location sexp))) + (nexp + (normal_exp sexp initial_environment ncx psloc)) ) + (debug_msg "normexpseq_command nexp" nexp (the_callcount)) + ))) + (debug_msg "after normalization normexpseq_command ncx" ncx (the_callcount)) + ))) + ) + +(install_initial_command (stringconst2val discr_string "normexpseq") normexpseq_command) + +;;;;; +(defun compileseq_command (dispatcher arg) + (message_dbg "starting compileseq_command") + (debug_msg "start compileseq_command" arg (the_callcount)) + (let ( (rlist (read_file arg)) + (basnam (make_string_nakedbasename discr_string arg)) + ) + (debug_msg "after read compileseq_command rlist" rlist (the_callcount)) + (debug_msg "after read compileseq_command initial_environment" initial_environment (the_callcount)) + (compile_list_sexpr rlist initial_environment basnam) + )) + +(install_initial_command (stringconst2val discr_string "compileseq") compileseq_command) +;;; eof warm-basilys.bysl \ No newline at end of file diff --git a/gcc/run-basilys.h b/gcc/run-basilys.h index 80c728f93f1..ab65e65725c 100644 --- a/gcc/run-basilys.h +++ b/gcc/run-basilys.h @@ -23,27 +23,26 @@ the Free Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. */ +/* usual GCC middle-end includes, copied from ipa-cp.c */ #include "config.h" #include "system.h" #include "coretypes.h" -#include "obstack.h" -#include "tm.h" +#include "real.h" #include "tree.h" +#include "target.h" +#include "cgraph.h" +#include "ipa-prop.h" +#include "tree-flow.h" #include "tree-pass.h" -#include "tree-dump.h" -#include "basic-block.h" +#include "flags.h" #include "timevar.h" -#include "errors.h" -#include "ggc.h" -#include "cgraph.h" #include "diagnostic.h" -#include "flags.h" -#include "toplev.h" -#include "options.h" -#include "params.h" -#include "real.h" -#include "prefix.h" +#include "tree-dump.h" +#include "tree-inline.h" + + +/* basilys or MELT specific includes */ #include "compiler-probe.h" -- cgit v1.2.1