;; file testrun1.bysl -*- Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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 runnable test; it shares code with warmelt*.bysl ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; root class (defclass class_root :predef CLASS_ROOT) ;; class of everything with a property table (defclass class_proped :predef CLASS_PROPED :super class_root :fields (prop_table)) ;; arbitrary container as class (defclass class_container :super class_root :fields (container_value)) ;; class of named objects (defclass class_named :predef CLASS_NAMED :super class_proped :fields (named_name)) ;; class of discriminants (defclass class_discr :predef CLASS_DISCR :super class_named :fields (disc_methodict disc_sender disc_super)) ;; 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 :predef CLASS_FIELD ;; the fields' objnum is its offset :super class_named :fields (fld_ownclass fld_typinfo)) ;; class of primitive (defclass class_primitive :predef CLASS_PRIMITIVE :super class_named :fields (prim_formals prim_type prim_expansion)) ;; class of symbols (defclass class_symbol :predef CLASS_SYMBOL :super class_named :fields (symb_data)) ;; 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 system data (defclass class_system_data :predef CLASS_SYSTEM_DATA :super class_named :fields (sysdata_cmd_fundict ;stringmap for closures for command dispatching sysdata_fresh_env ;closure to make a fresh environment sysdata_value_exporter ;closure to export a value sysdata_macro_exporter ;closure to export a macro sysdata___spare1 sysdata___spare2 sysdata___spare3 sysdata___spare4 )) ;; 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) ;;;; 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 )) ;; class of message selectors (defclass class_selector :super class_named :fields (sel_signature sel_data) :predef CLASS_SELECTOR) ;; 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 if an object is NOT a (sub) instance of a class (defprimitive is_not_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)") (defprimitive is_not_object (obj) :long " (basilys_magic_discr(" obj ") != OBMAG_OBJECT)") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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)") ;; runtime assertion with message (defprimitive assert_msg (:cstring msg :long cond) :void "basilys_assertmsg(" msg ", ( " cond "))") ;;; 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)") (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 ")))") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; STRBUF primitives ;; primitive to make a strbuf (defprimitive make_strbuf (discr) :value "basilysgc_new_strbuf((basilysobject_ptr_t)(" 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((void*)(" dis "), basilys_string_str((" str "))))") (defprimitive make_stringconst (dis :cstring cstr) :value "(basilysgc_new_stringdup((void*)(" 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((void*)(" dis "), basilys_strbuf_str((" sbuf "))))") ;;; compute the naked basename (defprimitive make_string_nakedbasename (dis str) :value "(basilysgc_new_string_nakedbasename((basilysobject_ptr_t)(" 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((basilysobject_ptr_t)(" discr "), (" ln ")))") (defprimitive make_tuple1 (discr v1) :value "(basilysgc_new_mult1((basilysobject_ptr_t)(" discr "),(" v1 ")))") (defprimitive make_tuple2 (discr v1 v2) :value "(basilysgc_new_mult2((basilysobject_ptr_t)(" discr "),(" v1 "), (" v2 ")))") (defprimitive make_tuple3 (discr v1 v2 v3) :value "(basilysgc_new_mult3((basilysobject_ptr_t)(" discr "),(" v1 "), (" v2 "), (" v3 ")))") (defprimitive make_tuple4 (discr v1 v2 v3 v4) :value "(basilysgc_new_mult4((basilysobject_ptr_t)(" discr "),(" v1 "), (" v2 "), (" v3 "), (" v4 ")))") (defprimitive make_tuple5 (discr v1 v2 v3 v4 v5) :value "(basilysgc_new_mult5((basilysobject_ptr_t)(" discr "),(" v1 "), (" v2 "), (" v3 "), (" v4 "), (" v5 ")))") ;; primitive to get the nth in a multiple (defprimitive multiple_nth (mul :long n) :value "(basilys_multiple_nth((void*)(" mul "), (" n ")))") ;; primitive to get the length of a multiple (defprimitive multiple_length (v) :long "(basilys_multiple_length((void*)(" v ")))") ;; be careful to avoid circularities (defprimitive multiple_put_nth (mul :long n :value v) :void " basilysgc_multiple_put_nth((void*)(" mul "), (" n "), (void*)(" 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((void*)(" map ")))") ;; primitive to get the attribute count of a mapobject (defprimitive mapobject_count (map) :long "(basilys_count_mapobjects((void*)(" map ")))") ;; primitive to get the nth attribute of a mapobject (defprimitive mapobject_nth_attr (map :long n) :value "(basilys_nthattr_mapobjects((void*)(" map "), (int)(" n ")))") ;; primitive to get the nth value of a mapobject (defprimitive mapobject_nth_val (map :long n) :value "(basilys_nthval_mapobjects((void*)(" map "), (int)(" n ")))") ;; primitive to get the value of an attribute in a mapobject (defprimitive mapobject_get (map attr) :value "(basilys_get_mapobjects((void*)(" 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((void*)(" map "), (" cstr ")))") ;; primitive for making a new map of strings (defprimitive make_mapstring (discr :long len) :value " (basilysgc_new_mapstrings( (basilysobject_ptr_t) (" 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((void*)(" 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((void*)(" 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((void*)(" ib ")) == OBMAG_INT)") ;; to get the boxed integer use get_int ;; make (defprimitive make_integerbox (discr :long n) :value "(basilysgc_new_int((void*)(" 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((void*)(" discr "), (void*)(" 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((void*)(" 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 ")))") ;;; debugging primitives (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 ")))") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; 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) (unsafe_put_fields discr_namestring :named_name (stringconst2val discr_namestring "DISCR_NAMESTRING")) ;;; the discriminant for verbatim strings (used for defprimitive) (definstance discr_verbatimstring class_discr :predef DISCR_VERBATIMSTRING :obj_num OBMAG_STRING :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 initest_freshenv_maker (parenv) (if (or (null parenv) (is_a parenv class_environment)) (make_instance class_environment :env_bind (make_mapobject discr_mapobjects 6) :env_prev parenv))) (defun initest_value_exporter (sym val env) (assert_msg "check sym" (is_a sym class_symbol)) (assert_msg "check env" (is_a env class_environment)) (let ( (valbind (make_instance class_value_binding :binder sym :vbind_value val )) ) (put_env env valbind))) (defun initest_macro_exporter (sym val env) (assert_msg "check sym" (is_a sym class_symbol)) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check val is closure" (is_closure val)) (let ( (macbind (make_instance class_macro_binding :binder sym :mbind_expanser val)) ) (put_env env macbind) )) ;;;;;;;;;;;;;;;;;;;; initial commands (definstance initial_system_data class_system_data :predef INITIAL_COMMAND_DISPATCHER :named_name (stringconst2val discr_namestring "INITIAL_SYSTEM_DATA") :sysdata_cmd_fundict (make_mapstring discr_mapstrings 40) :sysdata_fresh_env initest_freshenv_maker :sysdata_value_exporter initest_value_exporter :sysdata_macro_exporter initest_macro_exporter ) (defun install_initial_command (nam fun) (if (is_closure fun) (if (is_string nam) (mapstring_putstr (unsafe_get_field :sysdata_cmd_fundict initial_system_data) nam fun)))) ;;; 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 35)) ) (unsafe_put_fields cla :disc_methodict newmapdict) (mapobject_put newmapdict sel fun) ))))))) ;;; output on stderr (defprimitive outnum_err (:cstring pref :long l :cstring suf) :void "basilys_putnum(stderr,(" pref "), (" l "), (" suf "))") (defprimitive outcstring_err (:cstring s) :void "basilys_puts(stderr,(" s "))") (defprimitive outstrbuf_err (sbuf) :void "basilys_putstrbuf(stderr,(" sbuf "))") (defprimitive outnewline_err () :void "basilys_newlineflush(stderr)") (defprimitive outstr_err (str) :void "basilys_putstr(stderr,(" str "))") ;;; full iterator on tuple - ;;; the function is called with the component and its index (defun multiple_every (tup f) (if (is_multiple tup) (if (is_closure f) (let ( (:long ln (multiple_length tup)) (:long ix 0) ) (forever tuploop (if (>=i ix ln) (exit tuploop)) (f (multiple_nth tup ix) ix) (setq ix (+i ix 1))))))) ;;; full iterator on a list (defun list_every (lis f) (if (is_list lis) (if (is_closure f) (let ( (curpair (list_first lis)) ) (forever lisloop (if (is_pair curpair) (let ( (curhead (pair_head curpair)) (curtail (pair_tail curpair)) ) (f curhead) (setq curpair curtail)) (return (the_null)))))))) ;; find a binding inside an environment (defun find_env (env binder) (message_dbg "find_env start") (if (is_not_a env class_environment) (return ())) (if (is_not_object binder) (return)) (message_dbg "find_env before findloop") (forever findloop (message_dbg "find_env start findloop") (if (is_not_a env class_environment) (exit findloop)) (message_dbg "find_env before let bindmap") (let ( (bindmap (unsafe_get_field :env_bind env)) ) (message_dbg "find_env inside let bindmap") (let ( (bnd (mapobject_get bindmap binder)) ) (message_dbg "find_env inside let bnd") (if bnd (exit findloop bnd)) )) (setq env (unsafe_get_field :env_prev env)) (message_dbg "find_env end findloop") ) ) ;; put a binding at top of an environment (defun put_env (env binding) (assert_msg "check binding is obj" (is_object binding)) (assert_msg "check env is obj" (is_object env)) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check binding" (is_a binding class_any_binding)) (let ( (bindmap (unsafe_get_field :env_bind env)) (binder (unsafe_get_field :binder binding)) ) (assert_msg "check bindmap" (is_mapobject bindmap)) (assert_msg "check binder" (is_object binder)) (mapobject_put bindmap binder binding) )) ; find a binding inside an environment and also returns the reversed list of enclosing procedures (defun find_enclosing_env (env binder) (if (is_not_a env class_environment) (return)) (if (is_not_object binder) (return)) (let ( (proclist (make_list discr_list)) ) (forever findloop (if (is_not_a env class_environment) (exit findloop)) (let ( (bindmap (unsafe_get_field :env_bind env)) (eproc (unsafe_get_field :env_proc env)) ) (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)) )))) (defun outv (v :cstring m) (if m (outcstring_err m)) (cond ( (null v) (outcstring_err "*nil* ") ) ( (is_integerbox v) (outnum_err "#" (get_int v) " ")) ( (is_string v) (outcstring_err "*str'") (outstr_err v) (outcstring_err "' ") ) ( (is_multiple v) (outnum_err "mult#" (multiple_length v) " ")) ( (is_object v) (let ( (cla (discrim v)) (clanam (unsafe_get_field :named_name cla)) (:long h (obj_hash v)) ) (if (is_a v class_named) (let ( (nam (unsafe_get_field :named_name v)) ) (outstr_err nam) (outcstring_err ":") ) (outcstring_err "|") ) (outstr_err clanam) (outnum_err "/" h " "))) )) (defun outv_ident (v :cstring m) (outv v m) (outnewline_err) v) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun install_ctype (ctyp) (assert_msg "check ctyp" (is_a ctyp class_ctype)) (outv ctyp "install_ctype ctyp=") (outnewline_err) (let ( (ckw (unsafe_get_field :ctype_keyword ctyp)) ) (outv ckw "install_ctype ckw=") (outnewline_err) (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) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun say_command (sysdat arg mod) (outstr_err arg) (outnewline_err) ) (defclass myclass_container :super class_root :fields (contain)) (definstance mycontainer myclass_container :contain (make_stringconst discr_string "inside-my-container") ) (defselector get_self_and_content class_selector) (defun methcontainer_get_self_and_content (recv) (outv recv "methcontainer_get_self_and_content recv") (outnewline_err) (return recv (unsafe_get_field :contain recv))) (install_method myclass_container get_self_and_content methcontainer_get_self_and_content) (defun dotest_progn () (outcstring_err "**progn test**") (outnewline_err) (outcstring_err "first") (outnewline_err) (outcstring_err "second") (outnewline_err) (outcstring_err "third") (outnewline_err) (outcstring_err "fourth") (outnewline_err) (outcstring_err "**ended progn test**") (outnewline_err) ) (defun dotest_multiple () (outcstring_err "**multiple_every test**") (outnewline_err) (multiple_every (make_tuple5 discr_multiple (make_integerbox discr_integer 10) (make_integerbox discr_integer 20) (make_integerbox discr_integer 30) (make_integerbox discr_integer 40) (make_integerbox discr_integer 50)) (lambda (comp :long ix) (outv comp "comp=") (outnum_err " ix#" ix " ") (outnewline_err) )) (outcstring_err "**ended test multiple_every**") (outnewline_err) ) (defun multiappliedfun (x y) (outv x "inside multiappliedfun x=") (outv y "& y=") (outnewline_err) (return y x)) (defun dotest_multiapply () (outcstring_err "**multiapply test**") (outnewline_err) (multicall (u v) (multiappliedfun (make_integerbox discr_integer 12) (make_integerbox discr_integer 34)) (outv u "inside body multicall u=") (outv v " v=") (outnewline_err) u ) (outcstring_err "**ended test multiapply**") (outnewline_err) ) (defun dotest_multisend () (outcstring_err "**multisend test**") (outnewline_err) (multicall (u v) (get_self_and_content mycontainer) (outv u "inside body multisend u=") (outv v " v=") (outnewline_err) ) (outcstring_err "**ended test multisend**") (outnewline_err) ) (defun dotest_forever () (outcstring_err "**forever test**") (outnewline_err) (let ( (:long ix 0) (res (forever testloop (outnum_err "foreverloop ix=" ix ";") (outnewline_err) (if (>i ix 21) (exit testloop (make_integerbox discr_integer ix))) (setq ix (+i ix (+i 1 (/i ix 3)))))) ) (outv res "after forverloop res=") (outnewline_err) (outcstring_err "**ended test forever**") (outnewline_err) )) (defun dotest_or () (outcstring_err "**or tests**") (outnewline_err) (if (or (notnull (outv_ident (make_stringconst discr_string "first-orand") "first-in-or")) (notnull (outv_ident (make_stringconst discr_string "second-orand") "second-in-or")) (notnull (outv_ident (make_integerbox discr_integer 123) "third-in-or")) (notnull (outv_ident (make_integerbox discr_integer 456) "fourth-in-or"))) (progn (outcstring_err "**first or test ok**") (outnewline_err)) (progn (outcstring_err "@@@ first or test FAILED! @@@@") (outnewline_err))) ;;- (cond ( (let ( ( aa (make_integerbox discr_integer 111) ) ;;- ( bb (make_integerbox discr_integer 222) ) ;;- ( cc (make_integerbox discr_integer 333) ) ;;- ( zz () ) ) ;;- (or aa ;;- bb ;;- cc ;;- zz)) ;;- (outcstring_err "@@@ second or test FAILED! @@@") ;;- (outnewline_err)) ;;- (:else ;;- (outcstring_err "**second or test ok**") ;;- (outnewline_err))) ;;- (cond ( (or ;;- (outv_ident ;;- (make_stringconst discr_string "again-first-orand") "again-first-in-or") ;;- (outv_ident ;;- () "again-nil-in-or") ;;- (outv_ident ;;- (make_stringconst discr_string "again-third-orand") "again-third--in-or")) ;;- (outcstring_err "@@@ again or test FAILED! @@@") ;;- (outnewline_err)) ;;- (:else ;;- (outcstring_err "**again or test ok**") ;;- (outnewline_err))) (outcstring_err "**ended or tests**") (outnewline_err) ) (defun outv_listcomp (v) (outv v "listcomp=") (outnewline_err)) (defun dotest_lists () (outcstring_err "**lists test**") (outnewline_err) (let ( (emptyl (make_list discr_list)) (monol (make_list discr_list)) (tripl (make_list discr_list)) ) (list_append monol (make_integerbox discr_integer 1)) (list_append tripl (make_integerbox discr_integer 1000)) (list_append tripl (make_integerbox discr_integer 2000)) (list_append tripl (make_integerbox discr_integer 3000)) (outcstring_err "list_every on nil") (outnewline_err) (list_every () outv_listcomp) (outcstring_err "list_every on emptyl") (outnewline_err) (list_every emptyl outv_listcomp) (outcstring_err "list_every on monol") (outnewline_err) (list_every monol outv_listcomp) (outcstring_err "list_every on tripl") (outnewline_err) (list_every tripl outv_listcomp) (outcstring_err "**ended lists test**") (outnewline_err))) (defun dotest_objects () (outcstring_err "**objects test**") (outnewline_err) (let ( (vbind (make_instance class_value_binding :binder 'boundsym :vbind_value 'symvalue)) ) (outv vbind " objects test vbind=") (outnewline_err) (if (is_a vbind class_any_binding) (outcstring_err "**test objects OK!**") (outcstring_err "@@@ test objects FAILED!!! @@@@")) (outnewline_err) (outcstring_err "**ended objects test**") (outnewline_err) )) (defun dotest_nested () (outcstring_err "**nested test**") (let ( (nv (make_integerbox discr_integer 123)) ) (let ( (id (lambda (x) (progn () x))) (id2 (id id)) (id3 (id2 id2)) (nnv (id3 nv)) ) (if (== nv nnv) (outcstring_err "**nested test ok***") (outcstring_err "@@@ nested test failed@@")) (outnewline_err)))) (defun test_command (sysdat arg mod) (outcstring_err "**start of tests in testrun1**") (outnewline_err) (dotest_progn) (outnewline_err) (dotest_or) (outnewline_err) (dotest_forever) (outnewline_err) (dotest_multiple) (outnewline_err) (dotest_multiapply) (outnewline_err) (dotest_multisend) (outnewline_err) (dotest_lists) (outnewline_err) (dotest_objects) (outnewline_err) (dotest_nested) (outnewline_err) (outcstring_err "**end tests in testrun1**") (outnewline_err) ) (install_initial_command (stringconst2val discr_string "say") say_command) (install_initial_command (stringconst2val discr_string "test") test_command) (defun macrone_expander (sexp env mexpander) (make_integerbox discr_integer 1)) (export_value test_command) (export_class class_selector) (export_macro macrone macrone_expander) ;; eof