path: root/gcc/melt/testrun1.bysl

;; file testrun1.bysl  -*- Lisp -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;    Copyright 2008 Free Software Foundation, Inc.
;;    Contributed by Basile Starynkevitch <basile@starynkevitch.net>

;;    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
;;    <http://www.gnu.org/licenses/>.

;;;;;;
;;    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 "))")
(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