;; File warmelt-genobj.melt -*- Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (comment "*** Copyright 2008 - 2013 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 . ***") ;; the copyright notice above apply both to warmelt-genobj.melt and ;; to the generated file warmelt-genobj*.c ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; This file is part of a bootstrapping compiler for the MELT lisp ;; dialect, compiler which should be able to compile itself (into ;; generated C file[s]) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Notice: the threshold governing the splitting and length of ;; generated secondary C files are wired in constants inside the ;; compile2obj_procedure function. ;;;; value like objects;; value here is meant in the sense of the C or C++ ;;;; language so can be any thing. (defclass class_objvalue :super class_generated_c_code :fields ( obv_type ;the ctype )) ;;; pure values expressions are side-effect free (defclass class_objpurevalue :super class_objvalue :fields ()) ;; formal arguments in C routines, notably in hooks (defclass class_objcformal :super class_objpurevalue :fields (oformal_name ;the verbatim name oformal_proc ;the containing proc oformal_bind ;the associated formal binding oformal_locv ;the associated stack location )) ;; object local variable ;;;; disposed local variables can be reused. (defclass class_objlocv :super class_objpurevalue :fields (obl_off ;offset in frame obl_proc ;containing procedure or nil if disposed obl_cname ;symbolic cname string )) ;; closed occurrence (defclass class_objcloccv :super class_objpurevalue :fields (obc_off ;offset in closure obc_proc ;containing procedure obc_name ;symbolic name )) ;; constant [closed] occurrence (defclass class_objconstv :super class_objcloccv :fields ( )) ;; hook closed occurrence (defclass class_objclohookv :super class_objcloccv :fields ( )) ;; fetch a module variable (defclass class_objfetchmodvar :super class_objpurevalue :fields (obfetchmodvar_bind ;; the normal module variable binding )) ;; predefined object (defclass class_objpredef :super class_objpurevalue :fields (obpredef )) ;; nil (defclass class_objnil :super class_objpurevalue :fields ()) ;; expanded pure C value, side-effect-free so could be non-emitted (defclass class_objexpandpureval :super class_objpurevalue :fields (oxpurval_loc ;optional source location oxpurval_comm ;optional comment oxpurval_cont ;expanded content chunk )) ;; initial element (defclass class_objinitelem :super class_objpurevalue :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 )) ;;; initial object - see MELT_OBJECT_STRUCT in melt-runtime.h (defclass class_objinitobject :super class_objinitelem :fields ( oio_predef ;the predef name or number to contain this object oio_class ;the class of the object )) ;;; some initial objects, such as existing symbols, should not be ;;; recreated if they already exist. Use this class for them. (defclass class_objinituniqueobject :super class_objinitobject :fields ( )) ;;; initial multiple - see MELT_MULTIPLE_STRUCT in melt-runtime.h (defclass class_objinitmultiple :super class_objinitelem :fields ( ;; we may need to tuple of compiled values for accessing ;; the nth at compilation time in compilobj_nrep_multacc oim_tupval ;tuple of compiled values )) ;;; initial closure - see MELT_CLOSURE_STRUCT in melt-runtime.h (defclass class_objinitclosure :super class_objinitelem :fields (oiclo_rout ;the compiled routine of the ;closure, useful for lambda-s ;in letrec-s )) ;;; initial routine - see MELT_ROUTINE_STRUCT in melt-runtime.h (defclass class_objinitroutine :super class_objinitelem :fields ( oir_procroutine ;the associated procroutine )) ;;; initial hook - see MELT_HOOK_STRUCT (defclass class_objinithook :super class_objinitelem :fields (oihk_prochook ;the associated prochook oihk_data ;the data description oihk_cloval ;the tuple of closed values in the hook oihk_predef ;the predefined, if any oihk_modvarbind ;the module variable binding if any )) ;;; initial string - see MELT_STRING_STRUCT in melt-runtime.h (defclass class_objinitstring :super class_objinitelem :fields ( )) ;;; initial pair - see struct meltpair_st in melt-runtime.h (defclass class_objinitpair :super class_objinitelem :fields ()) ;;; initial list - see struct meltlist_st in melt-runtime.h (defclass class_objinitlist :super class_objinitelem :fields ()) ;;; initial boxed int - see struct meltint_st in melt-runtime.h (defclass class_objinitboxinteger :super class_objinitelem :fields ( )) ;; expanded value (defclass class_objexpv :super class_objvalue :fields (obx_cont )) ;; expanded value with location (defclass class_objlocatedexpv :super class_objexpv :fields (obcx_loc ;optional location )) (defclass class_objflag :super class_objpurevalue :fields (obflag_matchflag obflag_name obflag_rank )) ;;;; instructions (defclass class_objinstr :super class_generated_c_code :fields (obi_loc ;src location )) (defclass class_objcommentinstr ;just a comment, useful only for debugging our generator :super class_objinstr :fields (obci_comment )) (defclass class_objchecksignal :super class_objinstr :fields ( )) ;;;; instructions with a list of destinations (computes, calls, sends, etc...) (defclass class_objdestinstr :super class_objinstr :fields (obdi_destlist ;a list of destination lovations )) ;;; compute instruction (defclass class_objcompute :super class_objdestinstr :fields (obcpt_expr ;expression list or object or tuple obcpt_type ;ctype of expression )) (defclass class_objputmodvar :super class_objinstr :fields (obputmodvar_bind obputmodvar_val)) ;; get argument instruction (defclass class_objgetarg :super class_objinstr :fields (obarg_obloc ;objlocation obarg_bind ;formal binding )) ;; put output argument instruction, usful inside hooks (defclass class_objputoutarg :super class_objinstr :fields (oboutarg_formal ;;formal out argument of class_objcformal )) ;; get argument & update rest index in variadic instruction (defclass class_objgetargrest :super class_objgetarg :fields (obarg_rest ;name prefix of rest index, as a string )) ;; 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_objanyblock :super class_objinstr :fields ( oblo_bodyl ;body list oblo_epil ;epilogue list )) (defclass class_objplainblock :super class_objanyblock :fields ( )) ;; multi-allocation block instruction, used for letrec compilation (defclass class_objmultiallocblock :super class_objanyblock :fields ( omalblo_allstruct ;the allocated structure is a ;tuple of class_objinitelem omalblo_name ;unique name )) ;; a block with a comment string appearing in the generated code (defclass class_objcommentedblock :super class_objanyblock :fields ( ocomblo_comment ;the comment string )) ;; a block for compiling matches. We need to redistribute put_objdest ;; inside appropriately (defclass class_objmultiblock :super class_objanyblock :fields (omulblo_subcomp ;the tuple of subcomponents ;into which redistribute ;destination )) ;; a block for compiling new matches with flags (defclass class_objmatchflagblock :super class_objanyblock :fields (omchflgblo_flags ;the tuple of flags )) ;; unique label instr (defclass class_objlabelinstr :super class_objinstr :fields (oblab_prefix ;unique prefix string oblab_rank ;additional rank )) ;; unconditional goto label (defclass class_objgotoinstr :super class_objinstr :fields (obgoto_prefix ;unique prefix string obgoto_rank ;additional rank )) ;; looping block (defclass class_objloop :super class_objanyblock ;the body is looped, not the epilogue :fields (obloop_label ;cloned symbol obloop_resv ;the result of the loop )) ;; exit a loop (defclass class_objexit :super class_objinstr :fields (obexit_label ;cloned symbol for goto destination )) ;; start again a loop (defclass class_objagain :super class_objinstr :fields (obagain_label ;cloned symbol for goto destination )) ;; citeration block (defclass class_objciterblock :super class_objanyblock :fields (obciter_citer obciter_before obciter_after )) ;; conditional instruction (defclass class_objcond :super class_objinstr :fields (obcond_test obcond_then obcond_else )) ;; preprocessor conditional instruction (defclass class_objcppif :super class_objinstr :fields (obifp_cond obifp_then obifp_else )) ;;; keyword & symbol intern instruction (defclass class_objinterncommon :super class_objinstr :fields (obintern_iobj ;the objinitobject for ;the symbol or keyword )) (defclass class_objinternsymbol :super class_objinterncommon :fields ( )) (defclass class_objinternkeyword :super class_objinterncommon :fields ( )) ;;; keyword & symbol getnamed instruction (defclass class_objgetnamedcommon :super class_objinstr :fields (obgnamed_iobj ;the objinitobject for the ;symbol or keyword )) (defclass class_objgetnamedsymbol :super class_objgetnamedcommon :fields ( )) (defclass class_objgetnamedkeyword :super class_objgetnamedcommon :fields ( )) ;;; apply instruction (defclass class_objapply :super class_objdestinstr :fields (obapp_clos ;closure to be applied obapp_args ;argument tuple )) ;;; multiapply instruction (defclass class_objmultiapply :super class_objapply :fields (obmultapp_xres ;extraresult tuple )) ;;; message send instruction (defclass class_objmsend :super class_objdestinstr :fields (obmsnd_sel ;selector object (compiled) obmsnd_recv ;message receiver (compiled) obmsnd_args ;argument tuple (compiled) )) ;;; multisend instruction (defclass class_objmultimsend :super class_objmsend :fields (obmultsnd_xres ;extraresult tuple )) ;; raw object allocation instruction (defclass class_objrawallocobj :super class_objdestinstr :fields ( obrallobj_class ;the class data obrallobj_len ;the boxed integer length obrallobj_classname ;the class name )) ;; instruction for debugtracing of written or created objects, for low ;; level debug purposes using GDB, see melt_dbgtrace_write_object in ;; runtime. (defclass class_objdbgtracewriteobj :super class_objinstr :fields (obdtw_writtenobj ;the changed object obdtw_message ;the message )) ;; new closure allocation (defclass class_objnewclosure :super class_objdestinstr :fields (obnclo_discr ;the discriminant obnclo_rout ;the routine obnclo_len ;the boxed integer length )) ;; 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 inside a pair (defclass class_objputpair :super class_objinstr :fields (oputp_pair ;the pair to update )) (defclass class_objputpairhead :super class_objputpair :fields (oputp_head ;the head to put )) (defclass class_objputpairtail :super class_objputpair :fields (oputp_tail ;the tail to put )) ;; put the first and last inside a list (defclass class_objputlist :super class_objinstr :fields (oputl_list ;the list to update oputl_first ;the first pair oputl_last ;the last pair )) ;; 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_field ;the [optional] field oslot_value ;the new value )) ;; get a slot from an object (defclass class_objgetslot :super class_objdestinstr :fields (ogetsl_obj ;the object to get from ogetsl_field ;the fieldname )) ;; 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 )) ;; likewise, but check that the closed value is notnull (defclass class_objputclosednotnullv :super class_objputclosedv :fields ( )) ;; put a constant value inside a hook (defclass class_objputhookconst :super class_objinstr :fields (ophconst_hook ;the hook data ophconst_off ;the boxed offset ophconst_cval ;the constant value )) ;; unsafely retrieve the hook nth "closed" data (defclass class_objhooknth :super class_objpurevalue :fields (ohknth_hook ;the hook ohknth_off ;the boxed offset )) ;; put a constant data inside a hook (defclass class_objputhookdata :super class_objinstr :fields (ophkdata_hook ;the hook ophkdata_data ;the data )) ;; 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 )) ;; likewise, but check that the constant is notnull (defclass class_objputroutconstnotnull :super class_objputroutconst :fields ( )) ;; 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 (usually C ;pointers like tree-s, ;cstrings, ...) obrout_retval ;the main return value obrout_cntciter ;the boxed counter of citerations obrout_cntletrec ;the boxed counter of letrecs )) ;; procedure routine (defclass class_procroutineobj :super class_routineobj :fields (oprout_getargs ;the get arguments tuple of instructions oprout_loc ;the source location oprout_funam ;function name oprout_restnam ;the name used for variadic arguments, or else null oprout_filenum ;boxed C file number )) ;; any initial or hook routine is a start routine (defclass class_any_start_routineobj :super class_routineobj :fields ( ) ) ;; hook routine (defclass class_hookroutineobj :super class_any_start_routineobj :fields ( ohookrout_datarg ;the argument for the data ohookrout_inargs ohookrout_outargs ohookrout_epilog ;list of objinstr after the ;meltlabend_rout label )) ;; initial routine common super-class (defclass class_initialroutineobj :super class_any_start_routineobj :fields ( oirout_data ;the tuple of initial data oirout_prolog ;the prologue (list of instr) before filling the data. Imports should go here! oirout_fill ;the fill of the data (a list of instr) oirout_modulename ;the module name )) ;; initial routine in modules (defclass class_initial_module_routineobj :super class_initialroutineobj :fields ( )) ;; initial routine in extensions (defclass class_initial_extension_routineobj :super class_initialroutineobj :fields ( )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; export the above classes (export_class ;alphabetical order class_any_start_routineobj class_hookroutineobj class_initial_extension_routineobj class_initial_module_routineobj class_initialroutineobj class_objagain class_objanyblock class_objapply class_objcformal class_objchecksignal class_objciterblock class_objclear class_objcloccv class_objclohookv class_objcommentedblock class_objcommentinstr class_objcompute class_objcond class_objconstv class_objcppif class_objdbgtracewriteobj class_objdestinstr class_objexit class_objexpandpureval class_objexpv class_objfetchmodvar class_objfinalreturn class_objflag class_objgetarg class_objgetargrest class_objgetnamedcommon class_objgetnamedkeyword class_objgetnamedsymbol class_objgetslot class_objgotoinstr class_objhooknth class_objinitboxinteger class_objinitclosure class_objinitelem class_objinithook class_objinitlist class_objinitmultiple class_objinitobject class_objinitpair class_objinitroutine class_objinitstring class_objinituniqueobject class_objinstr class_objinterncommon class_objinternkeyword class_objinternsymbol class_objlabelinstr class_objlocatedexpv class_objlocv class_objloop class_objmatchflagblock class_objmsend class_objmultiallocblock class_objmultiapply class_objmultiblock class_objmultimsend class_objnewclosure class_objnil class_objplainblock class_objpredef class_objpurevalue class_objputclosednotnullv class_objputclosedv class_objputclosurout class_objputhookconst class_objputhookdata class_objputlist class_objputoutarg class_objputpair class_objputpairhead class_objputpairtail class_objputmodvar class_objputroutconst class_objputroutconstnotnull class_objputslot class_objputuple class_objputxtraresult class_objrawallocobj class_objsetpredef class_objtouch class_objvalue class_procroutineobj class_routineobj ) ;end export_class (export_synonym class_objblock class_objplainblock) (export_synonym class_objcheckinterrupt class_objchecksignal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; variadic function to make an objlocatedexpv out of a macrostring (defun make_objlocatedexp (loc cty :rest) (debug "make_objlocatedexp loc=" loc " cty=" cty) (assert_msg "make_objlocatedexp check loc" (or (null loc) (is_a loc discr_mixed_location) (is_a loc discr_mixed_integer)) loc) (assert_msg "make_objlocatedexp check cty" (is_a cty class_ctype) cty) (let ( (arglist (make_list discr_list)) ) (forever argloop (variadic ( () (exit argloop)) ( (:long l) (let ( (bl (make_integerbox discr_constant_integer l)) ) (list_append arglist bl))) ( (:cstring s) (let ( (bs (make_stringconst discr_verbatim_string s)) ) (list_append arglist bs))) ( (:value v) (cond ( (is_list v) (list_append2list arglist v)) ( (is_multiple v) (foreach_in_multiple (v) (curcomp :long ix) (list_append arglist curcomp))) ( (is_closure v) (v arglist)) (:else (list_append arglist v)))) ( :else (debug "make_objlocatedexp varargctype=" (variadic_ctype 0)) (assert_msg "unexpected variable argument for make_objlocatedexp" () (variadic_ctype 0))) )) (debug "make_objlocatedexp arglist=" arglist) (let ( (res (instance class_objlocatedexpv :obv_type cty :obx_cont (list_to_multiple arglist discr_multiple) :obcx_loc loc)) ) (debug "make_objlocatedexp res=" res) (return res) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; variadic function to make an objcompute out of a macrostring (defun make_objcompute (loc ctyp :rest) (debug "make_objcompute loc=" loc) (assert_msg "make_objcompute check loc" (or (null loc) (is_a loc discr_mixed_location)) loc) (assert_msg "make_objcompute check ctyp" (is_a ctyp class_ctype) ctyp) (let ( (arglist (make_list discr_list)) ) (forever argloop (variadic ( () (exit argloop)) ( (:long l) (let ( (bl (make_integerbox discr_constant_integer l)) ) (list_append arglist bl))) ( (:cstring s) (let ( (bs (make_stringconst discr_verbatim_string s)) ) (list_append arglist bs))) ( (:value v) (cond ( (is_list v) (list_append2list arglist v)) ( (is_multiple v) (foreach_in_multiple (v) (curcomp :long ix) (list_append arglist curcomp))) (:else (list_append arglist v)))) ( :else (debug "make_objcompute varargctype=" (variadic_ctype 0)) (assert_msg "unexpected variable argument for make_objcompute" () (variadic_ctype 0))) )) (debug "make_objcompute arglist=" arglist) (let ( (res (instance class_objcompute :obdi_destlist (make_list discr_list) :obcpt_expr (list_to_multiple arglist discr_multiple) :obcpt_type ctyp :obi_loc loc)) ) (debug "make_objcompute res=" res) (return res) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; variadic function to make an objexpandpureval out of a macrostring (defun make_objexpandpureval (loc ctyp comm :rest) (debug "make_objexpandpureval loc=" loc " ctyp=" ctyp " comm=" comm) (assert_msg "make_objexpandpureval check loc" (or (null loc) (is_a loc discr_mixed_location)) loc) (assert_msg "make_objexpandpureval check ctyp" (is_a ctyp class_ctype) ctyp) (assert_msg "make_objexpandpureval check comm" (or (null comm) (is_string comm)) comm) (when (== ctyp ctype_void) (warning_plain loc "bizarre :void ctype for pure expanded cvalue") (shortbacktrace_dbg "make_objexpandpureval void" 15)) (let ( (arglist (make_list discr_list)) ) (forever argloop (variadic ( () (exit argloop)) ( (:long l) (let ( (bl (make_integerbox discr_constant_integer l)) ) (list_append arglist bl))) ( (:cstring s) (let ( (bs (make_stringconst discr_verbatim_string s)) ) (list_append arglist bs))) ( (:value v) (cond ( (is_list v) (list_append2list arglist v)) ( (is_multiple v) (foreach_in_multiple (v) (curcomp :long ix) (list_append arglist curcomp))) (:else (list_append arglist v)))) ( :else (debug "make_objexpandpureval varargctype=" (variadic_ctype 0)) (assert_msg "unexpected variable argument for make_objexpandpureval" ())) )) (debug "make_objexpandpureval arglist=" arglist) (let ( (res (instance class_objexpandpureval :obv_type ctyp :oxpurval_loc loc :oxpurval_comm comm :oxpurval_cont (list_to_multiple arglist discr_multiple))) ) (debug "make_objexpandpureval res=" res) (return res) ))) ;;;; selector to generate the declaration of an initial ;;; receiver some objinielem ;;; argument strbuf (defselector output_c_declinit class_selector :doc #{$OUTPUT_C_DECLINIT is the selector to generate the declaration of some initial element $RECV into the string-buffer $SBUF.}# :formals (recv sbuf) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; selector to put a destination into an objcode ;;; receiver: the objcode ;;; argument: the destination value ;;; result: the (modified) receiving objcode or its replacement (defselector put_objdest class_selector ) ;;; selector to generate the c code for an object ;;; receiver: 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 :doc #{$OUTPUT_C_CODE is the selector to generate C code. $RECV is the receiver, $DECLBUF is the string-buffer for declarations, $IMPLBUF is the string-buffer for implementations, $DEPTH is the raw integer depth.}# :formals (recv declbuf implbuf :long depth) ) ;;;; selector to generate the initial fill of some objinit ;;; receiver some objinitelem ;;; argument a stringbuffer (defselector output_c_initial_fill class_selector :doc #{$OUTPUT_C_INITIAL_FILL is the selector to generate the filling of some initalized object $RECV. $IMPLBUF is the string-buffer for implementations, $PTRSTR is the string value of the pointer to fill, and $DEPTH is the raw integer depth.}# :formals (recv implbuf ptrstr :long depth) ) ;;;; selector to generate the predef fill of some objinit ;;; receiver some objinitelem ;;; argument a stringbuffer (defselector output_c_initial_predef class_selector :formals (recv sbuf prtrstr :long depth) ) (export_values make_objexpandpureval output_c_code output_c_declinit output_c_initial_fill output_c_initial_predef put_objdest ) ;; 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 "compilobj_catchall_nrep recv=" recv " gcx=" gcx) (let ( (discr (discrim recv)) (discrname (unsafe_get_field :named_name discr)) ) (debug "compilobj_catchall_nrep discr=" discr) (errormsg_strv "{Internal Error} COMPILE_OBJ sent to unexpected object of class" discrname) (assert_msg "@@compile_obj should be implemented in nrep-s subclasses" () recv) )) (install_method class_nrep compile_obj compilobj_catchall_nrep) (defun putobjdest_catchall_objcode (recv desto) (debug "putobjdest_catchall_objcode recv=" recv " desto=" desto) (let ( (discr (discrim recv)) (discrname (unsafe_get_field :named_name discr)) ) (error_at () "PUT_OBJDEST sent to unexpected C-generated object $1 of class $2 for destination $3." recv discrname desto) (assert_msg "@@put_objdest should be implemented in generated c code subclasses" () recv discr) )) (install_method class_generated_c_code put_objdest putobjdest_catchall_objcode) (defun putobjdest_catch_objputmodvar (recv desto) (debug "putobjdest_catch_objputmodvar recv=" recv " desto=" desto) (assert_msg "check recv" (is_a recv class_objputmodvar) recv desto) (let ( (loc (get_field :obi_loc recv)) (obind (get_field :obputmodvar_bind recv)) (bindsymb (get_field :binder obind)) ) (error_at loc "assignment of a module variable $1 don't have any result" bindsymb) (assert_msg "@@put_objdest on objputmodvar" () recv desto) (return))) (install_method class_objputmodvar put_objdest putobjdest_catch_objputmodvar) (defun putobjdest_catchall_anydiscr (recv desto) (debug "putobjdest_catchall_anydiscr recv=" recv " desto=" desto) (outcstring_err "* putobjdest unimplemented receiver discriminant ") (let ( (discr (discrim recv)) (discrname (unsafe_get_field :named_name discr)) ) (error_at () "PUT_OBJDEST sent to unexpected reciever $1 of discriminant $2 for destination $3." recv discr desto) (assert_msg "@@ unexpected catchall putobjdest anydiscr" () recv))) (install_method discr_any_receiver put_objdest putobjdest_catchall_anydiscr) (defun getctype_objvalue (recv env) (assert_msg "check recv objvalue" (is_a recv class_objvalue) recv) (unsafe_get_field :obv_type recv)) (install_method class_objvalue get_ctype getctype_objvalue) ;; nil are ctype_value (defun gectyp_objnil (recv env) ctype_value) (install_method class_objnil get_ctype gectyp_objnil) ;; initstring-s are ctype_value (defun gectyp_objinitstring (recv env) (return ctype_value)) (install_method class_objinitstring get_ctype gectyp_objinitstring) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; in the debug output routineobj-s make huge output, so print the detail only when at toplevel (defun dbgout_routineobj (self dbgi :long depth) (if (<=i depth 0) (dbgout_namedobject_method self dbgi 0) (dbgout_namedobject_method self dbgi 30)) ) (install_method class_routineobj dbg_output dbgout_routineobj) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; common put destination of objdestinstr.... (defun putobjdest_objdestinstr (recv desto) (assert_msg "putobjdest_objdestinstr check recv" (is_a recv class_objdestinstr) recv) (debug "putobjdest_objdestinstr recv=" recv " desto=" desto) (let ( (destl (unsafe_get_field :obdi_destlist recv)) ) (if (not (is_list destl)) (progn (setq destl (make_list discr_list)) (unsafe_put_fields recv :obdi_destlist destl))) (let ( (firstd (pair_head (list_first destl))) ) (if (== firstd desto) (return recv) (progn (list_append destl desto) (return recv) ))))) (install_method class_objdestinstr put_objdest putobjdest_objdestinstr) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; notes about code generation ;;; ;;; in addition of the code structure generated by cold-melt 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; for some reason, final returns are sometimes putobjdest-ed - a NOP here (defun putobjdest_objfinalreturn (recv desto) (assert_msg "check recv" (is_a recv class_objfinalreturn) recv) recv ) (install_method class_objfinalreturn put_objdest putobjdest_objfinalreturn) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; produce the verbatim string for of a variadic symbol with a given suffix (defun variadic_idstr (variadsym :cstring suffix) (match variadsym (?(as_null) (return ())) (?(instance class_cloned_symbol :named_name ?nvarnam :csym_urank ?(integerbox_of ?nvarurank)) (assert_msg "check nvarnam" (is_string nvarnam) nvarnam) (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sbuf "variad_") (add2sbuf_cident sbuf nvarnam) (add2sbuf_strconst sbuf "_c") (add2sbuf_longdec sbuf nvarurank) (add2sbuf_strconst sbuf suffix) (strbuf2string discr_verbatim_string sbuf) )) (?(instance class_symbol :named_name ?nvarnam) (assert_msg "check nvarnam" (is_string nvarnam) nvarnam) (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sbuf "variad_") (add2sbuf_cident sbuf nvarnam) (add2sbuf_strconst sbuf suffix) (strbuf2string discr_verbatim_string sbuf) )) (?_ (debug "variadic_idstr bad variadsym=" variadsym) (assert_msg "variadic_idstr bad variadsym" () variadsym) ()))) (defun variadic_index_idstr (variadsym) :doc #{Gives the verbatim string representing the index for variadic $VARIADSYM or else null.}# (variadic_idstr variadsym "_ix")) (defun variadic_length_idstr (variadsym) :doc #{Gives the verbatim string representing the length for variadic $VARIADSYM or else null.}# (variadic_idstr variadsym "_len")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; compile a single hook (defun compile2obj_hook (nhook modctx compicache :long num) (debug "compile2obj_hook nhook=" nhook "\n.. modctx=" modctx "\n.. compicache=" compicache "\n.. num=" num "\n.. class_hookroutineobj=" class_hookroutineobj) (assert_msg "check nhook" (is_a nhook class_nrep_hookproc) nhook) (assert_msg "check compicache" (is_mapobject compicache) compicache) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (let ( (loc (get_field :nrep_loc nhook)) (nbody (get_field :nproc_body nhook)) (nhookname (get_field :nrclop_name nhook)) (hookroutname (let ( (namsbuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst namsbuf "melthook_") (add2sbuf_cident namsbuf nhookname) (strbuf2string discr_verbatim_string namsbuf) )) (ninbinds (get_field :nrclop_argbindtuple nhook)) (noutbinds (get_field :nrhook_outb nhook)) (resctype (get_field :nrhook_ctype nhook)) (ndatahook (get_field :nrhook_datahook nhook)) (nclosvtup (get_field :ndhook_closv ndatahook)) (obodylist (make_list discr_list)) (oepiloglist (make_list discr_list)) (oinargs (make_multiple discr_multiple (multiple_length ninbinds))) (ooutargs (make_multiple discr_multiple (multiple_length noutbinds))) (odatarg (instance class_objcformal :obv_type ctype_value :oformal_name '"melthookdatap" :oformal_proc nhook :oformal_bind () :oformal_locv () )) (hookrout (instance class_hookroutineobj :named_name hookroutname :obrout_proc nhook :obrout_body obodylist :obrout_nbval (make_integerbox discr_integer 0) :obrout_nblong (make_integerbox discr_integer 0) :obrout_others (make_list discr_list) :obrout_cntciter (make_integerbox discr_integer 0) :obrout_cntletrec (make_integerbox discr_integer 0) :ohookrout_datarg odatarg :ohookrout_inargs oinargs :ohookrout_outargs ooutargs :ohookrout_epilog oepiloglist )) (locmap (make_mapobject discr_map_objects (+i 30 (*i 3 (+i (multiple_length ninbinds) (multiple_length noutbinds)))))) (gcx (instance class_c_generation_context :gncx_objrout hookrout :gncx_locmap locmap :gncx_freeptrlist (make_list discr_list) :gncx_freelonglist (make_list discr_list) :gncx_freeothermaps (make_mapobject discr_map_objects 20) :gncx_compicache compicache :gncx_modulcontext modctx :gncx_matchmap (make_mapobject discr_map_objects 40) )) ) (debug "compile2obj_hook " nhookname " empty hookrout=" hookrout "\n nclosvtup=" nclosvtup) (debug "compile2obj_hook " nhookname " resctype=" resctype "\n.. gcx=" gcx) (assert_msg "check resctype" (is_a resctype class_ctype) resctype) (let ( (retloc (get_free_objloctyped gcx '_reshook_ resctype)) (hdataloc (get_free_objloctyped gcx '_hookdata_ ctype_value)) (ogetdata (make_objcompute loc ctype_value ##{/*hookgetdata*/ $ODATARG}#)) ) (put_fields gcx :gncx_retloc retloc) (put_fields odatarg :oformal_locv hdataloc) (put_objdest ogetdata hdataloc) (list_append obodylist ogetdata) ;; handle the input arguments (debug "compile2obj_hook " nhookname " ninbinds=" ninbinds) (foreach_in_multiple (ninbinds) (curinbnd :long inix) (debug "compile2obj_hook " nhookname " curinbnd=" curinbnd "\n .. inix=" inix) (assert_msg "check curinbnd" (is_a curinbnd class_formal_binding) curinbnd) (let ( (syminb (get_field :binder curinbnd)) (ctypinb (get_field :fbind_type curinbnd)) (locinb (get_free_objloctyped gcx syminb ctypinb)) (incname (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2out sbuf "meltinp" inix "_" (symbol_cname syminb)) (strbuf2string discr_verbatim_string sbuf))) (incformal (instance class_objcformal :obv_type ctypinb :oformal_name incname :oformal_proc nhook :oformal_bind curinbnd :oformal_locv locinb)) (ogetfarg (make_objcompute loc ctypinb ##{/*gethookinput*/ $INCFORMAL}#)) ) (put_int incformal inix) (put_objdest ogetfarg locinb) (list_append obodylist ogetfarg) (debug "compile2obj_hook " nhookname " incformal=" incformal "\n.. ogetfarg=" ogetfarg) (multiple_put_nth oinargs inix incformal) (mapobject_put locmap curinbnd locinb) )) (debug "compile2obj_hook " nhookname " oinargs=" oinargs "\n.. locmap=" locmap) ;; ;; handle the output arguments (debug "compile2obj_hook " nhookname " noutbinds=" noutbinds) (foreach_in_multiple (noutbinds) (curoutbnd :long outix) (debug "compile2obj_hook " nhookname " curoutbnd=" curoutbnd "\n .. outix=" outix) (assert_msg "check curoutbnd" (is_a curoutbnd class_formal_binding) curoutbnd) (let ( (symoutb (get_field :binder curoutbnd)) (ctypoutb (get_field :fbind_type curoutbnd)) (locoutb (get_free_objloctyped gcx symoutb ctypoutb)) (outcname (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2out sbuf "meltoutp" outix "_" (symbol_cname symoutb)) (strbuf2string discr_verbatim_string sbuf))) (outcformal (instance class_objcformal :obv_type ctypoutb :oformal_name outcname :oformal_proc nhook :oformal_bind curoutbnd :oformal_locv locoutb)) ) (put_int outcformal outix) (debug "compile2obj_hook " nhookname " outcformal=" outcformal) (multiple_put_nth ooutargs outix outcformal) (mapobject_put locmap curoutbnd locoutb) ) ) ;; (debug "compile2obj_hook " nhookname " here obodylist=" obodylist) (debug "compile2obj_hook " nhookname " ooutargs=" ooutargs "\n.. nbody=" nbody "\n..locmap=" locmap) ;; associate the hook with its routine in the compiler cache (mapobject_put compicache nhook hookrout) (debug "compile2obj_hook " nhookname " updated compicache=" compicache "\n.. for nhook=" nhook) (shortbacktrace_dbg "compile2obj_hook updated compicache" 15) ;; ;; associate each closedvalue with its retrieval in the compicache (debug "compile2obj_hook " nhookname " handling closvtup=" nclosvtup "\n") (foreach_in_multiple (nclosvtup) (nclosv :long clix) (debug "compile2obj_hook " nhookname " clix#" clix " nclosv=" nclosv) (let ( (ofetchcdata (instance class_objhooknth :obv_type ctype_value :ohknth_hook hdataloc :ohknth_off (constant_box clix))) ) (debug "compile2obj_hook " nhookname " ofetchcdata=" ofetchcdata "\n.. for nclosv=" nclosv) (mapobject_put compicache nclosv ofetchcdata) ) ) (debug "compile2obj_hook " nhookname " again updated compicache=" compicache "\n.. obodylist=" obodylist "\n") ) ;; ;; compile the body (debug "compile2obj_hook " nhookname " beforebody obodylist=" obodylist) (debug "compile2obj_hook " nhookname " gcx=" gcx "\n.. nbody=" nbody) (let ( (obody (compile_obj nbody gcx)) ) (debug "compile2obj_hook " nhookname " obody=" obody) (list_append obodylist obody) ;; forget the closed data (foreach_in_multiple (nclosvtup) (closv :long clix) (debug "compile2obj_hook " nhookname " forgetting closv=" closv) (mapobject_remove compicache closv) ) (debug "compile2obj_hook " nhookname " after forgethookdata compicache=" compicache) (debug "compile2obj_hook " nhookname " final obodylist=" obodylist "\n") ;; ;; set the output parameters in the epilog (foreach_in_multiple (ooutargs) (curout :long outix) (debug "compile2obj_hook " nhookname " curout=" curout "\n... outix=" outix) (let ( (outloc (get_field :oformal_locv curout)) (ctypoutb (get_field :obv_type curout)) (ofargout (instance class_objputoutarg :obi_loc loc :oboutarg_formal curout)) ) (debug "compile2obj_hook " nhookname " ofargout=" ofargout) (list_append oepiloglist ofargout) )) ;; (debug "compile2obj_hook " nhookname "oepiloglist=" oepiloglist) (debug "compile2obj_hook " nhookname " return hookrout=" hookrout) (return hookrout)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; compile a single procedure (defun compile2obj_procedure (pro modctx compicache :long num) (debug "compile2obj_procedure pro=" pro "\n.. num=" num "\n..start compicache=" compicache "\n\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n") (assert_msg "check pro" (is_a pro class_nrep_routproc) pro) (assert_msg "check compicache" (is_mapobject compicache) compicache) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (let ( (namsbuf (make_strbuf discr_strbuf)) (routfunam ()) (restnam ()) (mofuncount (get_field :mocx_funcount modctx)) (mofiles (get_field :mocx_filetuple modctx)) (:long funum (+i 1 (get_int mofuncount))) ) (if (is_a pro class_nrep_defunroutproc) (put_int mofuncount funum)) (add2sbuf_strconst namsbuf "meltrout_") (add2sbuf_longdec namsbuf num) (add2sbuf_strconst namsbuf "_") (add2sbuf_cident namsbuf (get_field :mocx_modulename modctx)) (if (is_a pro class_nrep_routproc) (let ( (pronam (get_field :nrclop_name pro)) (nvariadic (unsafe_get_field :nrpro_variadic pro)) ) (cond ( (is_a pronam class_symbol) (setq routfunam (symbol_cname pronam)) (add2out namsbuf "_" routfunam)) ( (is_a pronam class_named) (let ( (nambuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst nambuf "_") (add2sbuf_cident nambuf (unsafe_get_field :named_name pronam)) (setq routfunam (strbuf2string discr_verbatim_string nambuf)) (add2out namsbuf "_nm" routfunam))) ( (is_string pronam) (add2sbuf_cident namsbuf pronam))) (if nvariadic (setq restnam nvariadic)) )) (let ( (nbody (unsafe_get_field :nproc_body pro)) (nloc (unsafe_get_field :nrep_loc pro)) (nargb (if (is_a pro class_nrep_routproc) (get_field :nrclop_argbindtuple pro))) (obodylist (make_list discr_list)) ;; the number 20 below is the ratio of number of functions ;; per secondary generated C file. Change it carefully! the ;; offset 12 helps to make the first file less big, since it ;; already contains the huge initialization functions. (:long filenum (/iraw (+i funum 12) 20)) (:long nbfiles (multiple_length mofiles)) (obrout (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) :obrout_others (make_list discr_list) :obrout_cntciter (make_integerbox discr_integer 0) :obrout_cntletrec (make_integerbox discr_integer 0) :oprout_loc nloc :oprout_funam routfunam :oprout_filenum (make_integerbox discr_constant_integer filenum) :oprout_restnam restnam )) (locmap (make_mapobject discr_map_objects (+i 20 (*i 3 (multiple_length nargb))))) (gcx (let ( (gx (instance class_c_generation_context :gncx_objrout obrout :gncx_locmap locmap :gncx_freeptrlist (make_list discr_list) :gncx_freelonglist (make_list discr_list) :gncx_freeothermaps (make_mapobject discr_map_objects 20) :gncx_compicache compicache :gncx_modulcontext modctx :gncx_matchmap (make_mapobject discr_map_objects 40) )) ) (debug "compile2obj_procedure gcx=" gx "\n.. pro=" pro) gx)) (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) bnd) (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 (if restnam (instance class_objgetargrest :obi_loc nloc :obarg_obloc oloc :obarg_bind bnd :obarg_rest restnam) (instance class_objgetarg :obi_loc nloc :obarg_obloc oloc :obarg_bind bnd))) ) (if (and (<=i ix 0) (!= bctyp ctype_value)) (error_plain nloc "first argument of function should be a value")) (debug "compile2obj_procedure formal bnd=" bnd " oloc=" oloc) (mapobject_put locmap bnd oloc) ogarg )) )) ) ;;; grow the file tuple if needed (if (>=i filenum nbfiles) (let ( (:long newnbfiles (+i nbfiles (+i 2 (/iraw filenum 4)))) (newfiletup (make_multiple discr_multiple newnbfiles)) ) (put_fields modctx :mocx_filetuple newfiletup) (foreach_in_multiple (mofiles) (curfile :long curix) (multiple_put_nth newfiletup curix curfile)) )) ;; associate the procedure with its objroutine in the compiler cache (mapobject_put compicache pro obrout) (put_fields obrout :oprout_getargs gtatup) (debug "compile2obj_procedure updated compicache=" compicache "\n.. pro=" pro "\n.. obrout=" obrout ".. nbody=" nbody) (shortbacktrace_dbg "compile2obj_procedure updated compicache" 15) (assert_msg "check nbody" (is_a nbody class_nrep) nbody) (if (is_a pro class_nrep_routproc) (let ( (pthuls (unsafe_get_field :nrpro_thunklist pro)) ) (debug "compile2obj_procedure pthuls=" pthuls) (foreach_pair_component_in_list (pthuls) (pthupair pthu) (debug "compile2obj_procedure pthu=" pthu) (assert_msg "compile2obj_procedure check pthu" (is_closure pthu) pthu) (pthu gcx) (debug "compile2obj_procedure after pthu=" pthu "\n.. compicache=" compicache) ) )) (let ( (obody (compile_obj nbody gcx)) ) (debug "compile2obj_procedure obody=" obody) (list_append obodylist obody) ) (debug "compile2obj_procedure return obrout=" obrout) (return obrout) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; the initial routine uses the initial system data ... (definstance initialsystemdata_objpredef class_objpredef :obv_type ctype_value :obpredef 'INITIAL_SYSTEM_DATA ) (defun append_comment (ilist comstr iloc) (list_append ilist (instance class_objcommentinstr :obi_loc iloc :obci_comment comstr))) (defun append_commentconst (ilist :cstring comment :value iloc) (list_append ilist (instance class_objcommentinstr :obi_loc iloc :obci_comment (make_stringconst discr_string comment)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile the initial procedure into an object (defun compile2obj_initproc (ipro modctx idata compicache procurmodenvlist) (debug "compile2obj_initproc ipro=" ipro "\n* modctx=" modctx "\n* compicache=" compicache "\n* procurmodenvlist=" procurmodenvlist "\n\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n" ) (shortbacktrace_dbg "compile2obj_initproc" 15) (assert_msg "check ipro" (is_a ipro class_nrep_initproc) ipro) (assert_msg "check idata" (is_list idata) idata) (assert_msg "check modctx" (is_a modctx class_any_module_context) modctx) (assert_msg "check compicache" (is_mapobject compicache) compicache) (let ((locmap (make_mapobject discr_map_objects 50)) (importvalues (get_field :ninit_imports ipro)) (importexprs (get_field :ninit_importexprs ipro)) (oiniprolog (make_list discr_list)) (oinibody (make_list discr_list)) (modinienv (get_field :mocx_initialenv modctx)) (modnam (get_field :mocx_modulename modctx)) (rawmodnam (clone_with_discriminant modnam discr_verbatim_string)) (oinitrout (let ( (oi (instance class_initial_module_routineobj ;; Change the "melt_start_this_module" name with ;; great care, it is known by the MELT runtime, and ;; some functions of warmelt-outobj.melt are ;; hardwiring it, e.g. thru emission of struct ;; frame_melt_start_this_module_st or elsewhere. :named_name '"melt_start_this_module" :obrout_proc ipro :obrout_body oinibody :obrout_nbval (make_integerbox discr_integer 0) :obrout_nblong (make_integerbox discr_integer 0) :obrout_others (make_list discr_list) :obrout_cntciter (make_integerbox discr_integer 0) :obrout_cntletrec (make_integerbox discr_integer 0) :oirout_fill (make_list discr_list) :oirout_prolog oiniprolog :oirout_modulename (get_field :mocx_modulename modctx) )) ) (debug "compile2obj_initproc oinitrout=" oi) oi)) (importmap (make_mapobject discr_map_objects 50)) (gcx (let ( (gx (instance class_initial_generation_context :gncx_objrout oinitrout :gncx_locmap locmap :gncx_freeptrlist (make_list discr_list) :gncx_freelonglist (make_list discr_list) :gncx_freeothermaps (make_mapobject discr_map_objects 20) :gncx_compicache compicache :gncx_modulcontext modctx :gncx_matchmap (make_mapobject discr_map_objects 60) :igncx_procurmodenvlist (list_map procurmodenvlist (lambda (curpro) (debug "compile2obj_initproc procurmodenvlist curpro=" curpro) (let ( (curou (mapobject_get compicache curpro)) ) (debug "compile2obj_initproc procurmodenvlist curou=" curou) (assert_msg "check curou" (is_object curou) curou) curou))) ;; perhaps we should store not a list of procedures, but their matching routines :igncx_importmap importmap )) ) (debug "compile2obj_initproc gcx=" gx) gx)) (retinit (let ( (reti (get_free_objlocptr gcx '_retinit_)) ) (unsafe_put_fields gcx :gncx_retloc reti) (unsafe_put_fields oinitrout :obrout_retval reti) reti)) (boxloc (let ( (boxl (get_free_objlocptr gcx '_contenv_)) ) (put_fields gcx :igncx_contenvloc boxl) boxl)) (ofreshenv (get_free_objlocptr gcx '_freshenv_)) (oprevenv (let ( (preve (get_free_objlocptr gcx '_prevenv_)) ) (put_fields gcx :igncx_prevenvloc preve) preve)) (inidefbinds (get_field :ninit_defbinds ipro)) ) (append_commentconst oinibody "start of oinibody") (debug boxloc "compile2obj_initproc boxloc=" boxloc " inidefbinds=" inidefbinds) ;;; reserve location for defined values (foreach_pair_component_in_list (inidefbinds) (curpair curdefbind) (debug "compile2obj_initproc curdefbind=" curdefbind " of discrim=" (discrim curdefbind)) (let ( (inidefsymb (get_field :binder curdefbind)) (oinisym (get_field :fixbind_data curdefbind)) (oinidefloc (get_free_objlocptr gcx inidefsymb)) ) (debug "compile2obj_initproc oinidefloc=" oinidefloc " oinisym=" oinisym " of discrim:" (discrim oinisym) " curdefbind=" curdefbind) ;;oinisym is often a class_nrep_locsymocc but can be a ;;class_nrep_defined_constant (assert_msg "check oinisym" (is_a oinisym class_nrep_simple) oinisym) (mapobject_put locmap curdefbind oinidefloc) )) ;; create a commentedblock to compute the new environemnt box in boxloc if it is null (let ( ;; cond to test boxloc & call the hook_fresh_environment_reference_maker if it if null (otestcomputboxloc (instance class_objcond :obcond_test boxloc :obcond_then () :obcond_else (make_objcompute () ctype_void ##{ /* compile2obj_initproc emitted initialization of environment reference for $RAWMODNAM */ if ($OPREVENV) { $BOXLOC = melthookproc_HOOK_FRESH_ENVIRONMENT_REFERENCE_MAKER ((melt_ptr_t) $OPREVENV, "$RAWMODNAM") ; } else /* no prevenv */ { #if MELT_HAS_INITIAL_ENVIRONMENT>0 if (!melt_flag_bootstrapping) warning(0, "MELT is not creating a fresh environment reference for $RAWMODNAM without parent env.") ; #endif /* MELT_HAS_INITIAL_ENVIRONMENT>0 */ } }# ))) ;; (limplocv (list_map importvalues (lambda (ival) (debug "compile2obj_initproc imported ival=" ival) (assert_msg "check ival" (is_a ival class_nrep_importedval) ival) (let ( (isym (unsafe_get_field :nimport_symb ival)) (ilocv (get_free_objlocptr gcx isym)) ) (debug "compile2obj_initproc imported ilocv=" ilocv) (mapobject_put importmap isym ilocv) ilocv )))) ) (debug "compile2obj_initproc otestcomputboxloc=" otestcomputboxloc "\n.. importvalues=" importvalues "\n.. limplocv=" limplocv) ;; the prologue starts by getting the previous environment from the ;; modargp_ unique argument (let ( (lisdest (make_list discr_list)) ) (list_append lisdest oprevenv) (append_commentconst oiniprolog "get previous environment") (list_append oiniprolog (instance class_objcompute :obdi_destlist lisdest :obcpt_type ctype_value :obcpt_expr (make_stringconst discr_verbatim_string "/*getprevenv*/ (melt_ptr_t) modargp_")) ) ) (append_commentconst oiniprolog "compute boxloc") ;; we compute the boxloc at first (list_append oiniprolog otestcomputboxloc) ;; the tuple to compile the body (let ( (odatatup (list_to_multiple idata discr_multiple (lambda (curdat) (assert_msg "check curdat" (is_a curdat class_nrep_bound_data) curdat) (let ( (curobd (compile_obj curdat gcx)) ) curobd)))) (toplis (unsafe_get_field :ninit_topl ipro)) ) (unsafe_put_fields oinitrout :oirout_data odatatup) (assert_msg "check toplis" (is_list_or_null toplis) toplis) ;; compile the toplevels (let ( (objtoplis (list_map toplis (lambda (curtop) (let ( (otop (compile_obj curtop gcx)) ) (debug "compile2obj_initproc otop=" otop) otop)))) ) (debug "compile2obj_initproc objtoplis=" objtoplis "\n modinienv=" modinienv) (cond ( (is_object modinienv) ;; generate the getting of symbols & keywords (append_commentconst oiniprolog "get symbols & keywords for initial procedure") (foreach_in_multiple (odatatup) (curpdat :long curk) (if (is_a curpdat class_objinitobject) (let ( (odat (unsafe_get_field :oie_data curpdat)) ) (debug "compile2obj_initproc getting curpdat=" curpdat) (cond ;; first check for keywords, since they are also symbols (so order is important) ( (is_a odat class_nrep_datakeyword) (let ( (ogkw (instance class_objgetnamedkeyword :obgnamed_iobj curpdat)) ) (list_append oiniprolog ogkw) (debug "compile2obj_initproc added keyword getting ogkw=" ogkw) )) ( (is_a odat class_nrep_datasymbol) (let ( (ogsy (instance class_objgetnamedsymbol :obgnamed_iobj curpdat)) ) (list_append oiniprolog ogsy) (debug "compile2obj_initproc added symbol getting ogsy=" ogsy) )) )))) ;; ;; get the value importer if needed (when (>i (list_length importvalues) 0) ;; (debug "compile2obj_initproc importexprs=" importexprs) (append_commentconst oiniprolog "before getting imported values thru hook") (let ( (:long nbimportexprs (multiple_length importexprs)) (oimportup (make_multiple discr_multiple nbimportexprs)) ) (foreach_in_multiple (importexprs) (curimpexp :long impix) (debug "compile2obj_initproc curimpexp=" curimpexp " impix#" impix) (let ( (ocurimp (compile_obj curimpexp gcx)) ) (debug "compile2obj_initproc ocurimp=" ocurimp) (list_append oiniprolog ocurimp) ))) (append_commentconst oiniprolog "after getting imported values") ) ) ;end if modinienv ( (null modinienv) ;; initial module, don't need to generate importer or ;; symbol or keyword getter, but need to emit the check ;; that the parent environment is null (let ( (modulverbstr (clone_with_discriminant (get_field :mocx_modulename modctx) discr_verbatim_string)) (ochecknopar (make_objcompute () ctype_void ##{ /* initialization of initial module $MODULVERBSTR */ melt_assertmsg("initial module $MODULVERBSTR should have no parent", modargp_ == NULL) ; }# )) ) (debug "compile2obj_initproc ochecknopar=" ochecknopar) (list_append oiniprolog ochecknopar) )) (:else (debug "compile2obj_initproc unexpected modinienv=" modinienv) (assert_msg "compile2obj_initproc impossible modinienv" () modinienv) ) ) ;; end cond ;; ;; append the compiled toplevel (append_commentconst oinibody "before toplevel body") (list_every objtoplis (lambda (curobjt) (list_append oinibody curobjt))) (append_commentconst oinibody "after toplevel body") ;; we compute the boxloc again (append_commentconst oinibody "compute boxloc again") (list_append oinibody otestcomputboxloc) (append_commentconst oinibody "intern symbols") ;; generate interning of symbols & keywords (multiple_every odatatup (lambda (curpdat :long curk) (if (is_a curpdat class_objinitobject) (let ( (odat (unsafe_get_field :oie_data curpdat)) ) (debug "compile2obj_initproc interning curpdat=" curpdat) (cond ;; first check for keywords, since they are also symbols (so order is important) ( (is_a odat class_nrep_datakeyword) (let ( (oikw (instance class_objinternkeyword :obintern_iobj curpdat)) ) (list_append oinibody oikw) (debug "compile2obj_initproc added keyword interning oikw=" oikw) )) ( (is_a odat class_nrep_datasymbol) (let ( (oisy (instance class_objinternsymbol :obintern_iobj curpdat)) ) (list_append oinibody oisy) (debug "compile2obj_initproc added symbol interning oisy=" oisy) )) ))))) ) ;end of toplevels (append_commentconst oinibody "set retinit from boxloc") ;; emit setting the retinit from the boxloc (let ( (osetretinit (make_objcompute () ctype_value ##{/* finalsetretinit */ melt_reference_value((melt_ptr_t)($BOXLOC))}#)) ) (put_objdest osetretinit retinit) (debug "compile2obj_initproc adding osetretinit=" osetretinit) (list_append oinibody osetretinit)) ;;; ending (append_commentconst oinibody "end the initproc") (debug "compile2obj_initproc final oinibody=" oinibody " gcx=" gcx " oinitrout=" oinitrout) (return oinitrout) )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; this function is similar to compile2obj_initproc but they are some differences ;; it compiles the initial routine for runtime evaluation (defun compile2obj_initextendproc (ipro modctx idata compicache procurmodenvlist) (debug "compile2obj_initextendproc ipro=" ipro "\n* modctx=" modctx "\n* idata=" idata "\n* compicache=" compicache "\n* procurmodenvlist=" procurmodenvlist "\n\n~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\n\n" ) (shortbacktrace_dbg "compile2obj_initextendproc" 12) (assert_msg "check ipro" (is_a ipro class_nrep_initextendproc) ipro) (assert_msg "check idata" (is_list idata) idata) (assert_msg "check modctx" (is_a modctx class_running_extension_module_context) modctx) (assert_msg "check compicache" (is_mapobject compicache) compicache) (let ( (locmap (make_mapobject discr_map_objects 50)) (importvalues (get_field :ninit_imports ipro)) (importexprs (get_field :ninit_importexprs ipro)) (oiniprolog (make_list discr_list)) (oinibody (make_list discr_list)) (modenv (get_field :ninitextend_modenv ipro)) (nbody (let ( (nb (get_field :nproc_body ipro)) ) (debug "compile2obj_initextendproc nbody=" nb) nb)) (modname (get_field :mocx_modulename modctx)) (litvalist (get_field :morcx_litervalist modctx)) (oinitxrout (let ( (oi (instance class_initial_extension_routineobj ;; change carefully the name, since the runtime ;; should know it, notably its ;; meltgc_run_cc_extension function :named_name '"melt_start_run_extension" :obrout_proc ipro :obrout_body oinibody :obrout_nbval (make_integerbox discr_integer 0) :obrout_nblong (make_integerbox discr_integer 0) :obrout_others (make_list discr_list) :obrout_cntciter (make_integerbox discr_integer 0) :obrout_cntletrec (make_integerbox discr_integer 0) :oirout_fill (make_list discr_list) :oirout_prolog oiniprolog :oirout_modulename (get_field :mocx_modulename modctx) )) ) (debug "compile2obj_initextendproc oinitxrout=" oi) oi)) (importmap (make_mapobject discr_map_objects 30)) (valoclist (make_list discr_list)) ;; running expressions are usually smaller (gcx (instance class_extension_generation_context :gncx_objrout oinitxrout :gncx_locmap locmap :gncx_freeptrlist (make_list discr_list) :gncx_freelonglist (make_list discr_list) :gncx_freeothermaps (make_mapobject discr_map_objects 10) :gncx_compicache compicache :gncx_modulcontext modctx :gncx_matchmap (make_mapobject discr_map_objects 20) :igncx_procurmodenvlist (list_map procurmodenvlist (lambda (curpro) (debug "compile2obj_initextendproc procurmodenvlist curpro=" curpro) (let ( (curou (mapobject_get compicache curpro)) ) (debug "compile2obj_initextendproc procurmodenvlist curou=" curou) (assert_msg "check curou" (is_object curou) curou) curou))) ;; perhaps we should store not a list of procedures, but their matching routines :igncx_importmap importmap :egncx_valoclist valoclist )) ;; reserve stack location for the return value (retinit (let ( (reti (get_free_objlocptr gcx '_retruninit_)) ) (put_fields gcx :gncx_retloc reti) (put_fields oinitxrout :obrout_retval reti) (debug "compile2obj_initextendproc retinit=" reti) reti)) ;; reserve stack location for the current environment box container (ocurenvboxloc (let ( (boxl (get_free_objlocptr gcx '_ocurenvboxloc_)) ) (put_fields gcx :igncx_contenvloc boxl) (debug "compile2obj_initextendproc ocurenvboxloc=" boxl) boxl)) ;; reserve stack location for the current environment (ocurenvloc (let ( (locl (get_free_objlocptr gcx '_ocurenvloc_)) ) (debug "compile2obj_initextendproc ocurenvloc=" locl) locl)) ;; reserve stack location for the previous environment (oprevenvloc (let ( (boxl (get_free_objlocptr gcx '_prevenvloc_)) ) (put_fields gcx :igncx_prevenvloc boxl) (debug "compile2obj_initextendproc oprevenvloc=" boxl) boxl)) ;; reserve stack location for the tuple of literal values (olitvaluetuploc (let ( (boxl (get_free_objlocptr gcx '_olitvaluetuploc_)) ) (put_fields gcx :egncx_litvaltuploc boxl) (debug "compile2obj_initextendproc olitvaluetuploc=" boxl) boxl)) ;; We don't have any exporter, because all values stay ;; defined in the current environment so are implicitly ;; exported. ;; ;; We don't have any importer, because we use the value ;; literal tuple instead. ;; ;; initial defined bindings (inidefbinds (get_field :ninit_defbinds ipro)) ) (append_commentconst oinibody "start of oinibody") (debug "compile2obj_initextendproc ocurenvboxloc=" ocurenvboxloc "\n inidefbinds=" inidefbinds "\n modenv=" modenv) (debug "compile2obj_initextendproc importvalues=" importvalues "\n.. importexprs=" importexprs) ;; we actually could import literal named values. ;; ;; reserve location for defined values (debug "compile2obj_initextendproc inidefbinds=" inidefbinds) (assert_msg "check inidefbinds=" (is_list_or_null inidefbinds) inidefbinds) (foreach_pair_component_in_list (inidefbinds) (curpair curdefbind) (debug "compile2obj_initextendproc curdefbind=" curdefbind " of discrim=" (discrim curdefbind)) (let ( (inidefsymb (get_field :binder curdefbind)) (oinisym (get_field :fixbind_data curdefbind)) (oinidefloc (get_free_objlocptr gcx inidefsymb)) ) (debug "compile2obj_initextendproc oinidefloc=" oinidefloc " oinisym=" oinisym " of discrim:" (discrim oinisym) " curdefbind=" curdefbind) ;;oinisym is often a class_nrep_locsymocc but can be a ;;class_nrep_defined_constant (assert_msg "check oinisym" (is_a oinisym class_nrep_simple) oinisym) (mapobject_put locmap curdefbind oinidefloc) )) (debug "compile2obj_initextendproc updated locmap=" locmap "\n.. importvalues=" importvalues) ;; (let ( (limplocv (list_map importvalues (lambda (ival) (debug "compile2obj_initextendproc imported ival=" ival) (assert_msg "check ival" (is_a ival class_nrep_literalnamedvalue) ival) (let ( (isym (get_field :nlitval_symbol ival)) (regval (get_field :nlitval_regval ival)) (litloc (get_field :litv_loc regval)) (ilocv (or litloc (let ( (nloc (get_free_objlocptr gcx isym)) ) (debug "compile2obj_initextendproc nloc=" nloc " for ival=" ival) (mapobject_put importmap isym nloc) (put_fields litloc :litv_loc nloc) nloc))) ) (debug "compile2obj_initextendproc imported ilocv=" ilocv " for isym=" isym) ilocv ))))) (debug "compile2obj_initextendproc limplocv=" limplocv) (void) ) ;; ;; the prologue start by getting the the current environment ;; reference and the raw value tuple (list_append oiniprolog (make_objlocatedexp () ctype_void ##{/*initextendproc get boxcurenv*/ $OCURENVBOXLOC = meltarg_curenvbox_p ;}# )) (debug "compile2obj_initextendproc litvalist=" litvalist) (let ( (:long nblitval (list_length litvalist)) (toplis (unsafe_get_field :ninit_topl ipro)) ) (debug "compile2obj_initextendproc toplis=" toplis) (list_append oiniprolog (make_objlocatedexp () ctype_void ##{/*initextendproc get litvaluetup*/ $OLITVALUETUPLOC = meltarg_tuplitval_p ; if (melt_multiple_length((melt_ptr_t) $OLITVALUETUPLOC) != $NBLITVAL) melt_fatal_error ("bad runtime extension literal value tuple@%p in " $MODNAME ", wants $NBLITVAL components", (void*) $OLITVALUETUPLOC) ; }# )) (list_append oiniprolog (instance class_objgetslot :obdi_destlist (list ocurenvloc) :ogetsl_obj ocurenvboxloc :ogetsl_field referenced_value )) (list_append oiniprolog (instance class_objgetslot :obdi_destlist (list oprevenvloc) :ogetsl_obj ocurenvloc :ogetsl_field env_prev )) (debug "compile2obj_initextendproc before body oiniprolog=" oiniprolog "\n idata=" idata) (debug "compile2obj_initextendproc again toplis=" toplis "\n.. gcx=" debug_less gcx) (assert_msg "check toplis" (is_list_or_null toplis) toplis) ;; compile the toplevels (let ( (objtoplis (list_map toplis (lambda (curtop) (debug "compile2obj_initextendproc curtop=" curtop) (let ( (otop (compile_obj curtop gcx)) ) (debug "compile2obj_initextendproc otop=" otop) otop)))) ) (debug "compile2obj_initextendproc objtoplis=" objtoplis) ;; now handle the body ;; the tuple to compile the body (let ( (odatatup (list_to_multiple idata discr_multiple (lambda (curdat) (debug "compile2obj_initextendproc/lambdabody curdat=" curdat) (assert_msg "check curdat" (is_a curdat class_nrep_bound_data) curdat) (let ( (curobd (compile_obj curdat gcx)) ) (debug "compile2obj_initextendproc/lambdabody curobd=" curobd) curobd)))) ) (debug "compile2obj_initextendproc odatatup=" odatatup "\n.. toplis=" toplis) (put_fields oinitxrout :oirout_data odatatup) ;; generate the getting of symbols & keywords (append_commentconst oiniprolog "get symbols & keywords for extension") (assert_msg "check odatatup" (is_multiple_or_null odatatup) odatatup) (foreach_in_multiple (odatatup) (curpdat :long curk) (if (is_a curpdat class_objinitobject) (let ( (odat (unsafe_get_field :oie_data curpdat)) ) (debug "compile2obj_initextendproc getting curpdat=" curpdat) (cond ;; first check for keywords, since they are also symbols (so order is important) ( (is_a odat class_nrep_datakeyword) (let ( (ogkw (instance class_objgetnamedkeyword :obgnamed_iobj curpdat)) ) (list_append oiniprolog ogkw) (debug "compile2obj_initextendproc added keyword getting ogkw=" ogkw) )) ( (is_a odat class_nrep_datasymbol) (let ( (ogsy (instance class_objgetnamedsymbol :obgnamed_iobj curpdat)) ) (list_append oiniprolog ogsy) (debug "compile2obj_initextendproc added symbol getting ogsy=" ogsy) )) )))) (debug "compile2obj_initextendproc before imports oiniprolog=" oiniprolog) ;; (when (>i (list_length importvalues) 0) (append_commentconst oiniprolog "before getting imported values") ;; generate the getting of imported values (foreach_pair_component_in_list (importvalues) (curpairimp curimport) (debug "compile2obj_initextendproc curimport=" curimport) (assert_msg "check curimport" (is_a curimport class_nrep_literalnamedvalue) curimport) (compile_warning "the generated import should have a cstring") (let ( (impsym (get_field :nlitval_symbol curimport)) (regval (get_field :nlitval_regval curimport)) (val (get_field :litv_value regval)) (modulstr (get_field :mocx_modulename modctx)) (oimplocv (mapobject_get importmap impsym)) ) (debug "compile2obj_initextendproc impsym=" impsym "\n regval=" regval "\n oimplocv=" oimplocv) (let ( (:long litrank (get_int (get_field :litv_rank regval))) (ogetlit (make_objcompute () ctype_value ##{/* retrieve runtime literal value #$LITRANK */ ((melt_ptr_t) (((meltmultiple_ptr_t)$OLITVALUETUPLOC)->tabval[$LITRANK])) }#)) ) (put_objdest ogetlit oimplocv) (debug "compile2obj_initextendproc/import val=" val " regval=" regval " ogetlit=" ogetlit) (list_append oiniprolog ogetlit) ))) (append_commentconst oiniprolog "after getting imported values") ) ;; append the compiled toplevel (append_commentconst oinibody "before toplevel body") (debug "compile2obj_initextendproc objtoplis=" objtoplis) (foreach_pair_component_in_list (objtoplis) (curpair curobjt) (debug "compile2obj_initextendproc appendinf curobjt=" curobjt) (list_append oinibody curobjt)) (debug "compile2obj_initextendproc updated oinibody=" oinibody) (debug "compile2obj_initextendproc nbody=" nbody) (foreach_pair_component_in_list (nbody) (curnpair curninst) (debug "compile2obj_initextendproc curninst=" curninst) (if (is_not_a curninst class_nrep_routproc) (let ( (curobjb (compile_obj curninst gcx)) ) (debug "compile2obj_initextendproc curobjb=" curobjb) (cond ( (null curobjb) (debug "compile2obj_initextendproc skipping null curobjb=" curobjb) (void) ) ( (is_a curobjb class_objpurevalue) (debug "compile2obj_initextendproc skipping pure curobjb=" curobjb) (void) ) (:else (debug "compile2obj_initextendproc appending curobjb=" curobjb) (list_append oinibody curobjb) (void))) ))) ;; (append_commentconst oinibody "after toplevel body") (debug "compile2obj_initextendproc final oinibody=" oinibody) ;; (debug "compile2obj_initextendproc gives oinitxrout=" oinitxrout "\n") (return oinitxrout) ))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (export_values compile2obj_hook compile2obj_initproc compile2obj_initextendproc compile2obj_procedure variadic_index_idstr variadic_length_idstr ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;function to get a free local value pointer for some name ;; any free ptr is only reused for its offset. the objlocv is not reused... (defun get_free_objlocptr (gcx nam) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "get_free_objlocptr start nam=" nam) (shortbacktrace_dbg "get_free_objlocptr" 6) (let ( (orout (unsafe_get_field :gncx_objrout gcx)) (freeli (unsafe_get_field :gncx_freeptrlist gcx)) (pfree (list_popfirst freeli)) (:long off -1) ) (if (not (is_a orout class_routineobj)) (debug "get_free_objlocptr bad orout=" orout)) (assert_msg "check orout" (is_a orout class_routineobj) orout) (if (is_a pfree class_objlocv) (let ( (offpfree (unsafe_get_field :obl_off pfree)) ) (debug "get_free_objlocptr pfree=" pfree) (assert_msg "get_free_objlocptr check offpfree" (is_integerbox offpfree) offpfree) ;; check that pfree has no objnum so was unused (assert_msg "check pfree not used" (not (get_int pfree)) pfree) (setq off (get_int offpfree))) (let ( (nbvalorout (unsafe_get_field :obrout_nbval orout)) ) (setq off (get_int nbvalorout)) )) (assert_msg "check off" (>=i off 0) off) (let ( (nbvalbox (unsafe_get_field :obrout_nbval orout)) (:long nbval (get_int nbvalbox)) (nambuf (make_strbuf discr_strbuf)) ) (cond ( (is_a nam class_named) (let ( (namstr (unsafe_get_field :named_name nam)) ) (add2sbuf_cident nambuf namstr))) ( (is_string nam) (add2sbuf_cident nambuf nam))) (add2sbuf_strconst nambuf "__V") (add2sbuf_longdec nambuf (+i nbval 1)) (put_int nbvalbox (+i nbval 1)) (let ( (namstr (strbuf2string discr_string nambuf)) (oldnbvalbox (make_integerbox discr_integer nbval)) (nloc (instance class_objlocv :obv_type ctype_value :obl_off (make_integerbox discr_integer off) :obl_proc orout :obl_cname namstr)) ) (debug "get_free_objlocptr new nloc" nloc) (return 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_c_generation_context) gcx) (debug "get_free_objloclong start nam=" nam) ;(shortbacktrace_dbg "get_free_objloclong start" 12) (let ( (orout (unsafe_get_field :gncx_objrout gcx)) (freeli (unsafe_get_field :gncx_freelonglist gcx)) (pfree (list_popfirst freeli)) (:long off -1) ) (assert_msg "check orout" (is_a orout class_routineobj) orout) (if (is_a pfree class_objlocv) (let ( (offpfree (unsafe_get_field :obl_off pfree)) ) (debug "get_free_objloclong pfree" pfree) (assert_msg "check offpfree" (is_integerbox offpfree) offpfree) ;; check that pfree has no objnum so was unused (assert_msg "check pfree not used" (not (get_int pfree)) pfree) (setq off (get_int offpfree))) (let ( (nblongorout (unsafe_get_field :obrout_nblong orout)) ) (assert_msg "check nblongorout" (is_integerbox nblongorout) nblongorout) (setq off (get_int nblongorout)))) (assert_msg "check off" (>=i off 0) off) (let ( (nblongbox (unsafe_get_field :obrout_nblong orout)) (:long nblong (get_int nblongbox)) (nambuf (make_strbuf discr_strbuf)) ) (cond ( (is_a nam class_named) (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) ( (is_string nam) (add2sbuf_cident nambuf nam)) ) (add2sbuf_strconst nambuf "__L") (add2sbuf_longdec nambuf (+i nblong 1)) (put_int nblongbox (+i nblong 1)) (let ( (nloc (instance class_objlocv :obv_type ctype_long :obl_off (make_integerbox discr_integer off) :obl_proc orout :obl_cname (strbuf2string discr_string nambuf))) ) (debug "get_free_objloclong new nloc=" nloc) (return nloc) )))) ;;; function to get a free local otherstuff for some name and ctype (defun get_free_objloctyped (gcx nam ctyp) (debug "get_free_objloctyped nam=" nam " ctyp=" ctyp) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check ctyp" (is_a ctyp class_ctype) ctyp) (cond ( (== ctyp ctype_long) (return (get_free_objloclong gcx nam))) ( (== ctyp ctype_value) (return (get_free_objlocptr gcx nam))) ;; return null for the void ctype ( (== ctyp ctype_void) (return ())) (:else (debug "get_free_objloctyped otherctyp nam=" nam " ctyp=" ctyp) ;(shortbacktrace_dbg "get_free_objloctyped otherctyp" 15) (let ( (freemap (unsafe_get_field :gncx_freeothermaps gcx)) (orout (unsafe_get_field :gncx_objrout gcx)) (:long off -1) ) (assert_msg "check freemap" (is_mapobject freemap) freemap) (assert_msg "check orout" (is_a orout class_routineobj) orout) (let ( (freeli (mapobject_get freemap ctyp)) ) (if (null freeli) (progn (setq freeli (make_list discr_list)) (mapobject_put freemap ctyp freeli))) (let ( (pfree (list_popfirst freeli)) ) (if (is_a pfree class_objlocv) (progn (debug "get_free_objloctyped pfree=" pfree) (assert_msg "check pfree was unused" (not (get_int pfree)) pfree) (setq off (get_int (unsafe_get_field :obl_off pfree))) ) (setq off (list_length (unsafe_get_field :obrout_others orout)))) (let ( (nambuf (make_strbuf discr_strbuf)) (others (unsafe_get_field :obrout_others orout)) (:long nbothers (list_length others)) ) (assert_msg "check others" (is_list others) others) (add2sbuf_strconst nambuf "loc_") (add2sbuf_cident nambuf (get_field :named_name (get_field :ctype_keyword ctyp))) (add2sbuf_strconst nambuf "__o") (add2sbuf_longdec nambuf nbothers) (let ( (nloc (instance class_objlocv :obv_type ctyp :obl_proc orout :obl_off (make_integerbox discr_integer off) :obl_cname (strbuf2string discr_string nambuf))) ) (debug "get_free_objloctyped new nloc" nloc) (list_append others nloc) (return nloc) ) ))))))) ;; function to dispose, i.e. mark as free and reusable, an objlocation (defun dispose_objloc (oldloc gcx) (debug "dispose_objloc start disposing oldloc=" oldloc) (shortbacktrace_dbg "dispose_objloc" 9) (assert_msg "check oldloc" (is_a oldloc class_objlocv) oldloc) (assert_msg "check gcx" (is_a gcx class_c_generation_context)) ;; the obl_proc iff it has already been freed (assert_msg "check used oldloc" (unsafe_get_field :obl_proc oldloc) oldloc) (let ( (oldcty (unsafe_get_field :obv_type oldloc)) ) (assert_msg "check oldcty not void" (!= oldcty ctype_void) oldcty) (assert_msg "check oldcty is ctype" (is_a oldcty class_ctype) oldcty) (put_fields oldloc :obl_proc ()) ;mark the objlocation as freed (debug "dispose_objloc freeing oldloc=" 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 (let ( (freemap (unsafe_get_field :gncx_freeothermaps gcx)) (orout (unsafe_get_field :gncx_objrout gcx)) ) (assert_msg "check freemap" (is_mapobject freemap) freemap) (assert_msg "check orout" (is_a orout class_routineobj) orout) (let ( (freeli (mapobject_get freemap oldcty)) ) ;; since we are freeing, freeli should exist (assert_msg "check freeli" (is_list freeli) freeli) (list_append freeli oldloc))))) (debug "dispose_objloc freed oldloc=" oldloc) )) ;; function to dispose, i.e. mark as free, a binding (defun dispose_bnd_obj (bnd gcx) (debug "dispose_bnd_obj start bnd=" bnd) (assert_msg "check bnd" (is_a bnd class_any_binding) bnd) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (locmap (unsafe_get_field :gncx_locmap gcx)) (oldloc (mapobject_get locmap bnd)) ) (debug "dispose_bnd_obj oldloc=" oldloc) (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 "dispose_bnd_obj nulloldloc bnd=" bnd) )) (assert_msg "check oldloc" (is_a oldloc class_objlocv) oldloc) (dispose_objloc oldloc gcx) (mapobject_remove locmap bnd) (debug "dispose_bnd_obj end bnd=" bnd) )) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_chunk (nchk gcx) (debug "compilobj_nrep_chunk nchk=" nchk) (assert_msg "check nchk" (is_a nchk class_nrep_chunk) nchk) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc nchk)) (nexp (unsafe_get_field :nchunk_expansion nchk)) (noper (unsafe_get_field :nchunk_oper nchk)) (ntyp (unsafe_get_field :nexpr_ctyp nchk)) ) (debug "compilobj_nrep_chunk nexp=" nexp) (assert_msg "check noper" (is_a noper class_named) noper) (assert_msg "check nexp" (is_multiple nexp) nexp) (assert_msg "check ntyp" (is_a ntyp class_ctype) ntyp) (let ( (otup (multiple_map nexp (lambda (comp :long ix) (debug "compilobj_nrep_chunk comp=" comp " ix#" ix) (if (== (discrim comp) discr_verbatim_string) (progn (debug "compilobj_nrep_chunk verbstring comp=" comp " ix#" ix) (return comp) ) (let ( (ocomp (compile_obj comp gcx)) ) (debug "compilobj_nrep_chunk ocomp=" ocomp " ix#" ix) (return ocomp)))) )) (oexp (if loc (instance class_objlocatedexpv :obv_type ntyp :obx_cont otup :obcx_loc loc ) (instance class_objexpv :obv_type ntyp :obx_cont otup) )) ) (debug "compilobj_nrep_chunk otup=" otup) (assert_msg "check ntyp" (is_a ntyp class_ctype) ntyp) (debug "compilobj_nrep_chunk result oexp=" oexp) oexp) )) (install_method class_nrep_chunk compile_obj compilobj_nrep_chunk) ;;;;;;;;;;;;;;;; (defun getctype_typexpr (recv env) (assert_msg "check recv" (is_a recv class_nrep_typed_expression) recv) (unsafe_get_field :nexpr_ctyp recv)) (install_method class_nrep_typed_expression get_ctype getctype_typexpr) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_nil (nilo gcx) (assert_msg "check nilo" (is_a nilo class_nrep_nil) nilo) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (obnil (instance class_objnil :obv_type ctype_value)) ) (return obnil)) ) (install_method class_nrep_nil compile_obj compilobj_nrep_nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_comment (ncomm gcx) (debug "compilobj_nrep_comment start ncomm=" ncomm) (assert_msg "check ncomm" (is_a ncomm class_nrep_comment) ncomm) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (coms (unsafe_get_field :ncomm_string ncomm)) (nloc (unsafe_get_field :nrep_loc ncomm)) (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sbuf "/**!* ") (add2sbuf_ccomstring sbuf coms) (add2sbuf_strconst sbuf " *!**/") (let ( (ostr (strbuf2string discr_verbatim_string sbuf)) (res (instance class_objcompute :obi_loc nloc :obdi_destlist () :obcpt_type ctype_void :obcpt_expr ostr)) ) (debug "compilobj_nrep_comment ostr=" ostr " res=" res) (return res) ))) (install_method class_nrep_comment compile_obj compilobj_nrep_comment) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_locsymocc (lsyo gcx) (debug "compilobj_nrep_locsymocc begin lsyo=" lsyo) (assert_msg "check nchk" (is_a lsyo class_nrep_locsymocc) lsyo) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (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 "compilobj_nrep_locsymocc sbnd=" sbnd " ovar=" ovar) (when (null sbnd) (debug "compilobj_nrep_locsymocc null sbnd lsyo=" lsyo " sym=" sym) (assert_msg "locsymocc without binding" () lsyo) ) (if (null ovar) (progn (debug "compilobj locsymocc null ovar sbnd=" sbnd "\n.. locmap=" locmap "\n.. lsyo=" lsyo "\n.. gcx=" debug_less gcx) (assert_msg "compilobj_nrep_locsymocc null ovar without ctype_void" (== oty ctype_void) oty lsyo locmap) ) (assert_msg "compilobj_nrep_locsymocc check ovar" (is_a ovar class_objlocv) ovar)) (debug "compilobj_nrep_locsymocc end lsyo=" lsyo " gives ovar=" ovar) (return ovar) )) (install_method class_nrep_locsymocc compile_obj compilobj_nrep_locsymocc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_closedocc (nclo gcx) (debug "compilobj_nrep_closedocc nclo=" nclo) (assert_msg "check nclo" (is_a nclo class_nrep_closedocc) nclo) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (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)) ) (assert_msg "check lastcproc" (is_a lastcproc class_nrep_routproc) lastcproc) (let ( (cloblis (get_field :nrclop_clobindlist lastcproc)) (:long clorank -1) ) (assert_msg "check cloblis" (is_list cloblis) 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) clorank) (let ( (nclotyp (unsafe_get_field :nocc_ctyp nclo)) (ocloccv (instance class_objcloccv :obv_type nclotyp :obc_off (make_integerbox discr_integer clorank) :obc_proc lastcproc :obc_name (unsafe_get_field :named_name osym))) ) (assert_msg "check nclotyp" (is_a nclotyp class_ctype) nclotyp) (debug "compilobj closedocc result ocloccv=" ocloccv) ocloccv ))))) (install_method class_nrep_closedocc compile_obj compilobj_nrep_closedocc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_constocc (ncnst gcx) (debug "compilobj_nrep_constocc ncnst=" ncnst) (assert_msg "check ncnst" (is_a ncnst class_nrep_constocc) ncnst) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (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)) (cnstyp (unsafe_get_field :nocc_ctyp ncnst)) (nbind (unsafe_get_field :nocc_bind ncnst)) ) (debug "compilobj_nrep_constocc lastcproc=" lastcproc "\n..cprocs=" cprocs "\n..nbind=" nbind "\n.. gcx=" debug_less gcx) (shortbacktrace_dbg "compilobj_nrep_constocc" 8) (assert_msg "check lastcproc" (is_a lastcproc class_nrep_anyproc) lastcproc ncnst) (assert_msg "check cnstyp" (== cnstyp ctype_value) cnstyp ncnst) (cond ;; handle routine procedures ( (is_a lastcproc class_nrep_routproc) (let ( (cnstlis (get_field :nrclop_constlist lastcproc)) (:long cnstrank -1) ) (assert_msg "check cnstlis" (is_list cnstlis) 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) cnstrank) (let ( (oconstv (instance class_objconstv :obv_type cnstyp :obc_off (constant_box cnstrank) :obc_proc lastcproc :obc_name (unsafe_get_field :named_name osym))) ) (debug "compilobj_nrep_constocc result oconstv=" oconstv) (return oconstv) )))) ;; handle hook routines ( (is_a lastcproc class_nrep_hookproc) (let ( (:long offhk -1) (:long count 0) (hclobindlist (get_field :nrclop_clobindlist lastcproc)) ) (debug "compilobj_nrep_constocc hook hclobindlist=" hclobindlist) (foreach_pair_component_in_list (hclobindlist) (curpair curbind) (assert_msg "check curbind" (is_a curbind class_any_binding) curbind) (let ( (cursym (get_field :binder curbind)) ) (when (== cursym osym) (setq curpair ()) (setq offhk count)) (setq count (+i count 1)) )) (debug "compilobj_nrep_constocc offhk=" offhk) (assert_msg "check offhk" (>=i offhk 0) offhk) (let ( (ohkconstv (instance class_objclohookv :obv_type cnstyp :obc_off (constant_box offhk) :obc_proc lastcproc :obc_name (unsafe_get_field :named_name osym))) ) (debug "compilobj_nrep_constocc result ohkconstv=" ohkconstv) (return ohkconstv) ))) (:else (debug "compilobj_nrep_constocc invalid lastcproc=" lastcproc "\n.. for ncnst=" ncnst) (assert_msg "compilobj_nrep_constocc unexpected lastcproc" () lastcproc ncnst) )))) (install_method class_nrep_constocc compile_obj compilobj_nrep_constocc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_importedval (nsva gcx) (debug "compilobj_nrep_importedval nsva=" nsva " gcx=" gcx) (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx) (assert_msg "check nsva" (is_a nsva class_nrep_importedval) nsva) (let ( (var (unsafe_get_field :nimport_symb nsva)) (olocv (mapobject_get (unsafe_get_field :igncx_importmap gcx) var)) ) (debug "compilobj_nrep_importedval result olocv=" olocv) (assert_msg "check var" (is_a var class_symbol) var) (assert_msg "check olocv" (is_a olocv class_objlocv) olocv) (return olocv) )) (install_method class_nrep_importedval compile_obj compilobj_nrep_importedval) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_literalvalue (nlitv gcx) (debug "compilobj_nrep_literalvalue nlitv=" nlitv "\n of discrim=" (discrim nlitv) "\n gcx=" gcx) (let ( (litregval (get_field :nlitval_regval nlitv)) (litvrank (get_field :litv_rank litregval)) (olitup (get_field :egncx_litvaltuploc gcx)) (nloc (get_field :nrep_loc nlitv)) ) (debug "compilobj_nrep_literalvalue litregval=" litregval "\n litvrank=" litvrank "\n olitup=" olitup) (assert_msg "check litregval" (is_a litregval class_literal_value) litregval) (assert_msg "check litvrank" (is_integerbox litvrank) litvrank) (assert_msg "check gcx" (is_a gcx class_extension_generation_context) gcx) (let ( (res (make_objexpandpureval nloc ctype_value (string4out discr_verbatim_string ##{literal-value #$LITVRANK}#) ##{/*comp.literalvalue*/ (melt_ptr_t) (((meltmultiple_ptr_t)$OLITUP)->tabval[$LITVRANK])}#)) ) (debug "compilobj_nrep_literalvalue res=" res) (return res) ))) (install_method class_nrep_literalvalue compile_obj compilobj_nrep_literalvalue) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_definedconstant (ndconst gcx) (debug "compilobj definedconstant ndconst=" ndconst " gcx=" gcx) (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx) (assert_msg "check ndconst" (is_a ndconst class_nrep_defined_constant) ndconst) (let ( (nsval (unsafe_get_field :nconst_sval ndconst)) (nloc (unsafe_get_field :nrep_loc ndconst)) (locmap (unsafe_get_field :gncx_locmap gcx)) (ndefbnd (unsafe_get_field :nconst_defbind ndconst)) (ovloc (mapobject_get locmap ndefbnd)) (nproc (unsafe_get_field :nconst_proc ndconst)) ) (debug "compilobj definedconstant ndefbnd=" ndefbnd " nloc=" nloc " ovloc=" ovloc " nproc=" nproc) (assert_msg "compilobj definedconstant check ovloc" ovloc) (return ovloc) )) (install_method class_nrep_defined_constant compile_obj compilobj_nrep_definedconstant) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a quasiconstant (defun compilobj_nrep_quasiconstant (nconst gcx) (debug "compilobj quasiconstant nconst=" nconst) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check nconst" (is_a nconst class_nrep_quasiconstant) nconst) (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 (get_field :nrclop_constlist 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) coff) (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 (instance class_objconstv :obv_type ctype_value :obc_off (make_integerbox discr_integer coff) :obc_proc proc :obc_name (strbuf2string discr_string nambuf) )) ) (debug "compilobj quasiconstant constv=" constv) (return constv) ) ) (let ( (odata (compile_obj data gcx)) ) ;; not inside a proc, just return the compiled data (debug "compilobj quasiconstant odata=" odata) (return odata) ) ) ) ) (install_method class_nrep_quasiconstant compile_obj compilobj_nrep_quasiconstant) (defun compilobj_nrep_quasiconst_current_module_environment_reference (nqcme gcx) (debug "compilobj_nrep_quasiconst_current_module_environment_reference start nqcme=" nqcme) (assert_msg "check nqme" (is_a nqcme class_nrep_quasiconst_current_module_environment_reference) nqcme) (let ( (onres (compilobj_nrep_quasiconstant nqcme gcx)) (scomm (unsafe_get_field :nqcmec_comment nqcme)) (str (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sbuf "/*quasi.cur.mod.env.ref ") (add2sbuf_ccomstring sbuf scomm) (add2sbuf_strconst sbuf "*/\n") (strbuf2string discr_verbatim_string sbuf) ) ) (olres (make_objlocatedexp (unsafe_get_field :nrep_loc nqcme) ctype_value str ##{ /* check quasi.cur.mod.env.ref $(obj_hash nqcme) */ ($ONRES) }#)) ) (debug "compilobj_nrep_quasiconstant_current_module_environment_reference result olres=" olres) (return olres) )) (install_method class_nrep_quasiconst_current_module_environment_reference compile_obj compilobj_nrep_quasiconst_current_module_environment_reference) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a forever (defun compilobj_nrep_forever (nfor gcx) (debug "compilobj_nrep_forever nfor=" nfor) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check nfor" (is_a nfor class_nrep_forever) nfor) (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) nbind) (debug "compilobj_nrep_forever oresv=" oresv) (assert_msg "check oresv" (is_a oresv class_objlocv) oresv) (unsafe_put_fields nbind :labind_res oresv) (assert_msg "check again nbind" (is_object nbind) nbind) (debug "compilobj_nrep_forever updated nbind=" nbind) (let ( (closy (unsafe_get_field :labind_clonsy nbind)) (bodyl (make_list discr_list)) (epilogl (make_list discr_list)) (oloop (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_cloned_symbol) closy) (multiple_every nbody (lambda (ncomp :long ix) (list_append bodyl (compile_obj ncomp gcx)))) (debug "compilobj forever result oloop=" oloop) oloop ) ) ) (install_method class_nrep_forever compile_obj compilobj_nrep_forever) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile an exit (defun compilobj_nrep_exit (nexi gcx) (debug "compilobj_nrep_exit nexi=" nexi) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check nexi" (is_a nexi class_nrep_exit) nexi) (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) nbindx) (let ( (inslist (make_list discr_list)) (epilist (make_list discr_list)) (destlist (make_list discr_list)) (oval (compile_obj nval gcx)) (bxres (unsafe_get_field :labind_res nbindx)) (obloc (instance class_objplainblock :obi_loc nloc :oblo_bodyl inslist :oblo_epil epilist )) (obex (instance class_objexit :obi_loc nloc :obexit_label (unsafe_get_field :labind_clonsy nbindx) )) (obcom (instance class_objcompute :obi_loc nloc :obdi_destlist destlist :obcpt_type ctype_value :obcpt_expr oval)) ) (list_append inslist obcom) (list_append epilist obex) (list_append destlist bxres) (debug "compilobj_nrep_exit return obloc=" obloc) (return obloc) ))) (install_method class_nrep_exit compile_obj compilobj_nrep_exit) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; compile an again (defun compilobj_nrep_again (nag gcx) (debug "compilobj_nrep_again nag=" nag) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check nag" (is_a nag class_nrep_again) nag) (let ( (nloc (unsafe_get_field :nrep_loc nag)) (nlabind (unsafe_get_field :nagain_bind nag)) (oagain (instance class_objagain :obi_loc nloc :obagain_label (get_field :labind_clonsy nlabind) )) ) (assert_msg "check nlabind" (is_a nlabind class_label_binding) nlabind) (debug "compilobj_nrep_again return oagain=" oagain) (return oagain) )) (install_method class_nrep_again compile_obj compilobj_nrep_again) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_discrany (anyv gcx) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) anyv ) (install_method discr_any_receiver compile_obj compilobj_discrany) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_let (rlet gcx) (debug "compilobj_nrep_let initial rlet=" rlet) (assert_msg "check rlet" (is_a rlet class_nrep_let) rlet) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc rlet)) (bnds (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 (instance class_objplainblock :obi_loc loc :oblo_bodyl obodl :oblo_epil oepil)) ) (debug "compilobj_nrep_let initial loc=" loc "\n.. bnds=" bnds "\n.. bdy=" bdy "\n.. locmap=" locmap) ;; for each normalexp in the bnds tuple ;; add the binding and the setting in the body and the clear in the epilogue (assert_msg "compilobj_nrep_let check bnds multiple" (is_multiple_or_null bnds) bnds) ;; iterate on normal bindings (foreach_in_multiple (bnds) (nlbnd :long bndix) (debug "compilobj_nrep_let current normbinding loc=" loc " nlbnd=" nlbnd " locmap=" locmap) (assert_msg "check nlbnd in compilobj_nrep_let" (is_a nlbnd class_normal_let_binding) nlbnd) (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)) ) (debug "compilobj_nrep_let current normbinding obva=" obva "\n nexp=" nexp) (let ( (obnx (compile_obj nexp gcx)) ) (debug "compilobj_nrep_let current normbinding obnx=" obnx "\n.. for nexp=" nexp "\n.. with obva=" obva) (if (is_a nexp class_sexpr) (when (not (is_object obnx)) (debug "compilobj_nrep_let current normbinding faulty nexp=" nexp " obnx=" obnx) (assert_msg "compilobj_nrep_let check obnx" (is_object obnx) obnx nexp))) (if obva ;; non void cty (progn (mapobject_put locmap nlbnd obva) (debug "compilobj_nrep_let obnx=" obnx "\n nlbnd=" nlbnd "\n obva=" obva) (let ( (obpd (put_objdest obnx obva)) (obmy (or obpd obnx)) ) (debug "compilobj_nrep_let current obpd=" obpd " obmy=" obmy) (list_append obodl obmy) )) (progn ;; obva is nil when cty is void type (debug "compilobj_nrep_let append obnx=" obnx) (list_append obodl obnx) )) ;; add clearing of obva to epilogue part of oblock (if obva (let ( (obcl (instance class_objclear :obi_loc loc :oclr_vloc obva)) ) (list_append oepil obcl) ))))) (debug "compilobj_nrep_let after iterate normbind loc=" loc "\n.. locmap=" locmap "\n.. oepil=" oepil) ;; ;; compile each body component (assert_msg "check bdy" (is_multiple_or_null bdy) bdy) (foreach_in_multiple (bdy) (bdycomp :long bdyix) (debug "compilobj_nrep_let body loc=" loc " bdycomp=" bdycomp " bdyix=" bdyix) (let ( (objcomp (compile_obj bdycomp gcx)) ) (debug "compilobj_nrep_let body objcomp=" objcomp) ;; objcomp is null when compiling a locvar of ctype_void; ;; this happens with primitive of :void type (if (null objcomp) (void) (list_append obodl objcomp)))) (debug "compilobj_nrep_let after iterate body loc=" loc) ;; ;; dispose each binding (debug "compilobj_nrep_let disposing bnds=" bnds "\n.. with bdy=" bdy "\n.. obodl=" obodl) ;; @@@??? perhaps we should avoid disposing the binding of the ;; last component of tuple bdy, if it is its locsymocc... (foreach_in_multiple (bnds) (obnd :long ix) (debug "compilobj_nrep_let dispose loc=" loc " obnd=" obnd " ix=" ix) (dispose_bnd_obj obnd gcx)) (debug "compilobj_nrep_let done disposal bnds=" bnds) (debug "compilobj_nrep_let final loc=" loc " locmap=" locmap " oblock=" oblock) (return oblock) ;return it )) (install_method class_nrep_let compile_obj compilobj_nrep_let) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; selector to compile the fill inside a letrec ;;; receiver: the normalized constructrive binding ;;; arguments: ;;;; * GCX the code generation context ;;; result = the obj instruction or value (defselector compile_letrec_fill class_selector :doc #{The selector $COMPILE_LETREC_FILL is used to compile the fill for a $LETREC. The $RECV is usually a constructive binding. $OBVA is the object variable, and $OBODL is the list for the body, $GCX being the generation context. $SLOC is the source location.}# :formals (recv obva obodl gcx sloc) ) (export_values compile_letrec_fill) (defun fail_compiletrecfill (recv obva obodl gcx sloc) (debug "fail_compiletrecfill recv=" recv " obva=" obva) (let ( (d (discrim recv)) ) (error_strv sloc "unimplemented discriminant for compile_letrec_fill" (get_field :named_name d)) (assert_msg "fail_compiletrecfill unexpected" () recv) )) (install_method discr_any_receiver compile_letrec_fill fail_compiletrecfill) ;;;;;;;;;;;;;;;; ;; generate inside the body list the code for filling lambda in letrecs (defun compiletrec_lambda (recv obva obodl gcx sloc) (debug "compiletrec_lambda recv=" recv " obva=" obva) (assert_msg "check recv" (is_a recv class_normal_constructed_lambda_binding) recv) (assert_msg "check obva" (is_a obva class_objlocv) obva) (assert_msg "check obodl" (is_list obodl) obodl) (let ( (loc (or (get_field :nconsb_loc recv) sloc)) (nclosed (get_field :nlambdab_nclosed recv)) (nconstrout (get_field :nlambdab_constrout recv)) (otouch (instance class_objtouch :obi_loc loc :otouch_val obva )) (ocrout (compile_obj nconstrout gcx)) (oputrout (instance class_objputclosurout :obi_loc loc :opclor_clos obva :opclor_rout ocrout )) ) (debug "compiletrec_lambda oputrout=" oputrout) (list_append obodl oputrout) ;; (debug "compiletrec_lambda nclosed=" nclosed) (foreach_in_multiple (nclosed) (curclosed :long curix) (debug "compiletrec_lambda curclosed=" curclosed " curix=" curix) (let ( (oclosed (compile_obj curclosed gcx)) ) (debug "compiletrec_lambda oclosed=" oclosed) (cond ( (or (is_not_a oclosed class_objpurevalue) (is_a oclosed class_objinstr)) (if (>i curix 0) (list_append obodl otouch)) (list_append obodl oclosed) ) (:else (debug "compiletrec_lambda ignored generated code oclosed=" oclosed)) ) (let ( (oputclo (instance class_objputclosedv :obi_loc loc :opclov_clos obva :opclov_off (make_integerbox discr_integer curix) :opclov_cval oclosed )) ) (debug "compiletrec_lambda oputclo=" oputclo) (list_append obodl oputclo) )) ) (list_append obodl otouch) (debug "compiletrec_lambda final obodl=" obodl) )) (install_method class_normal_constructed_lambda_binding compile_letrec_fill compiletrec_lambda) ;; generate inside the body list the code for filling tuple in letrecs (defun compiletrec_tuple (recv obva obodl gcx sloc) (debug "compiletrec_tuple recv=" recv " obva=" obva) (assert_msg "check recv" (is_a recv class_normal_constructed_tuple_binding) recv) (assert_msg "check obva" (is_a obva class_objlocv) obva) (assert_msg "check obodl" (is_list obodl) obodl) (let ( (loc (or (get_field :nconsb_loc recv) sloc)) (ncomptup (get_field :ntupb_comp recv)) (otouch (instance class_objtouch :obi_loc loc :otouch_val obva )) ) (debug "compiletrec_tuple ncomptup=" ncomptup) (foreach_in_multiple (ncomptup) (ncurcomp :long ix) (debug "compiletrec_tuple ncurcomp=" ncurcomp " ix=" ix) (let ( (ocomp (compile_obj ncurcomp gcx)) (oputn (instance class_objputuple :obi_loc loc :oputu_tupled obva :oputu_offset (make_integerbox discr_integer ix) :oputu_value ocomp )) ) (debug "compiletrec_tuple ocomp=" ocomp) (cond ( (or (is_not_a ocomp class_objpurevalue) (is_a ocomp class_objinstr)) (list_append obodl otouch) (list_append obodl ocomp) ) (:else (debug "compiletrec_tuple ignored generated code ocomp=" ocomp)) ) (list_append obodl oputn) )) (list_append obodl otouch) (debug "compiletrec_tuple final obodl=" obodl) )) (install_method class_normal_constructed_tuple_binding compile_letrec_fill compiletrec_tuple) ;; generate inside the body list the code for filling pair in letrecs (defun compiletrec_pair (recv obva obodl gcx sloc) (debug "compiletrec_pair recv=" recv " obva=" obva) (assert_msg "check recv" (is_a recv class_normal_constructed_pair_binding) recv) (assert_msg "check obva" (is_a obva class_objlocv) obva) (assert_msg "check obodl" (is_list obodl) obodl) (let ( (loc (or (get_field :nconsb_loc recv) sloc)) (nhead (get_field :npairb_head recv)) (ntail (get_field :npairb_tail recv)) (ohead (compile_obj nhead gcx)) (otail (if ntail (compile_obj ntail gcx))) (oputhead (instance class_objputpairhead :obi_loc loc :oputp_pair obva :oputp_head ohead)) (oputtail (if otail (instance class_objputpairtail :obi_loc loc :oputp_pair obva :oputp_tail otail))) (otouch (instance class_objtouch :obi_loc loc :otouch_val obva )) ) (debug "compiletrec_pair nhead=" nhead " ohead=" ohead " ntail=" ntail " otail=" otail) (if (or (is_not_a ohead class_objpurevalue) (is_a ohead class_objinstr)) (list_append obodl ohead) (debug "compiletrec_pair ohead ignored generated code ohead=" ohead)) (if (and otail (or (is_not_a otail class_objpurevalue) (is_a otail class_objinstr))) (list_append obodl otail) (debug "compiletrec_pair otail ignored generated code otail=" otail)) (list_append obodl oputhead) (if oputtail (list_append obodl oputtail)) (list_append obodl otouch) )) (install_method class_normal_constructed_pair_binding compile_letrec_fill compiletrec_pair) ;; generate inside the body list the code for filling pair in letrecs (defun compiletrec_list (recv obva obodl gcx sloc) (debug "compiletrec_list recv=" recv " obva=" obva) (assert_msg "check recv" (is_a recv class_normal_constructed_list_binding) recv) (assert_msg "check obva" (is_a obva class_objlocv) obva) (assert_msg "check obodl" (is_list obodl) obodl) (let ( (loc (or (get_field :nconsb_loc recv) sloc)) (nfirst (get_field :nlistb_first recv)) (nlast (get_field :nlistb_last recv)) (ofirst (if nfirst (compile_obj nfirst gcx))) (olast (if nlast (compile_obj nlast gcx))) (oputl (if (or ofirst olast) (instance class_objputlist :obi_loc loc :oputl_list obva :oputl_first ofirst :oputl_last olast ))) (otouch (instance class_objtouch :obi_loc loc :otouch_val obva )) ) (if (and ofirst (or (is_not_a ofirst class_objpurevalue) (is_a ofirst class_objinstr))) (list_append obodl ofirst) (debug "compiletrec_list ignored generated code ofirst=" ofirst) ) (if (and olast (or (is_not_a olast class_objpurevalue) (is_a olast class_objinstr))) (list_append obodl olast) (debug "compiletrec_list olast ignored generated code olast=" olast) ) (if oputl (progn (list_append obodl oputl) (list_append obodl otouch) )) )) (install_method class_normal_constructed_list_binding compile_letrec_fill compiletrec_list) ;; generate inside the body list the code for filling instance in letrecs (defun compiletrec_instance (recv obva obodl gcx sloc) (debug recv "compiletrec_instance recv=" recv " obva=" obva " obodl=" obodl) (assert_msg "check recv" (is_a recv class_normal_constructed_instance_binding) recv) (assert_msg "check obva" (is_a obva class_objlocv) obva) (assert_msg "check obodl" (is_list obodl) obodl) (let ( (loc (or (get_field :nconsb_loc recv) sloc)) (nslots (get_field :ninstb_slots recv)) (nclabind (get_field :ninstb_clabind recv)) (otouch (instance class_objtouch :obi_loc loc :otouch_val obva )) (clas (cond ( (is_a nclabind class_value_binding) (unsafe_get_field :vbind_value nclabind)) ( (is_a nclabind class_class_binding) (unsafe_get_field :cbind_class nclabind)) (:else (debug "compiletrec_instance bad nclabind=" nclabind) (assert_msg "unexpected class binding" () nclabind)))) (flds (get_field :class_fields clas)) ) (debug "compiletrec_instance clas=" clas " nslots=" nslots) (assert_msg "check clas" (is_a clas class_class) clas) (foreach_in_multiple (nslots) (curnslot :long slix) (debug "compiletrec_instance curnslot=" curnslot " slix=" slix) (if curnslot (let ( (curfld (multiple_nth flds slix)) (oslot (compile_obj curnslot gcx)) ) (debug "compiletrec_instance curfld=" curfld " oslot=" oslot) (if (or (is_not_a oslot class_objpurevalue) (is_a oslot class_objinstr)) (progn (if (>i slix 0) (list_append obodl otouch)) (list_append obodl oslot)) (debug "compiletrec_instance ignored generated code oslot=" oslot)) (let ( (oputs (instance class_objputslot :obi_loc loc :oslot_odata obva :oslot_offset (make_integerbox discr_integer slix) :oslot_field curfld :oslot_value oslot)) ) (debug "compiletrec_instance oputs=" oputs) (list_append obodl oputs) )))) (list_append obodl otouch) (debug "compiletrec_instance final obodl=" obodl) )) (install_method class_normal_constructed_instance_binding compile_letrec_fill compiletrec_instance) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; compile of LETREC (defun compilobj_nrep_letrec (rlet gcx) (debug "compilobj_nrep_letrec initial rlet=" rlet) (assert_msg "check rlet" (is_a rlet class_nrep_letrec) rlet) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc rlet)) (bnds (unsafe_get_field :nlet_bindings rlet)) (fillbnds (unsafe_get_field :nletrec_fill_bindings rlet)) (bodybnds (unsafe_get_field :nletrec_body_bindings rlet)) (:long nbbnds (multiple_length bnds)) (nlocsyms (unsafe_get_field :nletrec_locsyms rlet)) (:long nblocsym (multiple_length nlocsyms)) (tuploc (make_multiple discr_multiple nblocsym)) (nbdy (unsafe_get_field :nlet_body rlet)) (locmap (unsafe_get_field :gncx_locmap gcx)) (obodl (make_list discr_list)) (oepil (make_list discr_list)) (ofreelocs (make_list discr_list)) (obrout (get_field :gncx_objrout gcx)) (obcntletrec (get_field :obrout_cntletrec obrout)) (:long cntletrec (+i 1 (get_int obcntletrec))) (oallstruct (make_multiple discr_multiple nbbnds)) (namstr (let ( (nambuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst nambuf "meltletrec_") (add2sbuf_longdec nambuf cntletrec) (strbuf2string discr_verbatim_string nambuf) )) (oblock (instance class_objmultiallocblock :obi_loc loc :oblo_bodyl obodl :oblo_epil oepil :omalblo_allstruct oallstruct :omalblo_name namstr )) ) (debug "compilobj_nrep_letrec initial loc=" loc "\n.. nlocsyms=" nlocsyms "\n.. fillbnds=" fillbnds "\n.. bodybnds=" bodybnds "\n locmap=" locmap) (assert_msg "check fillbnds is list" (is_list_or_null fillbnds) fillbnds) (assert_msg "check bodybnds is list" (is_list_or_null bodybnds) bodybnds) (put_int obcntletrec cntletrec) (debug "compilobj_nrep_letrec updated obcntletrec=" obcntletrec) (foreach_in_multiple (nlocsyms) (curlocsym :long symix) (debug "compilobj_nrep_letrec curlocsym=" curlocsym " symix=" symix) (assert_msg "check curlocsym" (is_a curlocsym class_nrep_locsymocc) curlocsym) (let ( (curobva (get_free_objloctyped gcx (get_field :nocc_symb curlocsym) ctype_value)) (ocurclear (instance class_objclear :obi_loc loc :oclr_vloc curobva)) (cursbnd (multiple_nth bnds symix)) ) (debug "compilobj_nrep_letrec again curlocsym=" curlocsym " curobva=" curobva " cursbnd=" cursbnd " ocurclear=" ocurclear " symix=" symix) (multiple_put_nth tuploc symix curobva) (mapobject_put locmap cursbnd curobva) (list_append oepil ocurclear) (list_append ofreelocs curobva) ) ) ;; (debug "compilobj_nrep_letrec locmap=" locmap " oblock=" oblock " ofreelocs=" ofreelocs " bnds=" bnds) (foreach_in_multiple (bnds) (curbnd :long bndix) (debug "compilobj_nrep_letrec curbnd=" curbnd " bndix=" bndix) (let ( (obnd (compile_obj curbnd gcx)) ) (debug "compilobj_nrep_letrec obnd=" obnd) (multiple_put_nth oallstruct bndix obnd) (list_append obodl obnd) (debug "compilobj_nrep_letrec updated obodl=" obodl) ) ) ;; ;; maybe we should reserve the recobva before compiling nrecexp (debug "compilobj_nrep_letrec fillbnds" fillbnds) (assert_msg "check fillbnds" (is_list_or_null fillbnds) fillbnds) ;; first loop to reserve the recobva (foreach_pair_component_in_list (fillbnds) (curecpair curecbnd) (debug "compilobj_nrep_letrec get_free_objloc curecbnd=" curecbnd) (assert_msg "check curecbnd" (is_a curecbnd class_normal_let_binding) curecbnd) (let ( (rbder (unsafe_get_field :binder curecbnd)) (rcty (unsafe_get_field :letbind_type curecbnd)) (rloc (unsafe_get_field :letbind_loc curecbnd)) (recobva (get_free_objloctyped gcx rbder rcty)) ) (debug "compilobj_nrep_letrec current normbinding recobva=" recobva) ;; recobva can be nil when rcty is :void (if recobva (let ( (oreclear (instance class_objclear :obi_loc (or rloc loc) :oclr_vloc recobva )) ) (assert_msg "check recobva" (is_a recobva class_objlocv) recobva) (mapobject_put locmap curecbnd recobva) (debug "compilobj_nrep_letrec oreclear=" oreclear) (list_append oepil oreclear) (list_append ofreelocs recobva) )))) (debug "compilobj_nrep_letrec again locmap=" locmap " ofreelocs=" ofreelocs " fillbnds=" fillbnds) ;; ;; loop to compile the fillbindings (foreach_pair_component_in_list (fillbnds) (curecpair curfilbnd) (debug "compilobj_nrep_letrec compil curfilbnd=" curfilbnd) (assert_msg "check curfilbnd" (is_a curfilbnd class_normal_let_binding) curfilbnd) (let ( (rbder (unsafe_get_field :binder curfilbnd)) (rcty (unsafe_get_field :letbind_type curfilbnd)) (nrecexp (unsafe_get_field :letbind_expr curfilbnd)) (recobva (mapobject_get locmap curfilbnd)) ) (debug "compilobj_nrep_letrec current recbinding nrecexp=" nrecexp) (let ( (robnx (compile_obj nrecexp gcx)) (rnewob ()) ) (debug "compilobj_nrep_letrec robnx=" robnx) (if recobva (setq rnewob (put_objdest robnx recobva)) (setq rnewob robnx)) (debug "compilobj_nrep_letrec rnewob=" rnewob) (if (or (is_not_a rnewob class_objpurevalue) (is_a rnewob class_objinstr)) (list_append obodl rnewob) (debug "compilobj_nrep_letrec ignored generated code rnewob=" rnewob) ) )) ) ;;; (debug "compilobj_nrep_letrec after fillbinding obodl=" obodl) ;;; ;;; generate the fill of the letrec-ed constructions (foreach_in_multiple (bnds) (curbnd :long bndix) (let ( (obva (multiple_nth tuploc bndix)) ) (debug "compilobj_nrep_letrec again obva=" obva " curbnd=" curbnd " bndix=" bndix) (compile_letrec_fill curbnd obva obodl gcx loc) (debug "compilobj_nrep_letrec letrecfilled obodl=" obodl) )) ;; (debug "compilobj_nrep_letrec oallstruct=" oallstruct " obodl=" obodl) ;; loop to compile the bodybindings (foreach_pair_component_in_list (bodybnds) (cubdypair curbdybnd) (debug "compilobj_nrep_letrec compil curbdybnd=" curbdybnd) (assert_msg "check curbdybnd" (is_a curbdybnd class_normal_let_binding) curbdybnd) (let ( (rbder (unsafe_get_field :binder curbdybnd)) (rcty (unsafe_get_field :letbind_type curbdybnd)) (nbdyexp (unsafe_get_field :letbind_expr curbdybnd)) (bdyobva (get_free_objloctyped gcx rbder rcty)) (rloc (unsafe_get_field :letbind_loc curbdybnd)) ) (debug "compilobj_nrep_letrec body bdyobva="bdyobva " nbdyexp=" nbdyexp) (mapobject_put locmap curbdybnd bdyobva) (let ( (robnx (compile_obj nbdyexp gcx)) (rnewob ()) ) (if (and bdyobva rcty (!= rcty ctype_void)) (progn (list_append ofreelocs bdyobva) (setq rnewob (put_objdest robnx bdyobva)) ) (setq rnewob robnx)) (debug "compilobj_nrep_letrec rnewob=" rnewob) (if (or (is_not_a rnewob class_objpurevalue) (is_a rnewob class_objinstr)) (list_append obodl rnewob) (debug "compilobj_nrep_letrec ignored generated code rnewob=" rnewob) ) )) ) ;; ;; compile the body (debug "compilobj_nrep_letrec nbdy=" nbdy) (assert_msg "check nbdy" (is_multiple_or_null nbdy) nbdy) (foreach_in_multiple (nbdy) (curbdy :long bdix) (debug "compilobj_nrep_letrec curbdy=" curbdy " bdix=" bdix) (let ( (ocurb (compile_obj curbdy gcx)) ) (debug "compilobj_nrep_letrec ocurb=" ocurb) (list_append obodl ocurb))) (debug "compilobj_nrep_letrec final obodl=" obodl "\n.. ofreelocs=" ofreelocs) ;; should clear and free our objlocs... (foreach_pair_component_in_list (ofreelocs) (curlpair curlocva) (debug "compilobj_nrep_letrec disposing curlocva=" curlocva) (assert_msg "check curlocva" (is_a curlocva class_objlocv) curlocva) (let ( (oclear (instance class_objclear :obi_loc loc :oclr_vloc curlocva)) ) (list_append oepil oclear) (debug "compilobj_nrep_letrec oclear=" oclear " \n..disposing curlocva=" curlocva) (dispose_objloc curlocva gcx) (debug "compilobj_nrep_letrec final oclear=" oclear) )) ;; (debug "compilobj_nrep_letrec final oblock=" oblock "\n.. oallstruct= "oallstruct "\n.. gcx=" gcx "\n") oblock )) (install_method class_nrep_letrec compile_obj compilobj_nrep_letrec) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_citeration (nciter gcx) (assert_msg "check nciter" (is_a nciter class_nrep_citeration) nciter) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_citeration nciter=" nciter) (let ( (loc (unsafe_get_field :nrep_loc nciter)) (obrout (unsafe_get_field :gncx_objrout gcx)) (citer (unsafe_get_field :nciter_citerator nciter)) (nlocbind (unsafe_get_field :nciter_locbindings nciter)) (nchkbef (unsafe_get_field :nciter_chunkbefore nciter)) (nstatocc (let ( (ns (unsafe_get_field :nciter_statocc nciter)) ) (debug "compilobj_nrep_citeration nstatocc=" ns) (assert_msg "check nstatocc" (is_a ns class_nrep_locsymocc) ns) ns)) (nbody (unsafe_get_field :nciter_body nciter)) (nbodbind (unsafe_get_field :nciter_bodbindings nciter)) (nchkaft (unsafe_get_field :nciter_chunkafter nciter)) (nstatbind (let ( (bi (unsafe_get_field :nocc_bind nstatocc)) ) (assert_msg "check nstatbind" (is_a bi class_normal_let_binding) bi) bi)) (nstatsy (unsafe_get_field :binder nstatbind)) (ostat (get_free_objloctyped gcx nstatsy (unsafe_get_field :nocc_ctyp nstatocc))) (obodl (make_list discr_list)) (oepil (make_list discr_list)) (ocblock (instance class_objciterblock :obi_loc loc :oblo_bodyl obodl :oblo_epil oepil :obciter_citer citer :obciter_before () :obciter_after () )) (locmap (unsafe_get_field :gncx_locmap gcx)) ) (debug "compilobj_nrep_citeration ostat=" ostat " nlocbind=" nlocbind) (assert_msg "check citer" (is_a citer class_citerator) citer) (assert_msg "check locmap" (is_mapobject locmap) locmap) (assert_msg "check nlocbind" (is_multiple_or_null nlocbind) nlocbind) (multiple_every nlocbind (lambda (nlbnd :long ix) (debug "compilobj_nrep_citeration current nlocbinding nlbnd=" nlbnd " ix=" ix) (assert_msg "check nlbnd in compilobj_nrep_citeration" (is_a nlbnd class_normal_let_binding) nlbnd) (let ( (bder (unsafe_get_field :binder nlbnd)) (cty (unsafe_get_field :letbind_type nlbnd)) (nexp (unsafe_get_field :letbind_expr nlbnd)) (oblva (get_free_objloctyped gcx bder cty)) ) (debug "compilobj_nrep_citeration current local bder=" bder " oblva=" oblva) (if (!= cty ctype_void) (let ( (oclr (instance class_objclear :obi_loc loc :oclr_vloc oblva) ) ) (list_append oepil oclr) (mapobject_put locmap nlbnd oblva) (debug "compilobj_nrep_citeration added clear for nlbnd=" nlbnd) )) ))) (debug "compilobj_nrep_citeration start ocblock=" ocblock) (let ( (boxcntciter (unsafe_get_field :obrout_cntciter obrout)) (:long cnt (+i 1 (get_int boxcntciter))) (statstr (let ( (sbu (make_strbuf discr_strbuf)) ) (put_int boxcntciter cnt) (add2sbuf_strconst sbu "meltcit") (add2sbuf_longdec sbu cnt) (add2sbuf_strconst sbu "__") (add2sbuf_cident sbu (unsafe_get_field :named_name nstatsy)) (strbuf2string discr_verbatim_string sbu) )) ) (unsafe_put_fields ocblock :obciter_before (multiple_map nchkbef (lambda (cbef :long ix) (cond ((is_string cbef) cbef) ((== cbef nstatocc) statstr) (:else (let ( (obef (compile_obj cbef gcx)) ) obef ))))) :obciter_after (multiple_map nchkaft (lambda (caft :long ix) (cond ((is_string caft) caft) ((== caft nstatocc) statstr) (:else (let ( (oaft (compile_obj caft gcx)) ) oaft ))))) ) ) (debug "compilobj_nrep_citeration filled before&after chunks ocblock=" ocblock) (assert_msg "check nbodbind" (is_list_or_null nbodbind) nbodbind) (list_every nbodbind (lambda (nbbnd :long ix) (assert_msg "check nbbnd in compilobj_nrep_citeration" (is_a nbbnd class_normal_let_binding) nbbnd) (let ( (bder (unsafe_get_field :binder nbbnd)) (cty (unsafe_get_field :letbind_type nbbnd)) (nexp (unsafe_get_field :letbind_expr nbbnd)) (obbva (get_free_objloctyped gcx bder cty)) ) (if (!= cty ctype_void) (let ( (oclr (instance class_objclear :obi_loc loc :oclr_vloc obbva)) ) (list_append oepil oclr) (mapobject_put locmap nbbnd obbva) ) ) (let ( (ocur (compile_obj nexp gcx)) ) (if (!= cty ctype_void) (progn (let ( (newocur (put_objdest ocur obbva)) ) (if newocur (list_append obodl newocur) (list_append obodl ocur)) )) (progn (list_append obodl ocur) ))) ))) (debug "compilobj_nrep_citeration nbody=" nbody) (multiple_every nbody (lambda (ncurbod :long ix) (let ( (ocbod (compile_obj ncurbod gcx)) ) (list_append obodl ocbod) ))) (debug "compilobj_nrep_citeration final ocblock=" ocblock) (return ocblock) ) ) (install_method class_nrep_citeration compile_obj compilobj_nrep_citeration) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a setq (defun compilobj_nrep_setq (nsq gcx) (assert_msg "check nsq" (is_a nsq class_nrep_setq) nsq) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_setq nsq=" nsq) (let ( (loc (unsafe_get_field :nrep_loc nsq)) (var (unsafe_get_field :nstq_var nsq)) (exp (unsafe_get_field :nstq_exp nsq)) ) (debug "compilobj_nrep_setq loc=" loc " var=" var " exp=" exp) (let ( (cexp (compile_obj exp gcx)) (cvar (compile_obj var gcx)) (cres (put_objdest cexp cvar)) ) (debug "compilobj_nrep_setq loc=" loc " left var=" var " cvar=" cvar "\n right exp=" exp " cexp=" cexp " cres=" cres) (and (is_a cres class_objinstr) (null (unsafe_get_field :obi_loc cres)) (unsafe_put_fields cres :obi_loc loc)) (debug "compilobj_nrep_setq cres=" cres) cres ))) (install_method class_nrep_setq compile_obj compilobj_nrep_setq) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a progn (defun compilobj_nrep_progn (npro gcx) (debug "compilobj_nrep_progn npro=" npro) (assert_msg "check npro" (is_a npro class_nrep_progn) npro) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc npro)) (nseq (unsafe_get_field :nprogn_seq npro)) (nlast (unsafe_get_field :nprogn_last npro)) (bodyl (make_list discr_list)) (oblock (instance class_objplainblock :obi_loc loc :oblo_bodyl bodyl ;; :oblo_epil is left null )) ) (debug "compilobj_nrep_progn nseq=" nseq) (foreach_in_multiple (nseq) (ncomp :long ix) (debug "compilobj_nrep_progn ncomp=" ncomp "\n ix#" ix "\n in npro=" npro) (let ( (ocomp (compile_obj ncomp gcx)) ) (debug "compilobj_nrep_progn ocomp=" ocomp "\n ix#" ix) (list_append bodyl ocomp) )) (debug "compilobj_nrep_progn nlast=" nlast) (let ( (olast (compile_obj nlast gcx)) ) (debug "compilobj_nrep_progn olast=" olast) (list_append bodyl olast)) ;; (debug "compilobj_nrep_progn return oblock=" oblock "\n from npro=" npro) (return oblock) )) (install_method class_nrep_progn compile_obj compilobj_nrep_progn) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a multacc [data multiple accessor] (defun compilobj_nrep_multacc (nma gcx) (assert_msg "check nma" (is_a nma class_nrep_multacc) nma) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_multacc nma=" nma) (let ( (loc (unsafe_get_field :nrep_loc nma)) (mul (unsafe_get_field :naccm_mul nma)) (ix (unsafe_get_field :naccm_ix nma)) (cmul (compile_obj mul gcx)) ;; we factor the case when the tuple access cannot be done at ;; compile time (makecompute (lambda () (let ( (tcont (tuple (make_stringconst discr_verbatim_string "/*multacc*/(melt_multiple_nth((") cmul (make_stringconst discr_verbatim_string "), (") ix (make_stringconst discr_verbatim_string ")))") )) (res (instance class_objexpv :obv_type ctype_value :obx_cont tcont)) ) (debug "compilobj_nrep_multacc makecompute res=" res) res )) ) ) (debug "compilobj_nrep_multacc cmul=" cmul " nma=" nma) (if (and (is_a cmul class_objinitmultiple) (is_integerbox ix)) (let ( (comptup (unsafe_get_field :oim_tupval cmul)) ) (if (is_multiple comptup) (let ( (curval (multiple_nth comptup (get_int ix))) ) (debug "compilobj_nrep_multacc returning curval=" curval) (return curval) ) (makecompute) )) (makecompute) ))) (install_method class_nrep_multacc compile_obj compilobj_nrep_multacc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a fieldacc [data field accessor] (defun compilobj_nrep_fieldacc (nfa gcx) (assert_msg "check nfa" (is_a nfa class_nrep_fieldacc) nfa) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_fieldacc nfa=" nfa) (let ( (loc (unsafe_get_field :nrep_loc nfa)) (obj (unsafe_get_field :naccf_obj nfa)) (fld (unsafe_get_field :naccf_fld nfa)) (:long fldoff (get_int fld)) (boxfldoff (make_integerbox discr_integer fldoff)) (cobj (compile_obj obj gcx)) ;; we factor the case when the field access cannot be done at ;; compile time (makecompute (lambda () (let ( (tcont (tuple (make_stringconst discr_verbatim_string "/*fieldacc*/(melt_field_object((melt_ptr_t)(") cobj (make_stringconst discr_verbatim_string "),") boxfldoff (make_stringconst discr_verbatim_string "))") )) (res (instance class_objexpv :obv_type ctype_value :obx_cont tcont)) ) (debug "compilobj_nrep_fieldacc makecompute res=" res) res ))) ) (assert_msg "compilobj_nrep_fieldacc check fld" (is_a fld class_field) fld) (debug "compilobj_nrep_fieldacc cobj=" cobj " fld=" fld) (if (is_a cobj class_objinitobject) (let ( (cdata (unsafe_get_field :oie_data cobj)) ) (if (is_a cdata class_nrep_datainstance) (let ( (slotup (unsafe_get_field :ninst_slots cdata)) (ourslot (multiple_nth slotup fldoff)) ) (if (is_a ourslot class_nrep_bound_data) (let ( (cslot (compile_obj ourslot gcx)) ) (debug "compilobj_nrep_fieldacc returning cslot=" cslot) (return cslot)) (return (makecompute)))) (return (makecompute))) ) (return (makecompute)) ))) (install_method class_nrep_fieldacc compile_obj compilobj_nrep_fieldacc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile an unsafe get field access (defun compilobj_nrep_unsafe_get_field (nugf gcx) (assert_msg "check nugf" (is_a nugf class_nrep_unsafe_get_field) nugf) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_unsafe_get_field nugf=" nugf) (let ( (loc (unsafe_get_field :nrep_loc nugf)) (nobj (unsafe_get_field :nuget_obj nugf)) (nfield (unsafe_get_field :nuget_field nugf)) (dlist (make_list discr_list)) (oobj (compile_obj nobj gcx)) (ogetslot (instance class_objgetslot :obi_loc loc :obdi_destlist dlist :ogetsl_obj oobj :ogetsl_field nfield)) ) (return ogetslot) )) (install_method class_nrep_unsafe_get_field compile_obj compilobj_nrep_unsafe_get_field) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile an unsafe put fields (defun compilobj_nrep_unsafe_put_fields (nupf gcx) (assert_msg "check nupf" (is_a nupf class_nrep_unsafe_put_fields) nupf) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_unsafe_put_fields nupf=" nupf) (let ( (loc (unsafe_get_field :nrep_loc nupf)) (nobj (unsafe_get_field :nuput_obj nupf)) (nfldass (unsafe_get_field :nuput_fields nupf)) (obodl (make_list discr_list)) (oepil (make_list discr_list)) (oblock (instance class_objplainblock :obi_loc loc :oblo_bodyl obodl :oblo_epil oepil)) (oobj (compile_obj nobj gcx)) ) (foreach_in_multiple (nfldass) (nfa :long ix) (assert_msg "check nfa" (is_a nfa class_nrep_fieldassign) nfa) (let ( (aloc (unsafe_get_field :nrep_loc nfa)) (afield (unsafe_get_field :nfla_field nfa)) (aval (unsafe_get_field :nfla_val nfa)) (:long aoff (get_int afield)) ) (assert_msg "check afield" (is_a afield class_field) afield) (let ( (oval (compile_obj aval gcx)) (opuf (instance class_objputslot :obi_loc (if aloc aloc loc) :oslot_odata oobj :oslot_field afield :oslot_offset (make_integerbox discr_integer aoff) :oslot_value oval)) ) (debug "compilobj_nrep_unsafe_put_fields opuf=" opuf) (assert_msg "compilobj_nrep_unsafe_put_fields check oval not nrep" (is_not_a oval class_nrep) oval) (list_append obodl opuf)) )) (list_append obodl (instance class_objtouch :obi_loc loc :otouch_val oobj)) ;; emit debugtrace of written object (list_append obodl (instance class_objdbgtracewriteobj :obi_loc loc :obdtw_writtenobj oobj :obdtw_message '"put-fields")) ;; add the updated obj to the block (list_append obodl oobj) (return oblock) )) (install_method class_nrep_unsafe_put_fields compile_obj compilobj_nrep_unsafe_put_fields) ;;;; (defun compilobj_nrep_modulevarocc (nsvar gcx) (debug "compilobj_nrep_modulevarocc nsvar=" nsvar) (assert_msg "check nsvar" (is_a nsvar class_nrep_modulevarocc) nsvar) (let ( (nvbind (get_field :nmodvar_bind nsvar)) ) (assert_msg "check nvbind" (is_a nvbind class_normal_module_variable_binding) nvbind) (let ( (ofetch (instance class_objfetchmodvar :obv_type ctype_value :obfetchmodvar_bind nvbind)) ) (debug "compilobj_nrep_modulevarocc ofetch=" ofetch) (return ofetch) ))) (install_method class_nrep_modulevarocc compile_obj compilobj_nrep_modulevarocc) ;;;; (defun compilobj_nrep_putmodulevar (npvar gcx) (debug "compilobj_nrep_putmodulevar npvar=" npvar) (assert_msg "check npvar" (is_a npvar class_nrep_putmodulevar) npvar) (let ( (loc (unsafe_get_field :nrep_loc npvar)) (destvar (unsafe_get_field :nputmod_destvar npvar)) (nval (unsafe_get_field :nputmod_value npvar)) ) (debug "compilobj_nrep_putmodulevar destvar=" destvar " nval=" nval) (assert_msg "check destvar" (is_a destvar class_nrep_modulevarocc) destvar) (let ( (modvarbind (get_field :nmodvar_bind destvar)) (oval (compile_obj nval gcx)) ) (assert_msg "check modvarbind" (is_a modvarbind class_normal_module_variable_binding) modvarbind) (let ( (oput (instance class_objputmodvar :obi_loc loc :obputmodvar_bind modvarbind :obputmodvar_val oval)) ) (debug "compilobj_nrep_putmodulevar result oput=" oput) (return oput) )))) (install_method class_nrep_putmodulevar compile_obj compilobj_nrep_putmodulevar) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_checksignal (nchint gcx) (debug "compilobj_nrep_checksignal nchint=" nchint) (assert_msg "check nchint" (is_a nchint class_nrep_checksignal) nchint) (let ( (nloc (unsafe_get_field :nrep_loc nchint)) (ochint (instance class_objchecksignal :obi_loc nloc)) ) (debug "compilobj_nrep_checksignal ochint=" ochint) (return ochint) )) (install_method class_nrep_checksignal compile_obj compilobj_nrep_checksignal) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile an unsafe nth component (defun compilobj_nrep_unsafe_nth_component (nunc gcx) (assert_msg "check nunc" (is_a nunc class_nrep_unsafe_nth_component) nunc) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_unsafe_nth_component nunc=" nunc) (let ( (nloc (unsafe_get_field :nrep_loc nunc)) (ntup (unsafe_get_field :nunth_tuple nunc)) (nidx (unsafe_get_field :nunth_index nunc)) (otup (compile_obj ntup gcx)) (oidx (compile_obj nidx gcx)) (ounc (make_objcompute nloc ctype_value ##{/*unsafenthcomp*/((meltmultiple_ptr_t)($OTUP))->tabval[$OIDX]}# )) ) (debug "compilobj_nrep_unsafe_nth_component otup=" otup " oidx=" oidx " ounc=" ounc) (return ounc) )) (install_method class_nrep_unsafe_nth_component compile_obj compilobj_nrep_unsafe_nth_component) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a simple application (defun compilobj_nrep_apply (napp gcx) (debug "compilobj_nrep_apply napp=" napp) (assert_msg "check napp" (is_a napp class_nrep_apply) napp) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc napp)) (fun (unsafe_get_field :napp_fun napp)) (args (unsafe_get_field :nexpr_args napp)) ) (let ( (oclos (compile_obj fun gcx)) (oargs (multiple_map args (lambda (comp :long ix) (let ( (ocomp (compile_obj comp gcx)) ) (assert_msg "compilobj_nrep_apply check ocomp not objinstr" (is_not_a ocomp class_objinstr) ocomp) ocomp)))) (dlist (make_list discr_list)) (oapp (instance class_objapply :obi_loc loc :obdi_destlist dlist :obapp_clos oclos :obapp_args oargs)) ) (debug "compilobj_nrep_apply return oapp=" oapp) oapp ))) (install_method class_nrep_apply compile_obj compilobj_nrep_apply) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a hook call (defun compilobj_nrep_hook_call (nhkcall gcx) (debug "compilobj_nrep_hook_call nhkcall=" nhkcall) (assert_msg "check nhkcall" (is_a nhkcall class_nrep_hook_call) nhkcall) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc nhkcall)) (nhkname (unsafe_get_field :nhook_name nhkcall)) (nhkctype (unsafe_get_field :nexpr_ctyp nhkcall)) (nhook (unsafe_get_field :nhook_called nhkcall)) (nargs (unsafe_get_field :nexpr_args nhkcall)) (nouts (unsafe_get_field :nhook_outs nhkcall)) (nhkdescr (unsafe_get_field :nhook_descr nhkcall)) (modctx (unsafe_get_field :gncx_modulcontext gcx)) (mhookdict (get_field :mocx_hookdict modctx)) ) (debug "compilobj_nrep_hook_call nhook=" nhook "\n.. nargs=" nargs "\n.. nouts=" nouts "\n.. nhkname=" nhkname "\n.. nhkdescr=" nhkdescr "\n.. mhookdict=" mhookdict) (let ( (ohook (let ( (oh (compile_obj nhook gcx)) ) (debug "compilobj_nrep_hook_call ohook=" oh) oh)) (oargs (multiple_map nargs (lambda (ncomp :long ix) (debug "compilobj_nrep_hook_call ncomp=" ncomp " ix#" ix) (let ( (ocomp (compile_obj ncomp gcx)) ) (debug "compilobj_nrep_hook_call ocomp=" ocomp) (assert_msg "compilobj_nrep_hook_call check ocomp not objinstr" (is_not_a ocomp class_objinstr) ocomp) ocomp)))) (oouts (multiple_map nouts (lambda (nvar :long oix) (debug "compilobj_nrep_hook_call nvar=" nvar " oix#" oix) (let ( (ovar (compile_obj nvar gcx)) ) (debug "compilobj_nrep_hook_call ovar=" ovar) ovar)))) ) (debug "compilobj_nrep_hook_call ohook=" ohook " oargs=" oargs " oouts=" oouts) (let ( (commastr (make_stringconst discr_verbatim_string ", ")) (commampstr (make_stringconst discr_verbatim_string ", &")) (rhkname (clone_with_discriminant nhkname discr_verbatim_string)) (addins (lambda (alist) (foreach_in_multiple (oargs) (curarg :long argix) (list_append alist commastr) (list_append alist curarg) ) )) (addouts (lambda (alist) (foreach_in_multiple (oouts) (curout :long outix) (list_append alist commampstr) (list_append alist curout) ) )) (ohkcall (make_objlocatedexp loc nhkctype ##{ /*hookcall*/ melthook_$RHKNAME ((melt_ptr_t) $OHOOK$ADDINS$ADDOUTS) }# )) ) (when nhkdescr (debug "compilobj_nrep_hook_call nhkdescr=" nhkdescr "\n.. nhkname=" nhkname "\n.. mhookdict=" mhookdict) (assert_msg "check nhkdescr" (is_a nhkdescr class_hook_descriptor) nhkdescr) (let ( (oldescr (mapstring_getstr mhookdict nhkname)) ) (debug "compilobj_nrep_hook_call nhkdescr=" nhkdescr " oldescr=" oldescr) (if oldescr (assert_msg "check oldescr" (== oldescr nhkdescr) oldescr) (progn (mapstring_putstr mhookdict nhkname nhkdescr) (debug "compilobj_nrep_hook_call updated mhookdict=" mhookdict) )))) (debug "compilobj_nrep_hook_call ohkcall=" ohkcall) (return ohkcall) )))) (install_method class_nrep_hook_call compile_obj compilobj_nrep_hook_call) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_multiapply (nmapp gcx) (assert_msg "check napp" (is_a nmapp class_nrep_multiapply) nmapp) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_multiapply nmapp=" nmapp) (let ( (loc (unsafe_get_field :nrep_loc nmapp)) (rbinds (unsafe_get_field :nmulapp_bindings nmapp)) (fun (unsafe_get_field :napp_fun nmapp)) (args (unsafe_get_field :nexpr_args nmapp)) (nbody (unsafe_get_field :nmulapp_body nmapp)) (locmap (unsafe_get_field :gncx_locmap gcx)) (:long nbres (multiple_length rbinds)) (reslocs (multiple_map rbinds (lambda (bind :long ix) (assert_msg "compilobj_nrep_multiapply check bind" (is_a bind class_formal_binding) bind) (let ( (bder (unsafe_get_field :binder bind)) (cty (unsafe_get_field :fbind_type bind)) (obva (get_free_objloctyped gcx bder cty)) ) (assert_msg "compilobj_nrep_multiapply check cty" (is_a cty class_ctype) cty) ;; link nlbnd to obva in locmap (if obva (mapobject_put locmap bind obva)) obva )))) (obodl (make_list discr_list)) (oepil (make_list discr_list)) (oblock (instance class_objplainblock :obi_loc loc :oblo_bodyl obodl :oblo_epil oepil)) (oxres (if (>i nbres 1) (make_multiple discr_multiple (-i nbres 1)) ())) (firstres (multiple_nth reslocs 0)) (ofun (compile_obj fun gcx)) (reslist (make_list discr_list)) (oargs (multiple_map args (lambda (comp :long ix) (compile_obj comp gcx)))) (obody (compile_obj nbody gcx)) (omapp (instance class_objmultiapply :obi_loc loc :obdi_destlist reslist :obapp_clos (compile_obj fun gcx) :obapp_args oargs :obmultapp_xres oxres)) ) (if firstres (list_append reslist firstres)) ;; add every compiled argument to the resulting block unless it is a pure value (foreach_in_multiple (oargs) (ocurarg :long ix) (if (and ocurarg (or (is_not_a ocurarg class_objpurevalue) (is_a ocurarg class_objinstr))) (list_append obodl ocurarg))) ;; add the multiapply to the block (list_append obodl omapp) ;; add the compiled body to the block (list_append obodl obody) ;; add the clearing of each result to epilog (foreach_in_multiple (reslocs) (rloc :long ix) (if (>i ix 0) (let ( (oclear (instance class_objclear :obi_loc loc :oclr_vloc rloc)) ) (list_append oepil oclear) (multiple_put_nth oxres (-i ix 1) rloc) ))) ;; dispose the local bindings (foreach_in_multiple (rbinds) (bind :long ix) (dispose_bnd_obj bind gcx)) (debug "compilobj_nrep_multiapply final oblock=" oblock) oblock )) (install_method class_nrep_multiapply compile_obj compilobj_nrep_multiapply) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a simple message send (defun compilobj_nrep_msend (nsnd gcx) (assert_msg "check nsnd" (is_a nsnd class_nrep_msend) nsnd) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc nsnd)) (nsel (unsafe_get_field :nsend_sel nsnd)) (nrecv (unsafe_get_field :nsend_recv nsnd)) (nargs (unsafe_get_field :nexpr_args nsnd)) ) (debug "compilobj_nrep_msend nsnd=" nsnd) (assert_msg "check nrecv" (is_object nrecv) nrecv) (let ( (osel (compile_obj nsel gcx)) (orecv (compile_obj nrecv gcx)) (oargs (multiple_map nargs (lambda (ncurarg :long ix) (debug "compilobj_nrep_msend ncurarg=" ncurarg " ix=" ix) (let ( (ocurarg (compile_obj ncurarg gcx)) ) (debug "compilobj_nrep_msend ocurarg=" ocurarg) (assert_msg "check ocurarg not tuple" (not (is_multiple ocurarg)) ocurarg) ocurarg )))) (osend (instance class_objmsend :obi_loc loc :obdi_destlist (make_list discr_list) :obmsnd_sel osel :obmsnd_recv orecv :obmsnd_args oargs )) ) (debug "compilobj_nrep_msend osend=" osend) (assert_msg "check orecv" (is_object orecv) orecv) osend ))) (install_method class_nrep_msend compile_obj compilobj_nrep_msend) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a multiresult message send (defun compilobj_nrep_multimsend (nmsnd gcx) (assert_msg "check nmsnd" (is_a nmsnd class_nrep_multimsend) nmsnd) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_multimsend nmsnd=" nmsnd) (let ( (loc (unsafe_get_field :nrep_loc nmsnd)) (rbinds (unsafe_get_field :nmulsend_bindings nmsnd)) (nbody (unsafe_get_field :nmulsend_body nmsnd)) ; a single normalized expression (nsel (unsafe_get_field :nsend_sel nmsnd)) (nrecv (unsafe_get_field :nsend_recv nmsnd)) (nargs (unsafe_get_field :nexpr_args nmsnd)) (locmap (unsafe_get_field :gncx_locmap gcx)) (:long nbres (multiple_length rbinds)) (reslocs (multiple_map rbinds (lambda (bind :long ix) (assert_msg "compilobj_nrep_multimsend check bind" (is_a bind class_formal_binding) bind) (let ( (bder (unsafe_get_field :binder bind)) (cty (unsafe_get_field :fbind_type bind)) (obva (get_free_objloctyped gcx bder cty)) ) (assert_msg "compilobj_nrep_multimsend check cty" (is_a cty class_ctype) cty) ;; link nlbnd to obva in locmap (if obva (mapobject_put locmap bind obva)) obva )))) (oxres (if (>i nbres 1) (make_multiple discr_multiple (-i nbres 1)))) (firstres (multiple_nth reslocs 0)) (osel (compile_obj nsel gcx)) (reslist (make_list discr_list)) (orecv (compile_obj nrecv gcx)) (oargs (multiple_map nargs (lambda (comp :long ix) (compile_obj comp gcx)))) (obody (compile_obj nbody gcx)) (obodl (make_list discr_list)) (oepil (make_list discr_list)) (oblock (instance class_objplainblock :obi_loc loc :oblo_bodyl obodl :oblo_epil oepil)) (omsend (instance class_objmultimsend :obi_loc loc :obdi_destlist reslist :obmsnd_sel osel :obmsnd_recv orecv :obmsnd_args oargs :obmultsnd_xres oxres)) ) (assert_msg "check orecv" (is_object orecv) orecv) (if firstres (list_append reslist firstres)) ;; add every compiled argument to the resulting block unless it is a pure value (foreach_in_multiple (oargs) (ocurarg :long ix) (if (and ocurarg (or (is_not_a ocurarg class_objpurevalue) (is_a ocurarg class_objinstr))) (list_append obodl ocurarg))) ;; add the multisend to the block (list_append obodl omsend) ;; add the compiled body to the block (list_append obodl obody) ;; add the clearing of each result to epilog (multiple_every reslocs (lambda (rloc :long ix) (if (>i ix 0) (let ( (oclear (instance class_objclear :obi_loc loc :oclr_vloc rloc)) ) (list_append oepil oclear) (multiple_put_nth oxres (-i ix 1) rloc))))) ;; dispose the local bindings (multiple_every rbinds (lambda (bind :long ix) (dispose_bnd_obj bind gcx))) (debug "compilobj_nrep_multimsend final oblock=" oblock) oblock )) (install_method class_nrep_multimsend compile_obj compilobj_nrep_multimsend) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; compile bindings (defun compilobj_any_binding (bind gcx) (assert_msg "check bind" (is_a bind class_any_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_any_binding bind=" bind) (outcstring_err "* compilobj unimplemented receiver binding class ") (let ( (discr (discrim bind)) ) (outstr_err (unsafe_get_field :named_name discr))) (outnewline_err) (assert_msg "@@compile_obj should be implemented in anybinding-s subclasses" () bind)) (install_method class_any_binding compile_obj compilobj_any_binding) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; compile value bindings (defun compilobj_value_binding (bind gcx) (assert_msg "check bind" (is_a bind class_value_binding) bind) (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx) (debug "compilobj_value_binding bind=" bind) (let ( (sym (get_field :binder bind)) (importmap (get_field :igncx_importmap gcx)) (olocv (mapobject_get importmap sym)) ) (debug "compilobj_value_binding olocv=" olocv " importmap=" importmap) (assert_msg "check olocv" (is_a olocv class_objlocv) olocv) (return olocv) ) ) (install_method class_value_binding compile_obj compilobj_value_binding) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_fixed_binding (bind gcx) (assert_msg "check bind" (is_a bind class_fixed_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_fixed_binding bind=" bind) (let ( (sbdata (unsafe_get_field :fixbind_data bind)) (osdata (compile_obj sbdata gcx)) ) (debug "compilobj_fixed_binding sbdata=" sbdata " osdata=" osdata) (return osdata) ) ) (install_method class_fixed_binding compile_obj compilobj_fixed_binding) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_normal_let_binding (bind gcx) (assert_msg "check bind" (is_a bind class_normal_let_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_normal_let_binding bind=" bind) (let ( (nexpr (unsafe_get_field :letbind_expr bind)) (ctyp (unsafe_get_field :letbind_type bind)) (bnder (unsafe_get_field :binder bind)) (oexpr (compile_obj nexpr gcx)) ) (debug "compilobj_normal_let_binding oexpr=" oexpr) (assert_msg "compilobj_normal_let_binding got here" () bind oexpr) (return oexpr) ) ) (install_method class_normal_let_binding compile_obj compilobj_normal_let_binding) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_conslambdabind (bind gcx) (assert_msg "check bind" (is_a bind class_normal_constructed_lambda_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_conslambdabind bind=" bind) (let ( (symb (unsafe_get_field :binder bind)) (loc (unsafe_get_field :nconsb_loc bind)) (ndiscr (unsafe_get_field :nconsb_discr bind)) (nclosed (unsafe_get_field :nlambdab_nclosed bind)) (ndatarout (unsafe_get_field :nlambdab_datarout bind)) (nconstrout (unsafe_get_field :nlambdab_constrout bind)) (nletrec (unsafe_get_field :nconsb_nletrec bind)) (odiscr (compile_obj ndiscr gcx)) (nambuf (make_strbuf discr_strbuf)) (nlocsyms (get_field :nletrec_locsyms nletrec)) (:long bindnum (get_int bind)) (:long nbclosed (multiple_length nclosed)) (locsymocc (multiple_nth nlocsyms bindnum)) ) (let ( (orout (compile_obj nconstrout gcx)) (oloc (compile_obj locsymocc gcx)) ) (add2sbuf_strconst nambuf "rclo_") (add2sbuf_longdec nambuf bindnum) (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name symb)) (if (is_a symb class_cloned_symbol) (progn (add2sbuf_strconst nambuf "_x") (add2sbuf_longdec nambuf (get_int (get_field :csym_urank symb))))) (let ( (iniclos (instance class_objinitclosure :obv_type ctype_value :oie_discr odiscr :oie_locvar oloc :oie_cname (strbuf2string discr_string nambuf) :oiclo_rout orout )) ) (put_int iniclos nbclosed) (debug "compilobj_conslambdabind returning iniclos=" iniclos) iniclos )))) (install_method class_normal_constructed_lambda_binding compile_obj compilobj_conslambdabind) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_constuplebind (bind gcx) (debug "compilobj_constuplebind bind=" bind) (assert_msg "check bind" (is_a bind class_normal_constructed_tuple_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (symb (unsafe_get_field :binder bind)) (nloc (unsafe_get_field :nconsb_loc bind)) (ndiscr (unsafe_get_field :nconsb_discr bind)) (nletrec (unsafe_get_field :nconsb_nletrec bind)) (ntupb (unsafe_get_field :ntupb_comp bind)) (odiscr (compile_obj ndiscr gcx)) (nambuf (make_strbuf discr_strbuf)) (nletrec (unsafe_get_field :nconsb_nletrec bind)) (nlocsyms (get_field :nletrec_locsyms nletrec)) (:long bindnum (get_int bind)) (:long lentup (multiple_length ntupb)) (locsymocc (multiple_nth nlocsyms bindnum)) ) (add2sbuf_strconst nambuf "rtup_") (add2sbuf_longdec nambuf bindnum) (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name symb)) (if (is_a symb class_cloned_symbol) (progn (add2sbuf_strconst nambuf "_x") (add2sbuf_longdec nambuf (get_int (get_field :csym_urank symb))))) (let ( (oloc (compile_obj locsymocc gcx)) (tupval (make_multiple discr_multiple lentup)) (initup (instance class_objinitmultiple :obv_type ctype_value :oie_discr odiscr :oie_locvar oloc :oie_cname (strbuf2string discr_string nambuf) :oim_tupval tupval )) ) (put_int initup lentup) (debug "compilobj_constuplebind result initup=" initup) initup ) )) (install_method class_normal_constructed_tuple_binding compile_obj compilobj_constuplebind) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_conspairbind (bind gcx) (debug "compilobj_conspairbind bind=" bind) (assert_msg "check bind" (is_a bind class_normal_constructed_pair_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (symb (unsafe_get_field :binder bind)) (nloc (unsafe_get_field :nconsb_loc bind)) (ndiscr (unsafe_get_field :nconsb_discr bind)) (nletrec (unsafe_get_field :nconsb_nletrec bind)) (nhead (unsafe_get_field :npairb_head bind)) (ntail (unsafe_get_field :npairb_tail bind)) (nlocsyms (get_field :nletrec_locsyms nletrec)) (odiscr (compile_obj ndiscr gcx)) (nambuf (make_strbuf discr_strbuf)) (:long bindnum (get_int bind)) (locsymocc (multiple_nth nlocsyms bindnum)) ) (assert_msg "check nletrec" nletrec) (add2sbuf_strconst nambuf "rpair_") (add2sbuf_longdec nambuf bindnum) (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name symb)) (if (is_a symb class_cloned_symbol) (progn (add2sbuf_strconst nambuf "_x") (add2sbuf_longdec nambuf (get_int (get_field :csym_urank symb))))) (let ( (oloc (compile_obj locsymocc gcx)) (inipair (instance class_objinitpair :obv_type ctype_value :oie_discr odiscr :oie_locvar oloc :oie_cname (strbuf2string discr_string nambuf))) ) (debug "compilobj_conspairbind return inipair=" inipair) (return inipair) ))) (install_method class_normal_constructed_pair_binding compile_obj compilobj_conspairbind) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_conslistbind (bind gcx) (debug "compilobj_conslistbind bind=" bind) (assert_msg "check bind" (is_a bind class_normal_constructed_list_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (symb (unsafe_get_field :binder bind)) (nloc (unsafe_get_field :nconsb_loc bind)) (ndiscr (unsafe_get_field :nconsb_discr bind)) (nletrec (unsafe_get_field :nconsb_nletrec bind)) (nfirst (unsafe_get_field :nlistb_first bind)) (nlast (unsafe_get_field :nlistb_last bind)) (nlocsyms (get_field :nletrec_locsyms nletrec)) (odiscr (compile_obj ndiscr gcx)) (nambuf (make_strbuf discr_strbuf)) (:long bindnum (get_int bind)) (locsymocc (multiple_nth nlocsyms bindnum)) ) (add2sbuf_strconst nambuf "rlist_") (add2sbuf_longdec nambuf bindnum) (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name symb)) (let ( (oloc (compile_obj locsymocc gcx)) (inilist (instance class_objinitlist :obv_type ctype_value :oie_discr odiscr :oie_locvar oloc :oie_cname (strbuf2string discr_string nambuf) )) ) (debug "compilobj_conslistbind return inilist=" inilist) (return inilist) ))) (install_method class_normal_constructed_list_binding compile_obj compilobj_conslistbind) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_consinstancebind (bind gcx) (debug "compilobj_consinstancebind bind=" bind) (assert_msg "check bind" (is_a bind class_normal_constructed_instance_binding) bind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (symb (unsafe_get_field :binder bind)) (nloc (unsafe_get_field :nconsb_loc bind)) (ndiscr (unsafe_get_field :nconsb_discr bind)) (nletrec (unsafe_get_field :nconsb_nletrec bind)) (nslots (unsafe_get_field :ninstb_slots bind)) (nambuf (make_strbuf discr_strbuf)) (odiscr (compile_obj ndiscr gcx)) (nlocsyms (get_field :nletrec_locsyms nletrec)) (:long bindnum (get_int bind)) (locsymocc (multiple_nth nlocsyms bindnum)) (nclabind (get_field :ninstb_clabind bind)) ) (add2sbuf_strconst nambuf "rinst_") (add2sbuf_longdec nambuf bindnum) (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name symb)) (let ( (oloc (compile_obj locsymocc gcx)) (clas (cond ( (is_a nclabind class_value_binding) (unsafe_get_field :vbind_value nclabind)) ( (is_a nclabind class_class_binding) (unsafe_get_field :cbind_class nclabind)) (:else (debug "compilobj_consinstancebind bad nclabind=" nclabind) (assert_msg "unexpected class binding" () nclabind)))) (ininst (instance class_objinitobject :obv_type ctype_value :oie_discr odiscr :oie_locvar oloc :oie_cname (strbuf2string discr_string nambuf) :oio_class clas )) ) ;; set the length of the instance (put_int ininst (multiple_length (get_field :class_fields clas))) (debug "compilobj_consinstancebind return ininst=" ininst) (return ininst) ))) (install_method class_normal_constructed_instance_binding compile_obj compilobj_consinstancebind) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun putobjdest_objvalue (recv desto) (assert_msg "check recv" (is_a recv class_objvalue) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (let ( (typrecv (unsafe_get_field :obv_type recv)) (typdesto (get_field :obv_type desto)) ) (cond ;; special case when receiver is void ( (== typrecv ctype_void) (if (== typdesto ctype_void) (return recv) ;; if recv is void we just create a block with recv and the ;; clear of desto (let ( (obodl (make_list discr_list)) (oblk (instance class_objplainblock ;; dont fill :obi_loc :oblo_bodyl obodl :oblo_epil () ) ) (oclr (instance class_objclear ;; dont fill :obi_loc :oclr_vloc desto )) ) (list_append obodl recv) (list_append obodl oclr) ;; the last of the block is the destination location, to ;; avoid latter putobjdest-s on the objclear (list_append obodl desto) (return oblk) ))) ;; common case when desto & recv have same type ( (== typrecv typdesto) (assert_msg "check same typrecv&rtpdesto" (is_a typrecv class_ctype) typrecv) (let ( (destlis (make_list discr_list)) (explis (make_list discr_list)) (obc (instance class_objcompute ;; dont fill :obi_loc :obdi_destlist destlis :obcpt_expr explis :obcpt_type typrecv )) ) (list_append destlis desto) (list_append explis recv) (return obc))) ;; error case: type mismatch (:else (debug "putobjdest_objvalue mismatching recv=" recv " typrecv=" typrecv " desto=" desto " typdesto=" typdesto) (outcstring_err "putobjdest_objvalue type mismatch : recv <") (let ( (discr (discrim recv)) ) (outstr_err (unsafe_get_field :named_name discr))) (outcstring_err "> & desto<") (let ( (discr (discrim desto)) ) (outstr_err (unsafe_get_field :named_name discr))) (outcstring_err ">") (outnewline_err) (assert_msg "putobjdest_objvalue type mismatch" () recv desto) (return recv))) )) (install_method class_objvalue put_objdest putobjdest_objvalue) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun putobjdest_integer (recv desto) (debug "putobjdest_integer recv=" recv "\n* desto=" desto "\n* of discrim:" (discrim desto) "\n* class_objlocv=" class_objlocv) (assert_msg "check recv" (is_integerbox recv) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (let ( (destlis (make_list discr_list)) (explis (make_list discr_list)) (typdesto (get_field :obv_type desto)) (obc (instance class_objcompute ;; dont fill :obi_loc :obdi_destlist destlis :obcpt_expr explis :obcpt_type ctype_long )) ) (assert_msg "check typdesto" (== typdesto ctype_long) typdesto) (list_append destlis desto) (list_append explis recv) (debug "putobjdest_integer return obc=" obc) obc )) (install_method discr_integer put_objdest putobjdest_integer) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; put obj destination inside a string ;;; useful to compile (let ( (:cstring foo "abc") ) ...) (defun putobjdest_string (recv desto) (assert_msg "check recv" (is_string recv) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (debug "putobjdest_string recv=" recv " desto=" desto) (let ( (destlis (make_list discr_list)) (explis (make_list discr_list)) (typdesto (unsafe_get_field :obv_type desto)) (obc (instance class_objcompute ;; dont fill :obi_loc :obdi_destlist destlis :obcpt_expr explis :obcpt_type ctype_cstring )) ) (assert_msg "check typdesto" (== typdesto ctype_cstring) typdesto) (list_append destlis desto) (list_append explis recv) (debug "putobjdest_string return obc=" obc) obc )) (install_method discr_string put_objdest putobjdest_string) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun putobjdest_null (recv desto) (assert_msg "check recv" (null recv)) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (debug "putobjdest_null recv=" recv " desto=" desto) (if (melt_need_dbg 0) (shortbacktrace_dbg "putobjdest_null" 15)) (let ( (destlis (make_list discr_list)) (explis (make_list discr_list)) (typdesto (unsafe_get_field :obv_type desto)) (obc (instance class_objcompute ;; dont fill :obi_loc :obdi_destlist destlis :obcpt_expr explis :obcpt_type typdesto )) ) (list_append destlis desto) (if (== typdesto ctype_long) (list_append explis (make_integerbox discr_integer 0)) (list_append explis recv)) (debug "putobjdest_null return obc=" obc) obc )) (install_method discr_null_receiver put_objdest putobjdest_null) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun putobjdest_objanyblock (recv desto) (assert_msg "check recv" (is_a recv class_objanyblock) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (let ( (obl (unsafe_get_field :oblo_bodyl recv)) (oep (unsafe_get_field :oblo_epil recv)) ) (assert_msg "check obl" (is_list_or_null obl) obl) (assert_msg "check oep" (is_list_or_null oep) 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) ) ) ) recv )) (install_method class_objanyblock put_objdest putobjdest_objanyblock) ;;;;;;;;;; (defun putobjdest_objmultiblock (recv desto) (assert_msg "check recv" (is_a recv class_objmultiblock) recv) (debug "putobjdest_objmultiblock recv=" recv " desto=" desto) (let ( (osubcomp (unsafe_get_field :omulblo_subcomp recv)) ) (assert_msg "check osubcomp" (is_multiple_or_null osubcomp) osubcomp) (foreach_in_multiple (osubcomp) (cursubcomp :long curix) (put_objdest cursubcomp desto)) (debug "putobjdest_objmultiblock done recv=" recv) )) (install_method class_objmultiblock put_objdest putobjdest_objmultiblock) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun putobjdest_objloop (recv desto) (assert_msg "check recv" (is_a recv class_objloop) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (let ( (epil (unsafe_get_field :oblo_epil recv)) (resv (unsafe_get_field :obloop_resv recv)) (destlist (make_list discr_list)) (obc (instance class_objcompute ;; dont fill :obi_loc :obdi_destlist destlist :obcpt_expr resv :obcpt_type ctype_value )) ) (list_append destlist desto) (assert_msg "check epil" (is_list epil) epil) (assert_msg "check resv" (is_a resv class_objlocv) resv) (list_append epil obc) ) (debug "putobjdest loop updated recv=" recv) recv ) (install_method class_objloop put_objdest putobjdest_objloop) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; do nothing when puting a destination into an objexit (defun putobjdest_objexit (recv desto) (assert_msg "check recv" (is_a recv class_objexit) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) recv ) (install_method class_objexit put_objdest putobjdest_objexit) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_if (rif gcx) (assert_msg "check rif" (is_a rif class_nrep_if) rif) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_if rif=" rif) (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 :nexpr_ctyp rif)) ) (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp) (let ( (otest (compile_obj ntest gcx)) (othen (compile_obj nthen gcx)) (oelse (if (is_not_a nelse class_nrep_nil) (compile_obj nelse gcx))) (obif (instance class_objcond :obi_loc loc :obcond_test otest :obcond_then othen :obcond_else oelse)) ) (debug "compilobj_nrep_if ntest=" ntest " otest=" otest) (debug "compilobj_nrep_if nthen=" nthen " otest=" othen) (debug "compilobj_nrep_if nthen=" nelse " otest=" oelse) (debug "compilobj_nrep_if obif=" obif) (assert_msg "check otest" (notnull otest) otest) obif ))) (install_method class_nrep_if compile_obj compilobj_nrep_if) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_ifisa (rif gcx) (debug "compilobj_nrep_ifisa rif=" rif) (assert_msg "check rif" (is_a rif class_nrep_ifisa) rif) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc rif)) (nthen (unsafe_get_field :nif_then rif)) (nelse (unsafe_get_field :nif_else rif)) (nctyp (unsafe_get_field :nexpr_ctyp rif)) (nval (get_field :nif_testval rif)) (ncla (unsafe_get_field :nifa_class rif)) ) (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp) (let ( (othen (compile_obj nthen gcx)) (oval (compile_obj nval gcx)) (ocla (compile_obj ncla gcx)) (oelse (if (is_not_a nelse class_nrep_nil) (compile_obj nelse gcx))) (otest (make_objlocatedexp loc ctype_long ##{/*ifisa*/ melt_is_instance_of((melt_ptr_t)($OVAL), (melt_ptr_t)($OCLA)) }#)) (obif (instance class_objcond :obi_loc loc :obcond_test otest :obcond_then othen :obcond_else oelse)) ) (debug "compilobj_nrep_ifisa obif=" obif) obif ))) (install_method class_nrep_ifisa compile_obj compilobj_nrep_ifisa) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_ifsame (rif gcx) (debug "compilobj_nrep_ifsame rif=" rif "\n gcx=" gcx) (assert_msg "check rif" (is_a rif class_nrep_ifsame) rif) (let ( (nloc (get_field :nrep_loc rif)) (nleft (get_field :nifs_left rif)) (nright (get_field :nifs_right rif)) (nthen (get_field :nif_then rif)) (nelse (get_field :nif_else rif)) ) (let ( (othen (compile_obj nthen gcx)) (oleft (compile_obj nleft gcx)) (oright (compile_obj nright gcx)) (oelse (if (is_not_a nelse class_nrep_nil) (compile_obj nelse gcx))) (otest (make_objlocatedexp nloc ctype_long ##{/*ifsame*/ ($OLEFT) == ($ORIGHT)}#)) (obif (instance class_objcond :obi_loc nloc :obcond_test otest :obcond_then othen :obcond_else oelse)) ) (debug "compilobj_nrep_ifsame result obif=" obif) (return obif) ))) (install_method class_nrep_ifsame compile_obj compilobj_nrep_ifsame) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_iftuplesized (rif gcx) (debug "compilobj_nrep_ifisa rif=" rif) (assert_msg "check rif" (is_a rif class_nrep_iftuplesized) rif) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc rif)) (nthen (unsafe_get_field :nif_then rif)) (nelse (unsafe_get_field :nif_else rif)) (nval (get_field :nif_testval rif)) (ntsz (get_field :nif_tupsiz rif)) ) (debug "compilobj_nrep_iftuplesized nval=" nval " ntsz=" ntsz) (let ( (othen (compile_obj nthen gcx)) (oval (compile_obj nval gcx)) (oelse (compile_obj nelse gcx)) (oval (compile_obj nval gcx)) (otsz (compile_obj ntsz gcx)) (otest (make_objlocatedexp loc ctype_long ##{/*iftuplesized*/ melt_magic_discr((melt_ptr_t)($OVAL)) == MELTOBMAG_MULTIPLE && ((meltmultiple_ptr_t)($OVAL))->nbval == (int)($OTSZ)}#)) (obif (instance class_objcond :obi_loc loc :obcond_test otest :obcond_then othen :obcond_else oelse)) ) (debug "compilobj_nrep_iftuplesized obif=" obif) obif ))) (install_method class_nrep_iftuplesized compile_obj compilobj_nrep_iftuplesized) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_ifvariadic (rif gcx) (assert_msg "check rif" (is_a rif class_nrep_ifvariadic) rif) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_ifvariadic rif=" rif) (let ( (loc (unsafe_get_field :nrep_loc rif)) (nthen (unsafe_get_field :nif_then rif)) (nelse (unsafe_get_field :nif_else rif)) (nvariadic (unsafe_get_field :nifv_variadic rif)) (nvctypes (unsafe_get_field :nifv_ctypes rif)) (:long nbvararg (multiple_length nvctypes)) ) (assert_msg "check nvctypes" (is_multiple_or_null nvctypes) nvctypes) (assert_msg "check nvariadic" (is_a nvariadic class_symbol) nvariadic) (debug "compilobj_nrep_ifvariadic nthen=" nthen " nelse=" nelse " nvariadic=" nvariadic) (let ( (ovariadicindex (variadic_index_idstr nvariadic)) (ovariadiclength (variadic_length_idstr nvariadic)) (otestchklist (if (<=i nbvararg 0) (list (make_stringconst discr_verbatim_string "/*ifvariadic nomore*/ ") ovariadicindex (make_stringconst discr_verbatim_string " == ") ovariadiclength ) (let ( (ovlist (list (make_stringconst discr_verbatim_string "/*ifvariadic arg#") (make_integerbox discr_constant_integer nbvararg) (make_stringconst discr_verbatim_string "*/ ") ovariadicindex (make_stringconst discr_verbatim_string ">=0 && ") ovariadicindex (make_stringconst discr_verbatim_string " + ") (make_integerbox discr_constant_integer nbvararg) (make_stringconst discr_verbatim_string " <= ") ovariadiclength )) ) (foreach_in_multiple (nvctypes) (curctyp :long ix) (debug "compilobj_nrep_ifvariadic curctyp" curctyp " ix=" ix) (assert_msg "check curctyp" (is_a curctyp class_ctype) curctyp) (list_append ovlist (make_stringconst discr_verbatim_string " && meltxargdescr_[")) (list_append ovlist ovariadicindex) (if ix (progn (list_append ovlist (make_stringconst discr_verbatim_string " + ")) (list_append ovlist (make_integerbox discr_constant_integer ix)))) (list_append ovlist (make_stringconst discr_verbatim_string "]== ")) (list_append ovlist (make_string discr_verbatim_string (get_field :ctype_parchar curctyp))) ) (debug "compilobj_nrep_ifvariadic ovlist=" ovlist) ovlist)) ) (otest (instance class_objexpv :obx_cont (list_to_multiple otestchklist discr_multiple))) (othen (progn (debug "compilobj_nrep_ifvariadic before compiling nthen=" nthen) (let ( (objthen (compile_obj nthen gcx)) ) (debug "compilobj_nrep_ifvariadic after compiling nthen=" nthen " objthen=" objthen) objthen))) (oelse (progn (debug "compilobj_nrep_ifvariadic before compiling nelse=" nelse) (let ( (objelse (compile_obj nelse gcx)) ) (debug "compilobj_nrep_ifvariadic after compiling nelse=" nelse " objelse=" objelse) objelse))) (ocond (instance class_objcond :obi_loc loc :obcond_test otest :obcond_then othen :obcond_else oelse)) ) (debug "compilobj_nrep_ifvariadic ocond=" ocond) (return ocond)))) (install_method class_nrep_ifvariadic compile_obj compilobj_nrep_ifvariadic) (defun getctype_ifvariadic (rif env) (assert_msg "check ifvariadic" (is_a rif class_nrep_ifvariadic) rif) ctype_void) (install_method class_nrep_ifvariadic get_ctype getctype_ifvariadic) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_variadic_argument (nvarg gcx) (debug "compilobj_nrep_variadic_argument nvarg=" nvarg) (assert_msg "check nvarg" (is_a nvarg class_nrep_variadic_argument) nvarg) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (unsafe_get_field :nrep_loc nvarg)) (nvariadic (unsafe_get_field :nvarg_variadic nvarg)) (nctyp (unsafe_get_field :nvarg_ctyp nvarg)) (noffset (unsafe_get_field :nvarg_offset nvarg)) (ovariadicindex (variadic_index_idstr nvariadic)) (ovariadiclength (variadic_length_idstr nvariadic)) ) (assert_msg "check nctyp" (is_a nctyp class_ctype) nctyp) (assert_msg "check noffset" (is_integerbox noffset) noffset) (let ( (otuple (if (== nctyp ctype_value) (tuple (make_stringconst discr_verbatim_string "/*variadic argument value*/ ((meltxargtab_[") ovariadicindex (make_stringconst discr_verbatim_string " + ") noffset (make_stringconst discr_verbatim_string "].meltbp_aptr) ? (*(meltxargtab_[") ovariadicindex (make_stringconst discr_verbatim_string " + ") noffset (make_stringconst discr_verbatim_string "].meltbp_aptr)) : NULL)") ) (tuple (make_stringconst discr_verbatim_string "/*variadic argument stuff*/ meltxargtab_[") ovariadicindex (make_stringconst discr_verbatim_string " + ") noffset (make_stringconst discr_verbatim_string "].") (make_string discr_verbatim_string (get_field :ctype_argfield nctyp)) ))) (ocomp (instance class_objcompute :obi_loc nloc :obcpt_type nctyp :obcpt_expr otuple)) ) (debug "compilobj_nrep_variadic_argument ocomp=" ocomp) (return ocomp) ))) (install_method class_nrep_variadic_argument compile_obj compilobj_nrep_variadic_argument) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_consumevariadic (rcv gcx) (assert_msg "check rcv" (is_a rcv class_nrep_consume_variadic) rcv) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_consumevariadic rcv=" rcv) (let ( (nloc (unsafe_get_field :nrep_loc rcv)) (nvariadic (unsafe_get_field :nconsva_variadic rcv)) (nctypes (unsafe_get_field :nconsva_ctypes rcv)) (olist (make_list discr_list)) (ovariadicindex (variadic_index_idstr nvariadic)) (ovariadiclength (variadic_length_idstr nvariadic)) ) (assert_msg "check nctypes" (is_multiple_or_null nctypes) nctypes) (list_append olist (make_stringconst discr_verbatim_string "/*consume variadic ")) (foreach_in_multiple (nctypes) (curctyp :long typix) (assert_msg "check curctyp" (is_a curctyp class_ctype) curctyp) (if (== curctyp ctype_value) (list_append olist (make_stringconst discr_verbatim_string "Value")) (list_append olist (make_string discr_verbatim_string (get_field :named_name (get_field :ctype_keyword curctyp)))))) (list_append olist (make_stringconst discr_verbatim_string " !*/ ")) (list_append olist ovariadicindex) (list_append olist (make_stringconst discr_verbatim_string " += ")) (list_append olist (make_integerbox discr_integer (multiple_length nctypes))) (let ( (otuple (list_to_multiple olist)) (ocomp (instance class_objcompute :obi_loc nloc :obcpt_type ctype_void :obcpt_expr otuple)) ) (debug "compilobj_nrep_consumevariadic ocomp=" ocomp) (return ocomp) ))) (install_method class_nrep_consume_variadic compile_obj compilobj_nrep_consumevariadic) ;;;;;;;;;;;;; (defun putobjdest_objcond (recv desto) (assert_msg "check recv" (is_a recv class_objcond) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (let ( (othen (unsafe_get_field :obcond_then recv)) (oelse (unsafe_get_field :obcond_else recv)) ) (let ( (dthen (put_objdest othen desto)) (delse (put_objdest oelse desto)) ) (unsafe_put_fields recv :obcond_then dthen :obcond_else delse) recv ))) (install_method class_objcond put_objdest putobjdest_objcond) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_cppif (pif gcx) (assert_msg "check pif" (is_a pif class_nrep_cppif) pif) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (loc (unsafe_get_field :nrep_loc pif)) (ncond (unsafe_get_field :nifp_cond pif)) (nthen (unsafe_get_field :nifp_then pif)) (nelse (unsafe_get_field :nifp_else pif)) (ctyp (unsafe_get_field :nifp_ctyp pif)) (scond (cond ( (is_a ncond class_symbol) (unsafe_get_field :named_name ncond)) ( (is_string ncond) ncond) (:else (assert_msg "invalid ncond in nrep_cppif" () ncond)))) (othen (compile_obj nthen gcx)) (oelse (compile_obj nelse gcx)) (res (instance class_objcppif :obi_loc loc :obifp_cond scond :obifp_then othen :obifp_else oelse)) ) (return res) )) (install_method class_nrep_cppif compile_obj compilobj_nrep_cppif) ;;;;;;;;;;;;; (defun putobjdest_objcppif (recv desto) (assert_msg "check recv" (is_a recv class_objcppif) recv) (assert_msg "check desto" (is_a desto class_objpurevalue) desto) (let ( (othen (unsafe_get_field :obifp_then recv)) (oelse (unsafe_get_field :obifp_else recv)) ) (let ( (dthen (put_objdest othen desto)) (delse (put_objdest oelse desto)) ) (unsafe_put_fields recv :obifp_then dthen :obifp_else delse) recv ))) (install_method class_objcppif put_objdest putobjdest_objcppif) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; (defun compilobj_nrep_return (nret gcx) (assert_msg "check nret" (is_a nret class_nrep_return) nret) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_return nret=" nret "\n gcx=" gcx) (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 (instance class_objplainblock :obi_loc rloc :oblo_bodyl olis)) (omainv (progn (debug "compilobj_nrep_return rmain=" rmain) (compile_obj rmain gcx))) ) (debug "compilobj_nrep_return omainv=" omainv) (assert_msg "check orout" (is_a orout class_routineobj) orout) (assert_msg "check rrest" (is_multiple_or_null rrest) rrest) (if (null (get_field :obrout_retval orout)) (put_fields orout :obrout_retval retloc)) (debug "compilobj_nrep_return omainv=" omainv " retloc=" retloc) (if retloc (list_append olis (put_objdest omainv retloc))) (when (and (is_a orout class_initialroutineobj) (>i (multiple_length rrest) 0)) (debug "compilobj_nrep_return bad initial orout=" orout " with secondary results rrest=" rrest) (error_plain rloc "(RETURN ...) with secondary results outside of function") (return) ) (debug "compilobj_nrep_return rrest=" rrest) (foreach_in_multiple (rrest) (rxtra :long ix) (debug "compilobj_nrep_return rxtra=" rxtra " ix=" ix) (let ( (oxres (instance class_objputxtraresult :obi_loc rloc :obxres_rank (make_integerbox discr_integer ix) :obxres_obloc (compile_obj rxtra gcx))) ) (debug "compilobj_nrep_return oxres=" oxres) ;; maybe we need to compute the ctype of the extra result.... (list_append olis oxres))) ;; if no secondary results are returned, emit a check that no ;; secondary actual results are expected (if (is_a orout class_procroutineobj) (if (==i (multiple_length rrest) 0) (let ( (ochecknores ;; I should be ashamed of this, we really should a ;; special class subclass of class_objinstr for ;; that check. (make_objlocatedexp rloc ctype_void "/*ochecknores compilobj_nrep_return*/\n" "#if MELT_HAVE_DEBUG\n" " if (meltxresdescr_ && meltxresdescr_[0] && meltxrestab_)\n" " melt_warn_for_no_expected_secondary_results();\n" "/* we warned when secondary results are expected but not returned. */\n" "#endif /*MELT_HAVE_DEBUG*/\n" )) ) (debug "compilobj_nrep_return ochecknores=" ochecknores) (list_append olis ochecknores) ))) (list_append olis (instance class_objfinalreturn :obi_loc rloc)) (debug "compilobj_nrep_return final oblock=" oblock) oblock )) (install_method class_nrep_return compile_obj compilobj_nrep_return) (install_method class_nrep_return get_ctype (lambda (recv env) ctype_value)) ;; 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) (debug "compilobj_nrep_lambda nlam=" nlam "\n.. gcx=" gcx) (assert_msg "check nlam" (is_a nlam class_nrep_lambda) nlam) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (shortbacktrace_dbg "compilobj_nrep_lambda" 12) (let ( (nloc (unsafe_get_field :nrep_loc nlam)) (npro (let ( (checkpro (unsafe_get_field :nlambda_proc nlam)) ) (debug "compilobj_nrep_lambda npro=" checkpro) (assert_msg "check checkpro" (is_a checkpro class_nrep_routproc) checkpro) checkpro)) (nam (get_field :nrclop_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 (instance class_objplainblock :obi_loc nloc :oblo_bodyl olis)) (destlist (make_list discr_list)) ) (debug "compilobj_nrep_lambda nrou=" nrou "\n.. npro=" npro "\n.. orout=" orout) (list_append destlist locv) (list_append olis (instance class_objnewclosure :obi_loc nloc :obnclo_discr discrclosure_objpredef :obnclo_rout (progn (let ( (crou (compile_obj nrou gcx)) ) (debug "compilobj_nrep_lambda crou=" crou) crou) ) :obnclo_len (make_integerbox discr_integer nbclosed) :obdi_destlist destlist)) (foreach_in_multiple (nclovtup) (clov :long ix) (list_append olis (instance class_objputclosedv :obi_loc nloc :opclov_clos locv :opclov_off (make_integerbox discr_integer ix) :opclov_cval (compile_obj clov gcx)))) ;; we don't need to add any objtouch because the nlam was normalized! (list_append olis locv) ;;; last instruction is just the value, which can be set to some dest (debug "compilobj_nrep_lambda result oblock=" oblock) oblock )) (install_method class_nrep_lambda compile_obj compilobj_nrep_lambda) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_makeinst (nmki gcx) (debug "compilobj_nrep_makeinst nmki=" nmki) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check nmki" (is_a nmki class_nrep_instance) nmki) (let ( (nloc (unsafe_get_field :nrep_loc nmki)) (ncla (unsafe_get_field :nmins_class nmki)) (ncladat (unsafe_get_field :nmins_cladata nmki)) (nfields (unsafe_get_field :nmins_fields nmki)) ) (assert_msg "check ncla" (is_a ncla class_class) ncla) (let ( (:long nbfld (multiple_length (unsafe_get_field :class_fields ncla))) (destlist (make_list discr_list)) (locv (get_free_objlocptr gcx 'inst)) (olis (make_list discr_list)) (ocladat (compile_obj ncladat gcx)) (oblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl olis)) (orallobj (instance class_objrawallocobj :obi_loc nloc :obrallobj_class ocladat :obrallobj_len (make_integerbox discr_integer nbfld) :obrallobj_classname (unsafe_get_field :named_name ncla) :obdi_destlist destlist)) ) (list_append destlist locv) (list_append olis orallobj) ;; handle each field assign (foreach_in_multiple (nfields) (cfla :long ix) (assert_msg "compilobj_nrep_makeinst check cfla" (is_a cfla class_nrep_fieldassign) cfla) (let ( (cfloc (unsafe_get_field :nrep_loc cfla)) (cfield (unsafe_get_field :nfla_field cfla)) (cval (unsafe_get_field :nfla_val cfla)) ) (assert_msg "compilobj_nrep_makeinst check cfield" (is_a cfield class_field) cfield) (let ( (oval (compile_obj cval gcx)) (oputs (instance class_objputslot :obi_loc (if cfloc cfloc nloc) :oslot_odata locv :oslot_field cfield :oslot_offset (make_integerbox discr_integer (get_int cfield)) :oslot_value oval)) ) (debug "compilobj_nrep_makeinst cval=" cval "\n.. oputs=" oputs) (assert_msg "compilobj_nrep_makeinst check oval not nrep" (not (is_a oval class_nrep)) oval) (list_append olis oputs) ))) ;; since nmki was normalized, the new object was allocated in ;; the birth zone so don't need to be touched. ;; ;; add the debugtracing (let ( (odbgtr (instance class_objdbgtracewriteobj :obi_loc nloc :obdtw_writtenobj locv :obdtw_message '"newly made instance" )) ) (list_append olis odbgtr) ) (list_append olis locv) ;;; last instruction is just the value, which can be set to some dest (debug "compilobj_nrep_makeinst result oblock=" oblock) oblock ))) (install_method class_nrep_instance compile_obj compilobj_nrep_makeinst) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compile a procedure should not be called (defun compilobj_routproc (npro gcx) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check npro" (is_a npro class_nrep_routproc) npro) (debug "compilobj_routproc npro=" npro "\n... gcx=" gcx) (assert_msg "UNEXPECTED CALL TO compilobj_routproc" () npro) ) (install_method class_nrep_routproc compile_obj compilobj_routproc) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; (defun compilobj_predef (npr gcx) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check npr" (is_a npr class_nrep_predef) npr) (let ((obpred (get_field :nrpredef npr)) (opr (instance class_objpredef :obv_type ctype_value :obpredef obpred)) ) (assert_msg "check obpred" obpred npr) 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 ;;; return a tuple of bindings to be disposed (defun compil_data_and_slots_fill (ndat obj odiscr irout gcx) (debug "compil_data_and_slots_fill start ndat=" ndat "\n.. obj=" obj "\n.. odiscr=" odiscr "\n.. irout=" irout "\n") (shortbacktrace_dbg "compil_data_and_slots_fill" 25) (assert_msg "compil_data_and_slots_fill check ndat" (is_a ndat class_nrep_bound_data) ndat) (assert_msg "compil_data_and_slots_fill check obj" (is_a obj class_objinitobject) obj) (assert_msg "compil_data_and_slots_fill check odiscr" (is_a odiscr class_objvalue) odiscr) (assert_msg "compil_data_and_slots_fill check irout" (is_a irout class_any_start_routineobj) irout) (assert_msg "compil_data_and_slots_fill check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (ipredef (cond ( (is_a ndat class_nrep_datainstance) (unsafe_get_field :ninst_predef ndat)) ( (is_a ndat class_nrep_datahook) (unsafe_get_field :ndhook_predef ndat)))) (ibodylis (get_field :obrout_body irout)) (locvar (get_free_objlocptr gcx '_valdata_)) (comm (unsafe_get_field :named_name '_valuedata_)) (nloc (unsafe_get_field :nrep_loc ndat)) (dlocbind (unsafe_get_field :ndata_locbind ndat)) (locmap (unsafe_get_field :gncx_locmap gcx)) (istmtlis ibodylis) ;the statement list to which the putslots are appended ;; a tuple to store the objvar for localbinds to be able to clear them later (tupvar (make_multiple discr_multiple (multiple_length locmap))) ) (assert_msg "compil_data_and_slots_fill check ibodylis" (is_list ibodylis) ibodylis) (assert_msg "compil_data_and_slots_fill check fresh obj" (null (unsafe_get_field :oie_locvar obj)) obj) (unsafe_put_fields obj :oie_locvar locvar) (debug "compil_data_and_slots_fill updated obj=" obj) ;; if the data is predefined, we fill it conditionally on !meltpredefinited[..] (if ipredef (let ( (otestpredef (cond ( (is_a ipredef class_symbol) (instance class_objexpv :obx_cont (tuple (make_stringconst discr_verbatim_string "MELTPREDEFIX(meltpredefinited,") (make_string discr_verbatim_string (unsafe_get_field :named_name ipredef)) (make_stringconst discr_verbatim_string ")") )) ) ( (is_integerbox ipredef) (instance class_objexpv :obx_cont (tuple (make_stringconst discr_verbatim_string "predefinited[") ipredef (make_stringconst discr_verbatim_string "]") )) ) )) (initlis (make_list discr_list)) (oblockpredef (instance class_objcommentedblock :oblo_bodyl initlis :ocomblo_comment '"fill predef slots")) (ocondpredef (instance class_objcond :obi_loc nloc :obcond_test otestpredef :obcond_then () :obcond_else oblockpredef)) ) (setq istmtlis initlis) (list_append ibodylis ocondpredef) )) (debug "compil_data_and_slots_fill dlocbind=" dlocbind) (foreach_in_multiple (dlocbind) (lbind :long bindrk) (debug "compil_data_and_slots_fill lbind=" lbind) (assert_msg "compil_data_and_slots_fill check lbind" (is_a lbind class_normal_let_binding) lbind) (let ( (bder (unsafe_get_field :binder lbind)) (cty (unsafe_get_field :letbind_type lbind)) (nexp (unsafe_get_field :letbind_expr lbind)) (obva (get_free_objloctyped gcx bder cty)) (obnx (compile_obj nexp gcx)) ) (debug "compil_data_and_slots_fill obnx=" obnx "\n.. obva=" obva) (if obva (mapobject_put locmap lbind obva)) (let ( (obmy (if obva (put_objdest obnx obva) obnx)) ) ;; add the modified obmy in the ibodylis (list_append istmtlis obmy) ) (if obva (multiple_put_nth tupvar bindrk obva)) )) (shortbacktrace_dbg "compil_data_and_slots_fill [slo]" 21) (debug "compil_data_and_slots_fill ndats slots=" (get_field :ninst_slots ndat)) ;; for every non nil slot, append its initialization to istmtlis (foreach_in_multiple ((unsafe_get_field :ninst_slots ndat)) (sloval :long slork) (if sloval ;;; add to list inifill the filling in dai of slot#slork by slobj (let ( (slobj (compile_obj sloval gcx)) ) (debug "compil_data_and_slots_fill slobj=" slobj "\n.. sloval=" sloval "\n slork#" slork) (assert_msg "compil_data_and_slots_fill check slobj not nrep" (is_not_a slobj class_nrep) slobj) (let ( (ooff (make_integerbox discr_integer slork)) (oput (instance class_objputslot :obi_loc nloc :oslot_odata obj :oslot_offset ooff :oslot_value slobj )) ) (debug "compil_data_and_slots_fill oput=" oput "\n for sloval=" sloval) (shortbacktrace_dbg "compil_data_and_slots_fill oput" 18) (list_append istmtlis oput) )))) ;; touch the object (list_append istmtlis (instance class_objtouch :obi_loc (if nloc nloc (unsafe_get_field :nrep_loc ndat)) :otouch_comment comm :otouch_val obj)) ;; debugwrite the object ; (list_append istmtlis (instance class_objdbgtracewriteobj :obi_loc (if nloc nloc (unsafe_get_field :nrep_loc ndat)) :obdtw_writtenobj obj :obdtw_message '"new static instance")) ;; for every non nil local obvar, clear it (multiple_every tupvar (lambda (obva :long ix) (if obva (progn (list_append ibodylis (instance class_objclear :obi_loc nloc :oclr_vloc obva)) )))) ;;; add the obj as the last instr of the block (list_append ibodylis obj) ;; (debug "compil_data_and_slots_fill final dlocbind=" dlocbind) ;; the caller is supposed to do ;; dispose_dlocbind_after_data_and_slots_fill with the result if ;; needed but in practice this is never needed (return dlocbind) ) (return) ;force a nil return ) ;; probably useless function (defun dispose_dlocbind_after_data_and_slots_fill (dlocbind gcx) (debug "dispose_dlocbind_after_data_and_slots_fill dlocbind=" dlocbind) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (multiple_every dlocbind (lambda (bnd :long ix) (dispose_bnd_obj bnd gcx))) ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_datasymbol (syv gcx) (debug "compilobj_datasymbol syv=" syv) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check syv" (is_a syv class_nrep_datasymbol) syv) (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) (chobj (mapobject_get compicache syv)) (inirout (unsafe_get_field :gncx_objrout gcx)) ) (debug "compilobj_datasymbol inirout=" inirout "\n compicache=" compicache "\n chobj=" chobj) ;; datasymbol compiled only in start routines (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout) (when chobj (debug "compilobj_datasymbol found chobj=" chobj) (return chobj)) (let ( (odiscr (compile_obj (unsafe_get_field :ndata_discrx syv) gcx)) (obsym ;;; symbols should be unique objects, to avoir recreating ;;; them when they already exist. (instance class_objinituniqueobject :obv_type ctype_value :oie_data syv :oie_discr odiscr :oie_cname () :oio_class () )) ) (mapobject_put compicache syv obsym) (debug "compilobj_datasymbol obsym=" obsym "\n.. syv=" syv "\n.. updated compicache=" compicache "\n") ;; 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))) (shortbacktrace_dbg "compilobj_datasymbol" 6) (debug "compilobj_datasymbol obsym=" obsym "\n.. for syv=" syv) ;; put the length as obj_num of obsym (put_int obsym (multiple_length (unsafe_get_field :ninst_slots syv))) (let ( (dlocbind (compil_data_and_slots_fill syv obsym odiscr inirout gcx)) ) (debug "compilobj_datasymbol dlocbind=" dlocbind) ;;(dispose_dlocbind_after_data_and_slots_fill dlocbind gcx) ) (shortbacktrace_dbg "compilobj_datasymbol" 9) (debug "compilobj_datasymbol final obsym=" obsym) (return obsym) ))) (install_method class_nrep_datasymbol compile_obj compilobj_datasymbol) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; compilobj of datainstance (defun compilobj_datainstance (dai gcx) (debug "compilobj_datainstance dai=" dai) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) (chobj (mapobject_get compicache dai)) (inirout (unsafe_get_field :gncx_objrout gcx)) ) ;; datainstance compiled only in start routine (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout) (when chobj (debug "compilobj_datainstance return 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)) (dpredef (unsafe_get_field :ninst_predef dai)) (dslots (unsafe_get_field :ninst_slots dai)) ) ;; 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) drank) (let ( (cdisx (compile_obj disx gcx)) ) (debug "compilobj_datainstance cdisx=" cdisx) (let ( ;; make a cname (oini (if dpredef ;; if predefined, make it unique! (instance class_objinituniqueobject :obv_type ctype_value :oie_data dai :oie_discr cdisx :oio_predef dpredef :oio_class () ) ;; othewise, don't bother make it unique (instance class_objinitobject :obv_type ctype_value :oie_data dai :oie_discr cdisx :oio_predef dpredef :oio_class () ) )) (nambuf (make_strbuf discr_strbuf)) (:long drk (get_int drank)) ) (debug "compilobj_datainstance oini=" oini) (shortbacktrace_dbg "compilobj_datainstance" 14) (mapobject_put compicache dai oini) (debug "compilobj_datainstance updated compicache=" compicache "\n.. dai=" dai "\n.. oini=" oini) (add2sbuf_strconst nambuf "dobj_") (add2sbuf_longdec nambuf drk) (if nam (progn (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (get_field :named_name nam)))) (let ( (cnam (strbuf2string discr_string nambuf)) ) (unsafe_put_fields oini :oie_cname cnam) ) (put_int oini (multiple_length dslots)) (let ( (dlocbind (compil_data_and_slots_fill dai oini cdisx inirout gcx)) ) (debug "compil_data_and_slots_fill dlocbind=" dlocbind) ;;(dispose_dlocbind_after_data_and_slots_fill dlocbind gcx) ) (debug "compilobj_datainstance final oini=" oini) (return oini) ) ) ) ) ) (install_method class_nrep_datainstance compile_obj compilobj_datainstance) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; compile a data tuple (defun compilobj_datatuple (nti gcx) (debug "compilobj_datatuple nti=" nti) (assert_msg "check nti" (is_a nti class_nrep_datatuple) nti) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) (chobj (mapobject_get compicache nti)) (inirout (unsafe_get_field :gncx_objrout gcx)) ) ;; datatuples compiled only in start routine (debug "compilobj_datatuple inirout=" inirout) (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout) (when chobj (debug "compilobj_datatuple found chobj=" chobj) (return chobj)) (let ( (ncompi (unsafe_get_field :ntup_comp nti)) (ocompi (multiple_map ncompi (lambda (c :long ix) (if c (compile_obj c gcx))))) (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 (get_field :obrout_body inirout)) (comm (unsafe_get_field :named_name '_initup_)) ) (add2sbuf_strconst nambuf "dtup_") (add2sbuf_longdec nambuf drk) (cond ((is_a nam class_symbol) (add2out nambuf "_sy" (symbol_cname nam))) ((is_a nam class_named) (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (get_field :named_name nam))) ((is_string nam) (add2out nambuf "___") (add2sbuf_cident nambuf nam))) (let ( (otup (instance class_objinitmultiple :obv_type ctype_value :oie_discr odiscr :oie_locvar locvar :oie_cname (strbuf2string discr_verbatim_string nambuf) :oim_tupval ocompi )) ) (mapobject_put compicache nti otup) (debug "compilobj_datatuple updated compicache=" compicache "\n.. nti=" nti "\n.. otup=" otup) (put_int otup (multiple_length ncompi)) (multiple_every ncompi (lambda (scomp :long srk) (if scomp (let ( (ocomp (multiple_nth ocompi srk)) ) (list_append inibody (instance class_objputuple :oputu_tupled otup :oputu_offset (make_integerbox discr_integer srk) :oputu_value ocomp))) ))) (list_append inibody (instance class_objtouch :otouch_val otup :otouch_comment comm)) (debug "compilobj_datatuple otup=" otup) (return 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) nds) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (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_any_start_routineobj) inirout) (if chobj (progn (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 (instance class_objinitstring :obv_type ctype_value :oie_data odata :oie_discr odiscr :oie_locvar locvar )) ) (mapobject_put compicache nds ostr) (debug "compilobj_datastring updated compicache=" compicache "\n.. nds=" nds "\n.. ostr=" ostr) (add2sbuf_strconst nambuf "dstr_") (add2sbuf_longdec nambuf drk) (add2sbuf_strconst nambuf "__") (add2sbuf_cidentprefix nambuf odata 24) (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)) ostr ) )) (install_method class_nrep_datastring compile_obj compilobj_datastring) ;;;;;;;;;;;;;;;; compile a data boxed integer (defun compilobj_databoxedinteger (ndi gcx) (debug "compilobj_databoxedinteger ndi=" ndi) (assert_msg "check ndi" (is_a ndi class_nrep_databoxedinteger) ndi) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) (inirout (unsafe_get_field :gncx_objrout gcx)) (chobj (mapobject_get compicache ndi)) ) ;; datastring compiled only in initial routines (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout) (when chobj (debug "compilobj_databoxedinteger found chobj=" chobj) (return chobj)) (let ( (nambuf (make_strbuf discr_strbuf)) (ndisx (unsafe_get_field :ndata_discrx ndi)) (odiscr (compile_obj ndisx gcx)) (odata (unsafe_get_field :nboxint_num ndi)) (drank (unsafe_get_field :ndata_rank ndi)) (nam (unsafe_get_field :ndata_name ndi)) (locvar (get_free_objlocptr gcx '_valbxint_)) (:long drk (get_int drank)) (oint (instance class_objinitboxinteger :obv_type ctype_value :oie_data odata :oie_discr odiscr :oie_locvar locvar )) ) (mapobject_put compicache ndi oint) (debug "compilobj_databoxedinteger updated compicache=" compicache "\n ndi=" ndi "\n.. oint=" oint) (add2sbuf_strconst nambuf "dint_") (add2sbuf_longdec nambuf drk) (add2sbuf_strconst nambuf "__") (add2sbuf_cidentprefix nambuf odata 16) (if nam (progn (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name nam)))) (unsafe_put_fields oint :oie_cname (strbuf2string discr_string nambuf)) oint ) )) (install_method class_nrep_databoxedinteger compile_obj compilobj_databoxedinteger) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; compile a data closure (defun compilobj_dataclosure (ncl gcx) (debug "compilobj_dataclosure ncl=" ncl) (assert_msg "check ncl" (is_a ncl class_nrep_dataclosure) ncl) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (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_any_start_routineobj) inirout) (when chobj (debug "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) npro) (add2sbuf_strconst nambuf "dclo_") (add2sbuf_longdec nambuf (get_int nrank)) (when nam (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) (let ( (ndatarou (unsafe_get_field :nrpro_datarout npro)) (oiclo (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) (debug "compilobj_dataclosure updated compicache=" compicache "\n.. ncl=" ncl "\n.. oiclo=" oiclo) (assert_msg "check ndatarou" (is_a ndatarou class_nrep_dataroutine) ndatarou) (let ( ;; npro should already have been compiled, so should be in the compiler cache (ocrout (mapobject_get compicache npro)) (odatrout (compile_obj ndatarou gcx)) (ocputrout (instance class_objputclosurout :obi_loc nloc :opclor_clos oiclo :opclor_rout odatrout ;;@@OLDBUGGY :opclor_rout (mapobject_get compicache ndatarou) )) (bxoff (make_integerbox discr_integer 0)) ) (assert_msg "check ocrout" (is_a ocrout class_procroutineobj) ocrout) (list_append inibody ocputrout) (multiple_every nclov (lambda (clov :long ix) (let ( (cloval (compile_obj clov gcx)) (ocputclos (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)))) (list_append inibody (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) (debug "compilobj_dataroutine ndrou=" ndrou "\n.. gcx=" gcx) (assert_msg "check ndrou" (is_a ndrou class_nrep_dataroutine) ndrou) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (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 (debug "compilobj_dataroutine inirout=" inirout) (shortbacktrace_dbg "compilobj_dataroutine" 10) (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout) (when chobj (debug "compilobj_dataroutine return 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 (get_field :ndrou_proc ndrou)) (inibody (get_field :obrout_body inirout)) (locvar (get_free_objlocptr gcx '_valrout_)) ) (debug "compilobj_dataroutine npro=" npro "\n.. ndrou=" ndrou) (if (null nloc) (if (is_a npro class_nrep) (setq nloc (unsafe_get_field :nrep_loc npro)))) (debug "compilobj_dataroutine compicache=" compicache) (assert_msg "check compicache" (is_mapobject compicache) 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) (when nam (add2sbuf_strconst nambuf "__") (add2sbuf_cident nambuf (unsafe_get_field :named_name nam))) (let ( (oinipro (mapobject_get compicache npro)) (oirout (instance class_objinitroutine :obv_type ctype_value :oie_discr odiscr :oie_data ndrou :oie_locvar locvar :oie_cname (strbuf2string discr_string nambuf) :oir_procroutine oinipro )) ) (debug "compilobj_dataroutine oirout=" oirout "\n .. oinipro=" oinipro "\n.. npro=" npro "\n.. compicache=" compicache) (assert_msg "check oinipro" (is_object oinipro) oinipro) (mapobject_put compicache ndrou oirout) (debug "compilobj_dataroutine updated compicache=" compicache "\n.. ndrou=" ndrou "\n.. oirout=" oirout) (if (is_a npro class_nrep_routproc) (let ( (pconstl (get_field :nrclop_constlist npro)) (:long nbconst (list_length pconstl)) (bxoff (make_integerbox discr_integer 0)) (comm (unsafe_get_field :named_name '_iroutval_)) ) (debug "compilobj_dataroutine pconstl=" pconstl) (put_int oirout nbconst) (foreach_pair_component_in_list (pconstl) (constpair constx) (debug "compilobj_dataroutine constx=" constx) (cond ( (is_a constx class_nrep_constocc) (let ( (cnstbind (unsafe_get_field :nocc_bind constx)) ) (assert_msg "compilobj_dataroutine check cnstbind" (is_a cnstbind class_any_binding) cnstbind) (let ( (oconstx (compile_obj cnstbind gcx)) (:long off (get_int bxoff)) ) (debug "compilobj_dataroutine oconstx=" oconstx "\n.. off=" off) (if oconstx (let ( (iput (if (is_a cnstbind class_fixed_binding) (instance class_objputroutconstnotnull :obi_loc nloc :oprconst_rout oirout :oprconst_off (make_integerbox discr_integer off) :oprconst_cval oconstx) (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)))))) ) ( (is_a constx class_nrep_quasidata) (let ( (oconstx (compile_obj constx gcx)) (:long off (get_int bxoff)) ) (if oconstx (let ( (iput (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)))))) (:else (assert_msg "compilobj_dataroutine uneppected constx" () constx) ) ) ) ;end foreach_pair_component_in_list pconstl (if (>i (get_int bxoff) 0) (list_append inibody (instance class_objtouch :obi_loc nloc :otouch_val oirout :otouch_comment comm ))) (debug "compilobj_dataroutine final oirout=" oirout) oirout) )))) ) ) (install_method class_nrep_dataroutine compile_obj compilobj_dataroutine) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_datahook (ndhook gcx) (debug "compilobj_datahook ndhook=" ndhook "\n.. gcx=" gcx "\n") (shortbacktrace_dbg "compilobj_datahook" 16) (assert_msg "check ndhook" (is_a ndhook class_nrep_datahook) ndhook) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (compicache (unsafe_get_field :gncx_compicache gcx)) (inirout (unsafe_get_field :gncx_objrout gcx)) (chobj (mapobject_get compicache ndhook)) (nloc (get_field :nrep_loc ndhook)) ) (debug "compilobj_datahook compicache=" compicache) (assert_msg "check compicache" (is_mapobject compicache) compicache) (when chobj (debug "compilobj_datahook return chobj=" chobj) (return chobj)) (debug "compilobj_datahook inirout=" inirout) (assert_msg "check inirout" (is_a inirout class_any_start_routineobj) inirout) (let ( (nclotup (let ( (nct (get_field :ndhook_closv ndhook)) ) (debug "compilobj_datahook nclotup=" nct) nct)) (inibody (get_field :obrout_body inirout)) (:long nbclo (multiple_length nclotup)) (nhpro (get_field :ndhook_proc ndhook)) (hname (get_field :ndata_name ndhook)) ;a string (nrank (get_field :ndata_rank ndhook)) ;a boxed int (npredef (get_field :ndhook_predef ndhook)) ;a symbol or nil (nmodvarbind (get_field :ndhook_modvarbind ndhook)) ;a normal module variable binding or nil (nlocbind (get_field :ndata_locbind ndhook)) (ndisx (get_field :ndata_discrx ndhook)) (ndhdata (get_field :ndhook_data ndhook)) (odiscr (let ( (odi (compile_obj ndisx gcx)) ) (debug "compilobj_datahook odiscr=" odi) odi)) (onam (string4out discr_verbatim_string ##{dhook__$NRANK#__$HNAME}#)) (locvar (get_free_objlocptr gcx '_valhook_)) (oclo (make_multiple discr_multiple nbclo)) (ohkdata (let ( (o (compile_obj ndhdata gcx)) ) (debug "compilobj_datahook ohkdata=" o) o)) (oihook (instance class_objinithook :obv_type ctype_value :oie_locvar locvar :oie_cname onam :oie_data ndhook :oie_discr odiscr :oihk_data ohkdata :oihk_prochook nhpro :oihk_cloval oclo :oihk_predef npredef :oihk_modvarbind nmodvarbind )) ) (debug "compilobj_datahook before compiling nclotup=" nclotup) (foreach_in_multiple (nclotup) (ncurclo :long clix) (debug "compilobj_datahook clix#" clix " ncurclo=" ncurclo) (let ( (ocurclo (compile_obj ncurclo gcx)) ) (debug "compilobj_datahook clix#" clix " ocurclo=" ocurclo) (multiple_put_nth oclo clix ocurclo) )) (debug "compilobj_datahook oclo=" oclo) (mapobject_put compicache ndhook oihook) (put_int oihook (multiple_length oclo)) (debug "compilobj_datahook updated compicache=" compicache "\n.. nclotup=" nclotup "\n.. nhpro=" nhpro "\n.. oihook=" oihook "\n.. oclo=" oclo "\n.. inibody=" inibody) (when nmodvarbind (assert_msg "check nmodvarbind" (is_a nmodvarbind class_normal_module_variable_binding) nmodvarbind) (let ( (opmv (instance class_objputmodvar :obi_loc nloc :obputmodvar_bind nmodvarbind :obputmodvar_val oihook )) ) (list_append inibody opmv) (debug "compilobj_datahook opmv=" opmv) )) ;; set the data (let ( (ophd (instance class_objputhookdata :obi_loc nloc :ophkdata_hook oihook :ophkdata_data ohkdata)) ) (list_append inibody ophd) (debug "compilobj_datahook ophd=" ophd)) ;; set the components (debug "compilobj_datahook oclo=" oclo) (foreach_in_multiple (oclo) (curobc :long obix) (debug "compilobj_datahook curobc=" curobc " obix#" obix) (let ( (iput (instance class_objputhookconst :obi_loc nloc :ophconst_hook oihook :ophconst_off (constant_box obix) :ophconst_cval curobc )) ) (debug "compilobj_datahook obix=" obix ".. curobc=" curobc "\n.. iput=" iput) (list_append inibody iput) )) (when (multiple_length oclo) (list_append inibody (instance class_objtouch :obi_loc nloc :otouch_val oihook :otouch_comment hname ))) (debug "compilobj_datahook updated inibody=" inibody "\n.. final oihook=" oihook "\n") (return oihook) ))) (install_method class_nrep_datahook compile_obj compilobj_datahook) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_quasidata_current_module_environment_reference (qdcm gcx) (assert_msg "check qdcm" (is_a qdcm class_nrep_quasidata_current_module_environment_reference) qdcm) ;; the get_field below will fail if gcx is not a class_initial_generation_context (let ( (locbox (get_field :igncx_contenvloc gcx)) ) (return locbox))) (install_method class_nrep_quasidata_current_module_environment_reference compile_obj compilobj_quasidata_current_module_environment_reference) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_quasidata_parent_module_environment (qdpm gcx) (debug "compilobj_quasidata_parent_module_environment qdpm=" qdpm " gcx=" gcx) (assert_msg "check qdpm" (is_a qdpm class_nrep_quasidata_parent_module_environment) qdpm) ;; the get_field below will fail if gcx is not a class_initial_generation_context (let ( (prevenvloc (get_field :igncx_prevenvloc gcx)) ) (return prevenvloc))) (install_method class_nrep_quasidata_parent_module_environment compile_obj compilobj_quasidata_parent_module_environment) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_store_predefined (nspr gcx) (assert_msg "check nspr" (is_a nspr class_nrep_store_predefined) nspr) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_store_predefined start nspr=" nspr) (let ( (nloc (unsafe_get_field :nrep_loc nspr)) (npred (unsafe_get_field :nstpd_predef nspr)) (nval (unsafe_get_field :nstpd_value nspr)) (oval (compile_obj nval gcx)) (res ()) ) (cond ( (is_a npred class_symbol) (let ( (namepred (make_string discr_verbatim_string (get_field :named_name npred))) ) (setq res (make_objcompute nloc ctype_void ##{MELT_STORE_PREDEF($NAMEPRED, (melt_ptr_t) ($OVAL))}#))) ) ( (is_integerbox npred) (setq res (make_objcompute nloc ctype_void ##{melt_store_predefined($NPRED, (melt_ptr_t) ($OVAL))}#)) ) (:else (debug "compilobj_nrep_store_predefined bad npred=" npred) (assert_msg "compilobj_nrep_store_predefined invalid npred" () npred) (return)) ) (debug "compilobj_nrep_store_predefined result res=" res) res )) (install_method class_nrep_store_predefined compile_obj compilobj_nrep_store_predefined) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_update_current_module_environment_reference (nucmeb gcx) (assert_msg "check nucmeb" (is_a nucmeb class_nrep_update_current_module_environment_reference) nucmeb) (assert_msg "check gcx" (is_a gcx class_initial_generation_context) gcx) (debug "compilobj_nrep_update_current_module_environment_reference nucmeb=" nucmeb) (let ( (nloc (unsafe_get_field :nrep_loc nucmeb)) (ncomm (unsafe_get_field :ncumeb_comment nucmeb)) (nex (unsafe_get_field :nucmeb_expr nucmeb)) (pcml (unsafe_get_field :igncx_procurmodenvlist gcx)) (ocontenvloc (get_field :igncx_contenvloc gcx)) (csbuf (let ( (sb (make_strbuf discr_strbuf)) ) (add2sbuf_strconst sb "upd.cur.mod.env.cont") (if (is_string ncomm) (progn (add2sbuf_strconst sb " : ") (add2sbuf_string sb ncomm))) sb )) (obodl (make_list discr_list)) (ocblo (instance class_objcommentedblock :obi_loc nloc :oblo_bodyl obodl :ocomblo_comment (strbuf2string discr_string csbuf))) (oex (compile_obj nex gcx)) ) ;; get the igncx_procurmodenvlist from gcx ;; for each routine of class_procroutineobj get its nrpro_const list and ;; for each CLASS_NREP_QUASIDATA_CURRENT_MODULE_ENVIRONMENT_REFERENCE there do .... (foreach_pair_component_in_list (pcml) (curpair curout) (debug "compilobj_nrep_update_current_module_environment_reference curout=" curout) (if (is_a curout class_procroutineobj) (let ( (curproc (unsafe_get_field :obrout_proc curout)) (cnslis (get_field :nrclop_constlist curproc)) (datarout (unsafe_get_field :nrpro_datarout curproc)) (odatarout (compile_obj datarout gcx)) (boxcount (make_integerbox discr_integer 0)) (oroutlocvar (unsafe_get_field :oie_locvar odatarout)) ) (assert_msg "check odatarout" (is_a odatarout class_objinitroutine) odatarout) (list_every cnslis (lambda (curconst) (let ( (:long curcount (get_int boxcount)) ) (if (is_a curconst class_nrep_quasidata_current_module_environment_reference) ;; set into oroutlocvar the constant ranked curcount to oex ;; and touch it (let ( (oputrout (instance class_objputroutconst :obi_loc nloc :oprconst_rout oroutlocvar :oprconst_off (make_integerbox discr_integer curcount) :oprconst_cval oex )) (otouchrout (instance class_objtouch :obi_loc nloc :otouch_val oroutlocvar :otouch_comment '"compobj.upd.mod.env.box" )) (ocopy (instance class_objcompute :obi_loc nloc :obdi_destlist (list ocontenvloc) :obcpt_expr oex :obcpt_type ctype_value )) ) (list_append obodl oputrout) (list_append obodl otouchrout) (list_append obodl ocopy) ) ) ) )) (put_int boxcount (+i (get_int boxcount) 1)) ))) (debug "compobj.upd.mod.env.box result ocblo=" ocblo) (return ocblo) )) (install_method class_nrep_update_current_module_environment_reference compile_obj compilobj_nrep_update_current_module_environment_reference) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilobj_nrep_check_running_module_environment_container (nchmeb gcx) (debug "compilobj_nrep_check_running_module_environment_container nchmeb=" nchmeb "\n gcx=" gcx) (assert_msg "check nucmeb" (is_a nchmeb class_nrep_check_running_module_environment_container) nchmeb) (assert_msg "check gcx" (is_a gcx class_extension_generation_context) gcx) (let ( (nchcomm (get_field :nchrumod_comment nchmeb)) (nloc (get_field :nrep_loc nchmeb)) (ocontenvloc (get_field :igncx_contenvloc gcx)) (pcml (get_field :igncx_procurmodenvlist gcx)) (obodl (make_list discr_list)) (csbuf (make_strbuf discr_strbuf)) (locenv (get_free_objlocptr gcx '_curmodenv_)) ;stack location ;for the ;current ;environment (ocblo (instance class_objcommentedblock :obi_loc nloc :oblo_bodyl obodl :ocomblo_comment (progn (add2out csbuf "check.run.mod.env:" nchcomm) (strbuf2string discr_string csbuf)))) (ochkcont (make_objlocatedexp nloc ctype_void ##{ /*check running module environment reference*/ if (!melt_is_instance_of ((melt_ptr_t)$OCONTENVLOC, (melt_ptr_t) MELT_PREDEF(CLASS_REFERENCE))) melt_fatal_error ("MELT running extension with bad module environment reference @%p", (void*) $OCONTENVLOC) ; }#)) (ogetenv (make_objlocatedexp nloc ctype_void ##{ /*retrieve then check running module environment*/ $LOCENV = melt_reference_value ((melt_ptr_t)$OCONTENVLOC) ; if (!melt_is_instance_of ((melt_ptr_t) $LOCENV, (melt_ptr_t) MELT_PREDEF(CLASS_ENVIRONMENT))) melt_fatal_error ("MELT running extension with bad environment @%p in its reference @%p", (void*) $LOCENV, (void*) $OCONTENVLOC) ; }#)) ) (debug "compilobj_nrep_check_running_module_environment_container ocblo=" ocblo "\n ocontenvloc=" ocontenvloc) (debug "compilobj_nrep_check_running_module_environment_container ochkcont=" ochkcont "\n ogetenv=" ogetenv) (list_append obodl ochkcont) (list_append obodl ogetenv) (foreach_pair_component_in_list (pcml) (curpair curout) (debug "compilobj_nrep_update_current_module_environment_reference curout=" curout) (if (is_a curout class_procroutineobj) (let ( (curproc (unsafe_get_field :obrout_proc curout)) (cnslis (get_field :nrclop_constlist curproc)) (datarout (unsafe_get_field :nrpro_datarout curproc)) (odatarout (compile_obj datarout gcx)) (boxcount (make_integerbox discr_integer 0)) (oroutlocvar (unsafe_get_field :oie_locvar odatarout)) ) (assert_msg "check odatarout" (is_a odatarout class_objinitroutine) odatarout) (list_every cnslis (lambda (curconst) (let ( (:long curcount (get_int boxcount)) ) (if (is_a curconst class_nrep_quasidata_current_module_environment_reference) ;; set into oroutlocvar the constant ranked curcount to oex ;; and touch it (let ( (oputrout (instance class_objputroutconst :obi_loc nloc :oprconst_rout oroutlocvar :oprconst_off (make_integerbox discr_integer curcount) :oprconst_cval ocontenvloc )) (otouchrout (instance class_objtouch :obi_loc nloc :otouch_val oroutlocvar :otouch_comment '"updat.cur.running.mod.env" )) ) (list_append obodl oputrout) (list_append obodl otouchrout) ) ) ) )) (put_int boxcount (+i (get_int boxcount) 1)) ))) (list_append obodl (instance class_objclear :obi_loc nloc :oclr_vloc locenv)) (dispose_objloc locenv gcx) (debug "compilobj_nrep_check_running_module_environment_container gives ocblo=" ocblo) (return ocblo) )) (install_method class_nrep_check_running_module_environment_container compile_obj compilobj_nrep_check_running_module_environment_container) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; selector to compile a matcher ;; receiver: some indirect instance of class_any_matcher ;; arguments: ;;; * the match compilation context ;;; * the generation context ;;; (defselector compile_matcher class_selector ) (export_values compile_matcher) (defclass class_matchcompilcontext :super class_proped :fields (mcx_loc ;the location of the matcher mcx_normtester ;the normtester mcx_gotothen ;the goto then part mcx_gotoelse ;the goto else part mcx_olist ;the objcode list to be filled mcx_suffix ;the suffix for state expansion mcx_statecounter ;boxed counter for state expansion )) (export_class class_matchcompilcontext) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; selector to compile a tester ;;;; receiver: the tester ;;;; first argument: the generator context gcx ;;;; second argument: the tester context tcx ;;;; return values: primary, the objcode or lists; secondary the destination objcode (defselector compile_tester class_selector :doc #{Compile a tester $RECV for matching with generator context $GCX and tester context $TCX. Return the compiled tester and secondarily the destination.}# :formals (recv gcx tcx) ) (export_values compile_tester) (defclass class_testercompilcontext :super class_proped :fields (tcx_nrmatch ;the nrep_matcher tcx_freelist ;the list of free objloc tcx_nextest ;the next test )) (export_class class_testercompilcontext) ;;;; catch all (defun compiltst_anytester (ntester gcx tcx) (assert_msg "check ntester" (is_a ntester class_normtester_any) ntester) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (debug ntester "compiltst_anytester ntester=" ntester) (outcstring_err "* compiltst unimplemented receiver class ") (let ( (discr (discrim ntester)) ) (outstr_err (unsafe_get_field :named_name discr))) (outnewline_err) (assert_msg "@@compile_tester should be implemented in normtesters-s subclasses" () ntester) ) (install_method class_normtester_any compile_tester compiltst_anytester) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; compilation of old matches (defun compilobj_nrep_match (nmat gcx) (assert_msg "check nmat" (is_a nmat class_nrep_match) nmat) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "compilobj_nrep_match nmat=" nmat) (let ( (nloc (unsafe_get_field :nrep_loc nmat)) (nctyp (unsafe_get_field :nexpr_ctyp nmat)) (ntests (unsafe_get_field :nmatch_tests nmat)) (stuffmap (unsafe_get_field :nmatch_stuffmap nmat)) (nmatched (get_field :nmatch_matched nmat)) (matmap (unsafe_get_field :gncx_matchmap gcx)) (matlabel (let ( (:long nbmat (mapobject_count matmap)) (labuf (make_strbuf discr_strbuf)) ) (add2sbuf_strconst labuf "mtch") (add2sbuf_longdec labuf (+i nbmat 1)) (add2sbuf_strconst labuf "_") (let ( (labstr (strbuf2string discr_verbatim_string labuf)) ) (mapobject_put matmap nmat labstr) (debug "compilobj_nrep_match matlabel labstr=" labstr) labstr ))) (endlabel (let ( (labuf (make_strbuf discr_strbuf)) ) (add2sbuf_string labuf matlabel) (add2sbuf_strconst labuf "_end") (strbuf2string discr_verbatim_string labuf))) ;; the list of suborders for putobjdest dispatch... ;; should be the *last* of each sequence added... (subcomplist (make_list discr_list)) (obodyl (make_list discr_list)) (ombloc (instance class_objmultiblock :obi_loc nloc :oblo_bodyl obodyl :omulblo_subcomp () )) (ofirstgoto (instance class_objgotoinstr :obi_loc nloc :obgoto_prefix matlabel :obgoto_rank (make_integerbox discr_integer 0) )) (oendlabel (instance class_objlabelinstr :obi_loc nloc :oblab_prefix endlabel :oblab_rank ())) (tcx (instance class_testercompilcontext :tcx_nrmatch nmat :tcx_freelist (make_list discr_list) :tcx_nextest () ;updated below )) (donetests (make_list discr_list)) (omatched (progn (debug "compilobj_nrep_match nmatched=" nmatched) (compile_obj nmatched gcx))) ) (list_append obodyl ofirstgoto) (debug "compilobj_nrep_match ntests=" ntests " omatched=" omatched " oendlabel=" oendlabel) (foreach_in_multiple (ntests) (curotest :long testix) (debug "compilobj_nrep_match curotest=" curotest " testix=" testix) (assert_msg "check curotest" (is_a curotest class_normtester_any) curotest) (assert_msg "check curotest rank" (==i (get_int curotest) testix) testix) ;; do we have both then & else? (compile_warning ;; we probably don't need to test the curnthen & curntest; they ;; probably are set... "probably useless tests - the then & else parts are here!" ()) (if (is_a curotest class_normtester_anytester) (let ( (curnthen (get_field :ntest_then curotest)) (curnelse (get_field :ntest_else curotest)) ) (cond ( (null curnthen) (debug "compilobj_nrep_match with null then curotest=" curotest) (shortbacktrace_dbg "compilobj_nrep_match curotest has null then" 14) ) ( (null curnelse) (debug "compilobj_nrep_match with null else curotest=" curotest) (shortbacktrace_dbg "compilobj_nrep_match curotest has null else" 14) ) ))) (let ( (labins (normtester_labelinstr curotest gcx)) (curnmatched (get_field :ntest_matched curotest)) ) (debug "compilobj_nrep_match labins=" labins) (let ( (nextest (multiple_nth ntests (+i testix 1))) ) (put_fields tcx :tcx_nextest nextest) (debug "compilobj_nrep_match nextest=" nextest " tcx=" tcx)) (multicall (curcomp curobdest) (compile_tester curotest gcx tcx) (debug "compilobj_nrep_match curcomp=" curcomp "curobdest=" curobdest) (assert_msg "check curcomp" curcomp) ;; always add the labins and the curcomp or its element into obodyl (list_append obodyl labins) (cond ( (is_list curcomp) (let ( (lastlicomp (pair_head (list_last curcomp))) ) (debug "compilobj_nrep_match lastlicomp=" lastlicomp) (list_append2list obodyl curcomp) )) ( (is_multiple curcomp) (let ( (lastupcomp (multiple_nth curcomp -1)) ) (debug "compilobj_nrep_match lastupcomp=" lastupcomp) (foreach_in_multiple (curcomp) (subtest :long subix) (list_append obodyl subtest)) )) ( (is_object curcomp) (debug "compilobj_nrep_match obj curcomp=" curcomp) (list_append obodyl curcomp) ) (:else (assert_msg "unexpected curcomp" () curcomp) )) ;; add into subcomplist the curobdest if not null (if curobdest (list_append subcomplist curobdest)) ;; (list_append donetests curotest) ;; dispose some stuff (let ( (disposablist (make_list discr_list)) ) (debug "compilobj_nrep_match disposing curotest=" curotest) (cond ;; if the current test is a success, we can dispose all the ;; stuff which has already been tested ( (is_a curotest class_normtester_success) (mapobject_every stuffmap (lambda (stuff stutests) (if (!= stuff omatched) (let ( (remstuff stuff) ) (foreach_pair_component_in_list (stutests) (testpair curtest) (if (list_find donetests curtest) (setq testpair ()) (setq remstuff ())) ) (if remstuff (list_append disposablist remstuff)) ))))) ;; if the curnmatched is the nmatched, we do nothing ;; because we cannot dispose it ( (== curnmatched nmatched) (debug "compilobj_nrep_match curnmatched == nmatched=" nmatched) ) ;; if the current test is not a success and the curnmatched ;; is an object, we can dispose it if all its stuff has been ;; tested ( (is_object curnmatched) (debug curnmatched "compilobj_nrep_match disposing curnmatched=" curnmatched " omatched=" omatched) (let ( (stutests (mapobject_get stuffmap curnmatched)) ) (let ( (remstuff curnmatched) ) (foreach_pair_component_in_list (stutests) (testpair curtest) (if (list_find donetests curtest) (setq testpair ()) (setq remstuff ())) ) (if remstuff (list_append disposablist remstuff)) )))) ;;; dispose all the stuff in the disposablist (debug "compilobj_nrep_match disposablist=" disposablist) (foreach_pair_component_in_list (disposablist) (dispair dispstuff) (mapobject_remove stuffmap dispstuff) (debug "compilobj_nrep_match dispstuff=" dispstuff) (let ( (dispobj (compile_obj dispstuff gcx)) ) (debug "compilobj_nrep_match dispobj=" dispobj) (assert_msg "check dispobj" (is_a dispobj class_objlocv) dispobj) ;; but never dispose omatched itself (if (!= dispobj omatched) (dispose_objloc dispobj gcx) (debug "compilobj_nrep_match dont dispose omatched=" omatched)) )))))) (list_append obodyl oendlabel) (put_fields ombloc :omulblo_subcomp (list_to_multiple subcomplist discr_multiple)) (debug "compilobj_nrep_match return ombloc=" ombloc) (return ombloc ()) )) (install_method class_nrep_match compile_obj compilobj_nrep_match) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass class_alternate_match_nrep_data :super class_root :fields (altmatchn_prev ;the previous altmatchn_number ;unique number altmatchn_nrep ;the current nrep_matchalt altmatchn_flagmap ;mapping from match flags to objflags altmatchn_datamap ;mapping from nrep matched data to objvalues altmatchn_stepmap ;mapping from match steps to their unique number altmatchn_labprefix ;string prefix for labels ) ) (export_class class_alternate_match_nrep_data) ;;;; compilation of alternate matches (defun compilobj_nrep_matchalt (nmat gcx) (debug "compilobj_nrep_matchalt nmat=" nmat "\n** gcx=" gcx "\n** class_objmatchflagblock=" class_objmatchflagblock "\n") (assert_msg "check nmat" (is_a nmat class_nrep_matchalt) nmat) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (unsafe_get_field :nrep_loc nmat)) (nctyp (unsafe_get_field :nexpr_ctyp nmat)) (nmatched (unsafe_get_field :namatch_matched nmat)) (nres (unsafe_get_field :namatch_result nmat)) (nbody (unsafe_get_field :namatch_body nmat)) (nflags (unsafe_get_field :namatch_flags nmat)) (nmdatas (unsafe_get_field :namatch_mdatas nmat)) (nstartlab (get_field :namatch_startlabel nmat)) (obodyl (make_list discr_list)) (oldaltmatch (get_field :gncx_altmatch gcx)) (oldmatchnum (or (get_field :altmatchn_number oldaltmatch) '0)) (matchnum (+ivi oldmatchnum 1)) (oflagmap (make_mapobject discr_map_objects (+i 5 (*i 2 (multiple_length nflags))))) (odatamap (make_mapobject discr_map_objects (+i 7 (*i 2 (multiple_length nmdatas))))) (ostepmap (make_mapobject discr_map_objects (+i 13 (*i 3 (multiple_length nmdatas))))) (labprefix (string4out discr_verbatim_string "_meltmatchaltlab" matchnum "_")) (altmatch (instance class_alternate_match_nrep_data :altmatchn_prev oldaltmatch :altmatchn_number matchnum :altmatchn_nrep nmat :altmatchn_flagmap oflagmap :altmatchn_datamap odatamap :altmatchn_stepmap ostepmap :altmatchn_labprefix labprefix ))) (debug "compilobj_nrep_matchalt nmatched=" nmatched "\n nres=" nres "\n nflags=" nflags "\n nctyp=" nctyp "\n nbody=" nbody "\n oldaltmatch=" oldaltmatch "\n new altmatch=" altmatch) (put_fields gcx :gncx_altmatch altmatch) (let ( (nsymbres (get_field :nocc_symb nres)) (obvares (get_free_objloctyped gcx nsymbres nctyp)) (ocleares (instance class_objclear :obi_loc nloc :oclr_vloc obvares)) ) (list_append obodyl ocleares) ;; (debug "compilobj_nrep_matchalt nflags=" nflags) (let ( (oflags (multiple_map nflags (lambda (curnflag :long fix) (debug "compilobj_nrep_matchalt/lambda curnflag=" curnflag " fix=" fix) (let ( (curoflag (compile_obj curnflag gcx)) ) (debug "compilobj_nrep_matchalt/lambda curoflag=" curoflag) (return curoflag)))) ) (oblock (instance class_objmatchflagblock :obi_loc nloc :omchflgblo_flags oflags :oblo_bodyl obodyl)) ) (debug "compilobj_nrep_matchalt oflags=" oflags "\n oblock=" oblock "\n nbody=" nbody "\n nstartlab=" nstartlab) ;; ;; fill the stepmap from class_nrep_match_label occurrences (foreach_in_multiple (nbody) (curncomp :long bodix) (debug "compilobj_nrep_matchalt stepmap bodix#" bodix " curncomp=" curncomp) (if (is_a curncomp class_nrep_match_label) (let ( (labstep (get_field :nmlab_step curncomp)) (:long stepcount (mapobject_count ostepmap)) (stepnum (constant_box (+i stepcount 1))) ) (debug "compilobj_nrep_matchalt labstep=" labstep "\n stepnum=" stepnum) (assert_msg "check labstep" (or (is_a curncomp class_nrep_match_label_end) (is_a labstep class_match_step)) labstep) (assert_msg "check unknown labstep" (null (mapobject_get ostepmap labstep)) labstep ostepmap) (if labstep (mapobject_put ostepmap labstep stepnum)) )) ) (debug "compilobj_nrep_matchalt ostepmap=" ostepmap "\n.. nbody=" nbody) ;; (foreach_in_multiple (nbody) (curncomp :long bodix) (debug "compilobj_nrep_matchalt curncomp=" curncomp " bodix=" bodix) (let ( (curocomp (compile_obj curncomp gcx)) ) (debug "compilobj_nrep_matchalt curocomp=" curocomp) (assert_msg "check curocomp object" (is_object curocomp) curocomp) (if (and (== curncomp nstartlab) (is_a curncomp class_nrep_match_label)) ;; we forcibly add a goto to the first label step, to ;; avoid a label without goto warning from gcc ;; compiling the generated code (let ( (startstep (get_field :nmlab_step nstartlab)) (ostartjump (instance class_objgotoinstr :obgoto_prefix labprefix :obgoto_rank (mapobject_get ostepmap startstep))) ) (debug "compilobj_nrep_matchalt ostartjump=" ostartjump "\n startstep=" startstep "\n ostepmap=" ostepmap) (list_append obodyl ostartjump) )) (list_append obodyl curocomp) )) ;; we need to append the result at end of body (list_append obodyl obvares) ;; (debug "compilobj_nrep_matchalt obodyl=" obodyl) (dispose_objloc obvares gcx) (put_fields gcx :gncx_altmatch oldaltmatch) ;; (debug "compilobj_nrep_matchalt restored gcx=" gcx "\n* obodyl=" obodyl "\n* result oblock=" oblock "\n*****\n") (return oblock) )))) (install_method class_nrep_matchalt compile_obj compilobj_nrep_matchalt) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchlabel (nmlab gcx) (debug "compilobj_nrep_matchlabel nmlab=" nmlab " gcx=" gcx) (assert_msg "check nmlab" (is_a nmlab class_nrep_match_label) nmlab) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (get_field :nrep_loc nmlab)) (nstep (get_field :nmlab_step nmlab)) (altmatchdata (get_field :gncx_altmatch gcx)) (labprefix (get_field :altmatchn_labprefix altmatchdata)) (ostepmap (get_field :altmatchn_stepmap altmatchdata)) (stepnum (mapobject_get ostepmap nstep)) ) (debug "compilobj_nrep_matchlabel nstep=" nstep "\n stepnum=" stepnum "\n labprefix=" labprefix) (assert_msg "check altmatchdata" (is_a altmatchdata class_alternate_match_nrep_data) altmatchdata) (assert_msg "check nstep" (is_a nstep class_match_step) nstep) (assert_msg "check stepnum" (is_integerbox stepnum) stepnum) (assert_msg "check labprefix" (is_string labprefix) labprefix) (shortbacktrace_dbg "compilobj_nrep_matchlabel" 12) (let ( (olabinstr (instance class_objlabelinstr :obi_loc nloc :oblab_prefix labprefix :oblab_rank stepnum)) ) (debug "compilobj_nrep_matchlabel result olabinstr=" olabinstr) (return olabinstr) ))) (install_method class_nrep_match_label compile_obj compilobj_nrep_matchlabel) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchlabelend (nmlab gcx) (debug "compilobj_nrep_matchlabelend nmlab=" nmlab " gcx=" gcx) (assert_msg "check nmlab" (is_a nmlab class_nrep_match_label_end) nmlab) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (get_field :nrep_loc nmlab)) (altmatchdata (get_field :gncx_altmatch gcx)) (labprefix (get_field :altmatchn_labprefix altmatchdata)) ) (debug "compilobj_nrep_matchlabel labprefix=" labprefix) (assert_msg "check labprefix" (is_string labprefix) labprefix) (shortbacktrace_dbg "compilobj_nrep_matchlabel" 12) (let ( (olabinstr (instance class_objlabelinstr :obi_loc nloc :oblab_prefix (string4out discr_verbatim_string labprefix "_end") ) ) ) (debug "compilobj_nrep_matchlabel resultend olabinstr=" olabinstr) (return olabinstr) ))) (install_method class_nrep_match_label_end compile_obj compilobj_nrep_matchlabelend) ;;;;;;;;;;;;;;;; ;; the compilation of a match flag should give a (defun compilobj_nrep_matchflag (nmflag gcx) (debug "compilobj_nrep_matchflag nmflag=" nmflag "\n of discrim=" (discrim nmflag) "\n** gcx=" gcx) (assert_msg "check nmflag" (is_a nmflag class_nrep_match_flag) nmflag) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (unsafe_get_field :nrep_loc nmflag)) (nrfla (unsafe_get_field :nrpfla_flag nmflag)) (nrmatch (unsafe_get_field :nrpfla_nmatch nmflag)) (altmatchdata (get_field :gncx_altmatch gcx)) (oflagmap (get_field :altmatchn_flagmap altmatchdata)) ) (debug "compilobj_nrep_matchflag nrfla=" nrfla " nrmatch=" nrmatch " oflagmap=" oflagmap) (assert_msg "check oflagmap" (is_mapobject oflagmap) oflagmap) (let ( (objmf (mapobject_get oflagmap nmflag)) ) (if objmf (progn (debug "compilobj_nrep_matchflag found & returning objmf=" objmf) (assert_msg "check ojbmf" (is_a objmf class_objflag) objmf) (return objmf))) (setq objmf (instance class_objflag :obv_type ctype_long :obflag_matchflag nmflag :obflag_name (get_field :mflag_string nrfla) :obflag_rank (get_field :mflag_rank nrfla))) (mapobject_put oflagmap nmflag objmf) (debug "compilobj_nrep_matchflag new objmf=" objmf " in updated oflagmap=" oflagmap) (shortbacktrace_dbg "compilobj_nrep_matchflag" 15) (return objmf) ))) (install_method class_nrep_match_flag compile_obj compilobj_nrep_matchflag) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchdatainit (nmdat gcx) (debug "compilobj_nrep_matchdatainit nmdat=" nmdat "\n of discr=" (discrim nmdat) "\n gcx=" gcx) (assert_msg "check nmdat" (is_a nmdat class_nrep_match_data_initializer) nmdat) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (unsafe_get_field :nrep_loc nmdat)) (ndata (get_field :nmdac_data nmdat)) (ndatatype (get_field :nrmatd_ctype ndata)) (ndatarank (get_field :nrmatd_rank ndata)) (matdata (get_field :nrmatd_mdata ndata)) (altmatch (get_field :gncx_altmatch gcx)) (symb (or (get_field :mdata_symb matdata) (clone_symbol 'matchdata))) ) (shortbacktrace_dbg "compilobj_nrep_matchdatainit" 10) (debug "compilobj_nrep_matchdatainit ndata=" ndata "\n* ndatatype=" ndatatype "\n* ndatarank=" ndatarank "\n* matdata=" matdata "\n* altmatch=" altmatch "\n* symb=" symb) (let ( (obvloc (get_free_objloctyped gcx symb ndatatype)) (aldatamap (get_field :altmatchn_datamap altmatch)) (obcl (instance class_objclear :obi_loc nloc :oclr_vloc obvloc)) ) (debug "compilobj_nrep_matchdatainit obvloc=" obvloc "\n* obcl=" obcl "\n* aldatamap=" aldatamap) (assert_msg "unknown ndata in aldatamap" (null (mapobject_get aldatamap ndata)) ndata aldatamap) (mapobject_put aldatamap ndata obvloc) (debug "compilobj_nrep_matchdatainit updated aldatamap=" aldatamap "\n*return obcl=" obcl) (return obcl) ))) (install_method class_nrep_match_data_initializer compile_obj compilobj_nrep_matchdatainit) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchdataclear (nmc gcx) (debug "compilobj_nrep_matchdataclear nmc=" nmc "\n gcx=" gcx) (assert_msg "check nmc" (is_a nmc class_nrep_match_data_clear) nmc) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (get_field :nrep_loc nmc)) (ndata (get_field :nmdac_data nmc)) (odata (compile_obj ndata gcx)) (oclear (instance class_objclear :obi_loc nloc :oclr_vloc odata)) ) (debug "compilobj_nrep_matchdataclear odata=" odata "\n result oclear=" oclear) (return oclear) )) (install_method class_nrep_match_data_clear compile_obj compilobj_nrep_matchdataclear) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchdatafinal (nmdatf gcx) (debug "compilobj_nrep_matchdatafinal nmdatf=" nmdatf "\n of discr=" (discrim nmdatf) "\n gcx=" gcx) (assert_msg "check nmdatf" (is_a nmdatf class_nrep_match_data_finalizer) nmdatf) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (shortbacktrace_dbg "compilobj_nrep_matchdatafinal" 10) (let ( (nloc (unsafe_get_field :nrep_loc nmdatf)) (ndata (unsafe_get_field :nmdac_data nmdatf)) (odata (compile_obj ndata gcx)) ;; no need to clear odata, it is already cleared before ) (debug "compilobj_nrep_matchdatafinal ndata=" ndata "\n disposing odata=" odata "\n nmdatf=" nmdatf) (dispose_objloc odata gcx) (debug "compilobj_nrep_matchdatafinal end nmdatf=" nmdatf) (return) )) (install_method class_nrep_match_data_finalizer compile_obj compilobj_nrep_matchdatafinal) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchedata (nmdat gcx) (debug "compilobj_nrep_matchedata nmdat=" nmdat "\n of discr=" (discrim nmdat) "\n gcx=" gcx) (assert_msg "check nmdat" (is_a nmdat class_nrep_matched_data) nmdat) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (unsafe_get_field :nrep_loc nmdat)) (nctype (unsafe_get_field :nrmatd_ctype nmdat)) (nrmdata (get_field :nrmatd_mdata nmdat)) (nrmrank (get_field :nrmatd_rank nmdat)) (altmatch (get_field :gncx_altmatch gcx)) (aldatamap (get_field :altmatchn_datamap altmatch)) (obmdat (mapobject_get aldatamap nmdat)) ) (shortbacktrace_dbg "compilobj_nrep_matcheddata" 10) (debug "compilobj_nrep_matchedata altmatch=" altmatch "\n aldatamap=" aldatamap "\n obmdat=" obmdat "\n.. of discrim=" (discrim obmdat)) (assert_msg "check obmdat" (is_a obmdat class_objvalue) obmdat) (return obmdat) )) (install_method class_nrep_matched_data compile_obj compilobj_nrep_matchedata) ;;;;;;;;;;;;;;;; (defun compilobj_nrep_matchjump (nmjump gcx) (debug "compilobj_nrep_matchjump nmjump=" nmjump "\n of discr=" (discrim nmjump) "\n gcx=" gcx) (assert_msg "check nmjump" (is_a nmjump class_nrep_match_jump) nmjump) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (nloc (unsafe_get_field :nrep_loc nmjump)) (altmatchdata (get_field :gncx_altmatch gcx)) (nmlab (get_field :nmjmp_label nmjump)) (labprefix (get_field :altmatchn_labprefix altmatchdata)) ) (debug "compilobj_nrep_matchjump altmatchdata=" altmatchdata "\n *nmlab=" nmlab) (assert_msg "check altmatchdata" (is_a altmatchdata class_alternate_match_nrep_data) altmatchdata) (let ( (objgotomins (cond ((is_a nmlab class_nrep_match_label_end) (debug "compilobj_nrep_matchjump ending nmlab=" nmlab) (instance class_objgotoinstr :obi_loc nloc :obgoto_prefix (string4out discr_verbatim_string labprefix "_end") )) ((is_a nmlab class_nrep_match_label) (let ( (nstep (get_field :nmlab_step nmlab)) (ostepmap (get_field :altmatchn_stepmap altmatchdata)) (stepnum (mapobject_get ostepmap nstep)) ) (debug "compilobj_nrep_matchjump nstep=" nstep "\n *stepnum=" stepnum) (instance class_objgotoinstr :obi_loc nloc :obgoto_prefix labprefix :obgoto_rank stepnum))) (:else (assert_msg "unexpected nmlab" () nmlab)))) ) (debug "compilobj_nrep_matchjump result objgotomins=" objgotomins) (return objgotomins) ))) (install_method class_nrep_match_jump compile_obj compilobj_nrep_matchjump) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; utility function to return the label instr of a tester (defun normtester_labelinstr (nt gcx) (debug "normtester_labelinstr start nt=" nt) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (if (is_not_a nt class_normtester_any) (progn (debug "normtester_labelinstr return nil") (return))) (let ( (nloc (unsafe_get_field :nrep_loc nt)) (:long ntestix (get_int nt)) (normatch (unsafe_get_field :ntest_normatch nt)) (matchmap (unsafe_get_field :gncx_matchmap gcx)) ) (assert_msg "check normatch" (is_a normatch class_nrep_match) normatch) (assert_msg "check valid normatch" (== (multiple_nth (get_field :nmatch_tests normatch) ntestix) nt) normatch ntestix) (let ( (prefix (mapobject_get matchmap normatch)) (labins (instance class_objlabelinstr :obi_loc nloc :oblab_prefix prefix :oblab_rank nt)) ) (debug "normtester_labelinstr result labins=" labins) (assert_msg "check prefix" (is_string prefix) prefix) (return labins) ))) ;; utility function to return the goto instr into a tester (defun normtester_gotoinstr (nt gcx) (debug "normtester_gotoinstr start nt=" nt) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (if (is_not_a nt class_normtester_any) (progn (debug "normtester_gotoinstr return nil") (return))) (let ( (nloc (unsafe_get_field :nrep_loc nt)) (:long ntestix (get_int nt)) (normatch (unsafe_get_field :ntest_normatch nt)) (matchmap (unsafe_get_field :gncx_matchmap gcx)) ) (debug "normtester_gotoinstr normatch=" normatch) (assert_msg "check normatch" (is_a normatch class_nrep_match) normatch) (assert_msg "check valid normatch" (== (multiple_nth (get_field :nmatch_tests normatch) ntestix) nt) normatch ntestix) (let ( (prefix (mapobject_get matchmap normatch)) (goins (instance class_objgotoinstr :obi_loc nloc :obgoto_prefix prefix :obgoto_rank nt)) ) (debug "normtester_gotoinstr result goins=" goins) (assert_msg "check prefix" (is_string prefix) prefix) (return goins) ))) ;;; utility function to return the goto instr at end of matcher (defun endmatch_gotoinstr (nma gcx nloc) (assert_msg "check nma" (is_a nma class_nrep_match) nma) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (debug "endmatch_gotoinstr nma=" nma) (shortbacktrace_dbg "endmatch_gotoinstr" 15) (let ( (matchmap (unsafe_get_field :gncx_matchmap gcx)) (prefix (mapobject_get matchmap nma)) (labuf (make_strbuf discr_strbuf)) ) (add2sbuf_string labuf prefix) (add2sbuf_strconst labuf "_end /*endmatch*/") (let ( (goins (instance class_objgotoinstr :obi_loc nloc :obgoto_prefix (strbuf2string discr_verbatim_string labuf) :obgoto_rank ())) ) (debug "endmatch_gotoinstr goins=" goins) (return goins) ))) ;; utility function to return the goto instr to a given tester (defun testmatch_gotoinstr (ntest nma gcx nloc) (debug "testmatch_gotoinstr ntest=" ntest) (assert_msg "check ntest" (is_a ntest class_normtester_any) ntest) (assert_msg "check nma" (is_a nma class_nrep_match) nma) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (shortbacktrace_dbg "testmatch_gotoinstr" 15) (let ( (matchmap (unsafe_get_field :gncx_matchmap gcx)) (prefix (mapobject_get matchmap nma)) (labuf (make_strbuf discr_strbuf)) ) (add2sbuf_string labuf prefix) (add2sbuf_longdec labuf (get_int ntest)) (add2sbuf_strconst labuf " /*testmatch*/") (let ( (goins (instance class_objgotoinstr :obi_loc nloc :obgoto_prefix (strbuf2string discr_verbatim_string labuf) :obgoto_rank ())) ) (debug "testmatch_gotoinstr goins=" goins) (return goins) ))) ;;; utility function to get free objloc for the local occurrences of a tester (defun normtester_free_objloc_list (nt gcx tcx) (debug "normtester_free_objloc_list nt=" nt) (assert_msg "check nt" (is_a nt class_normtester_any) nt) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloclist (unsafe_get_field :ntest_locclist nt)) (locmap (unsafe_get_field :gncx_locmap gcx)) ) (debug "normtester_free_objloc_list nloclist=" nloclist) (shortbacktrace_dbg "normtester_free_objloc_list" 15) (let ( (freelist (list_map nloclist (lambda (nloc) (assert_msg "check nloc" (is_a nloc class_nrep_locsymocc) nloc) (let ( (oblo (get_free_objloctyped gcx (get_field :nocc_symb nloc) (get_field :nocc_ctyp nloc) )) ) (mapobject_put locmap (get_field :nocc_bind nloc) oblo) oblo )))) ) (list_append2list (get_field :tcx_freelist tcx) freelist) (debug "normtester_free_objloc_list result freelist=" freelist) (return freelist) ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; catch-all for unimplemented normtester (defun compiltst_normtester_any (nta gcx tcx) (debug "compiltst_normtester_any nta=" nta "\n of discrim " (discrim nta) "\n gcx=" gcx " tcx=" tcx) (error_strv (get_field :nrep_loc nta) "**UNIMPLEMENTED normal tester compilation " (get_field :named_name (discrim nta))) (assert_msg "@$@UNIMPLEMENTED normal tester compilation" () nta gcx tcx) ) (install_method class_normtester_any compile_tester compiltst_normtester_any) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compiltst_normtester_matcher (ntma gcx tcx) (debug "compiltst_normtester_matcher ntma=" ntma) (assert_msg "check ntma" (is_a ntma class_normtester_matcher) ntma) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntma)) (nmatched (unsafe_get_field :ntest_matched ntma)) (nthen (unsafe_get_field :ntest_then ntma)) (nelse (unsafe_get_field :ntest_else ntma)) (nmatcher (unsafe_get_field :ntmatch_matcher ntma)) (nins (unsafe_get_field :ntmatch_inargs ntma)) (nouts (unsafe_get_field :ntmatch_outlocs ntma)) (normatch (unsafe_get_field :ntest_normatch ntma)) (gotothen (normtester_gotoinstr nthen gcx)) (gotoelse (normtester_gotoinstr nelse gcx)) (olist (make_list discr_list)) (matchmap (unsafe_get_field :gncx_matchmap gcx)) (prefix (mapobject_get matchmap normatch)) (freelist (normtester_free_objloc_list ntma gcx tcx)) (nextest (get_field :tcx_nextest tcx)) ) (debug "compiltst_normtester_matcher matchmap=" matchmap " nextest=" nextest " gotothen=" gotothen) (cond ( (null gotothen) (shortbacktrace_dbg "compiltst_normtester_matcher null gotothen" 14) (setq gotothen (if nextest (testmatch_gotoinstr nextest normatch gcx nloc) (endmatch_gotoinstr normatch gcx nloc))) (debug "compiltst_normtester_matcher fixed gotothen=" gotothen) )) (debug "compiltst_normtester_matcher unfixed gotoelse=" gotoelse) (cond ( (null gotoelse) (shortbacktrace_dbg "compiltst_normtester_matcher null gotoelse" 14) (setq gotoelse (if nextest (testmatch_gotoinstr nextest normatch gcx nloc) (endmatch_gotoinstr normatch gcx nloc))) (debug "compiltst_normtester_matcher fixed gotoelse=" gotoelse) )) (debug "compiltst_normtester_matcher freelist=" freelist " prefix=" prefix) (assert_msg "check prefix" (is_string prefix) prefix) ;; clear the freelist (foreach_pair_component_in_list (freelist) (locpair obloc) (assert_msg "check obloc" (is_a obloc class_objlocv) obloc) (let ( (oclearob (instance class_objclear :obi_loc nloc :oclr_vloc obloc )) ) (list_append olist oclearob) )) (debug "compiltst_normtester_matcher before nmatcher=" nmatcher) (let ( (matcx (instance class_matchcompilcontext :mcx_loc nloc :mcx_normtester ntma :mcx_gotothen gotothen :mcx_gotoelse gotoelse :mcx_olist olist :mcx_suffix prefix :mcx_statecounter (make_integerbox discr_integer 0) )) ) (debug "compiltst_normtester_matcher matcx=" matcx) (compile_matcher nmatcher matcx gcx) (debug "compiltst_normtester_matcher return olist=" olist) (return olist ()) ) )) (install_method class_normtester_matcher compile_tester compiltst_normtester_matcher) ;;;;;;;;;;;;;;;; (defun compiltst_normtester_instance (ntmi gcx tcx) (debug "compiltst_normtester_instance ntmi=" ntmi) (assert_msg "check ntmi" (is_a ntmi class_normtester_instance) ntmi) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntmi)) (nmatched (unsafe_get_field :ntest_matched ntmi)) (nthen (unsafe_get_field :ntest_then ntmi)) (nelse (unsafe_get_field :ntest_else ntmi)) (normatch (unsafe_get_field :ntest_normatch ntmi)) (nlocclist (unsafe_get_field :ntest_locclist ntmi)) (olist (make_list discr_list)) (:long ntestix (get_int ntmi)) (ntclass (unsafe_get_field :ntinst_class ntmi)) (ntflds (unsafe_get_field :ntinst_fieldlocs ntmi)) (gotothen (or (normtester_gotoinstr nthen gcx) (endmatch_gotoinstr normatch gcx nloc))) (gotoelse (or (normtester_gotoinstr nelse gcx) (endmatch_gotoinstr normatch gcx nloc))) (oclass (compile_obj ntclass gcx)) (omatched (compile_obj nmatched gcx)) (freelist (normtester_free_objloc_list ntmi gcx tcx)) (othenlist (make_list discr_list)) (oelselist (make_list discr_list)) (othenblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl othenlist )) (oelseblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl oelselist)) (otest (make_objlocatedexp nloc ctype_long ##{/*normtesterinst*/ (melt_is_instance_of((melt_ptr_t)($OMATCHED), (melt_ptr_t)($OCLASS)))}#)) (ocond (instance class_objcond :obi_loc nloc :obcond_test otest :obcond_then othenblock :obcond_else oelseblock)) ) (debug "compiltst_normtester_instance otest=" otest " gotothen=" gotothen " gotoelse=" gotoelse " ocond=" ocond) (assert_msg "check oclass" (is_object oclass) oclass) ;; clear the freelist (foreach_pair_component_in_list (freelist) (locpair obloc) (debug "compiltst_normtester_instance obloc=" obloc) (assert_msg "check obloc" (is_a obloc class_objlocv) obloc) (let ( (oclearob (instance class_objclear :obi_loc nloc :oclr_vloc obloc )) ) (list_append olist oclearob) )) ;; add the cond (list_append olist ocond) ;; we have to add into the othenlist the fetch of each field and ;; the gotothen (debug "compiltst_normtester_instance ntflds=" ntflds " nlocclist=" nlocclist) (foreach_in_multiple (ntflds) (fldoc :long fldix) (if fldoc (progn (debug "compiltst_normtester_instance fldoc=" fldoc " fldix=" fldix) (assert_msg "check fldoc" (is_a fldoc class_nrep_locsymocc) fldoc) (let ( (flovar (compile_obj fldoc gcx)) (flbind (unsafe_get_field :nocc_bind fldoc)) (fldget (unsafe_get_field :letbind_expr flbind)) (ofget (compile_obj fldget gcx)) ) (assert_msg "check flbind" (is_a flbind class_normal_let_binding) flbind) (assert_msg "check fldget" (is_a fldget class_nrep_unsafe_get_field) fldget) (put_objdest ofget flovar) (debug "compiltst_normtester_instance ofget=" ofget) (assert_msg "check ofget" (is_object ofget) ofget) (list_append othenlist ofget) )))) ;; also add the gotothen (assert_msg "check gotothen" (is_object gotothen) gotothen) (list_append othenlist gotothen) ;; ;; add into the oelselist the gotoelse (assert_msg "check gotoelse" (is_object gotoelse) gotoelse) (list_append oelselist gotoelse) (debug "compiltst_normtester_instance final olist=" olist) (return olist ()) ) ) (install_method class_normtester_instance compile_tester compiltst_normtester_instance) ;;;;;;;;;;;;;;;; (defun compiltst_normtester_tuple (ntup gcx tcx) (debug "compiltst_normtester_tuple ntup=" ntup " of discrim=" (discrim ntup)) (assert_msg "check ntup" (is_a ntup class_normtester_tuple) ntup) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntup)) (nmatched (unsafe_get_field :ntest_matched ntup)) (nthen (unsafe_get_field :ntest_then ntup)) (nelse (unsafe_get_field :ntest_else ntup)) (normatch (unsafe_get_field :ntest_normatch ntup)) (nlocclist (unsafe_get_field :ntest_locclist ntup)) (ntupcomp (unsafe_get_field :nttuple_components ntup)) (:long nbcomp (multiple_length ntupcomp)) (olist (make_list discr_list)) (:long ntestix (get_int ntup)) (gotothen (or (normtester_gotoinstr nthen gcx) (endmatch_gotoinstr normatch gcx nloc))) (gotoelse (or (normtester_gotoinstr nelse gcx) (endmatch_gotoinstr normatch gcx nloc))) (omatched (compile_obj nmatched gcx)) (freelist (normtester_free_objloc_list ntup gcx tcx)) (othenlist (make_list discr_list)) (oelselist (make_list discr_list)) (othenblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl othenlist )) (oelseblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl oelselist)) (otest (make_objlocatedexp nloc ctype_long ##{/*normtestertuple*/ (melt_magic_discr((melt_ptr_t)($OMATCHED)) == MELTOBMAG_MULTIPLE && ((meltmultiple_ptr_t)($OMATCHED))->nbval == $NBCOMP)}#) ) (ocond (instance class_objcond :obi_loc nloc :obcond_test otest :obcond_then othenblock :obcond_else oelseblock)) ) (debug "compiltst_normtester_tuple omatched=" omatched " freelist=" freelist "\n otest=" otest "\n ocond=" ocond) ;; clear the freelist (foreach_pair_component_in_list (freelist) (locpair obloc) (debug "compiltst_normtester_tuple obloc=" obloc) (assert_msg "check obloc" (is_a obloc class_objlocv) obloc) (let ( (oclearob (instance class_objclear :obi_loc nloc :oclr_vloc obloc )) ) (list_append olist oclearob) )) ;; add the cond (list_append olist ocond) ;; we have to add into the othenlist the fetch of each component and ;; the gotothen (debug "compiltst_normtester_tuple ntupcomp=" ntupcomp) (foreach_in_multiple (ntupcomp) (curntup :long tupix) (debug "compiltst_normtester_tuple curntup=" curntup " tupix=" tupix) (if curntup (let ( (curovar (compile_obj curntup gcx)) (cnbind (get_field :nocc_bind curntup)) (curbexp (get_field :letbind_expr cnbind)) (curoexp (compile_obj curbexp gcx)) ) (debug "compiltst_normtester_tuple curovar=" curovar " cnbind=" cnbind " curbexp=" curbexp " curoexp=" curoexp " tupix=" tupix) (assert_msg "check curovar" (is_a curovar class_objlocv) curovar) (assert_msg "check cnbind" (is_a cnbind class_normal_let_binding) cnbind) (assert_msg "check curbexp" (is_a curbexp class_nrep_unsafe_nth_component) curbexp) (assert_msg "check nthrnk" (==i (get_int (get_field :nunth_index curbexp)) tupix) curbexp) (put_objdest curoexp curovar) (debug "compiltst_normtester_tuple updated curoexp=" curoexp) (list_append othenlist curoexp) )) );; end foreach ntupcomp ;; also add the gotothen (assert_msg "check gotothen" (is_object gotothen) gotothen) (list_append othenlist gotothen) ;; ;; add into the oelselist the gotoelse (assert_msg "check gotoelse" (is_object gotoelse) gotoelse) (list_append oelselist gotoelse) (debug "compiltst_normtester_tuple final olist=" olist) (return olist ()) )) (install_method class_normtester_tuple compile_tester compiltst_normtester_tuple) ;;;;;;;;;;;;;;;; (defun compiltst_normtester_same (ntsa gcx tcx) (debug "compiltst_normtester_same ntsa=" ntsa) (assert_msg "check ntsa" (is_a ntsa class_normtester_same) ntsa) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntsa)) (nmatched (unsafe_get_field :ntest_matched ntsa)) (nthen (unsafe_get_field :ntest_then ntsa)) (nelse (unsafe_get_field :ntest_else ntsa)) (normatch (unsafe_get_field :ntest_normatch ntsa)) (nidentical (unsafe_get_field :ntsame_identical ntsa)) (:long ntestix (get_int ntsa)) (omatched (compile_obj nmatched gcx)) (oidentical (compile_obj nidentical gcx)) (gotothen (or (normtester_gotoinstr nthen gcx) (endmatch_gotoinstr normatch gcx nloc))) (gotoelse (or (normtester_gotoinstr nelse gcx) (endmatch_gotoinstr normatch gcx nloc))) (freelist (normtester_free_objloc_list ntsa gcx tcx)) (othenlist (make_list discr_list)) (oelselist (make_list discr_list)) (othenblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl othenlist )) (oelseblock (instance class_objplainblock :obi_loc nloc :oblo_bodyl oelselist)) (otest (make_objlocatedexp nloc ctype_long ##{/*testersame*/ ($OMATCHED == $OIDENTICAL)}#)) (ocond (instance class_objcond :obi_loc nloc :obcond_test otest :obcond_then othenblock :obcond_else oelseblock)) (olist (make_list discr_list)) ) (debug "compiltst_normtester_same ocond=" ocond) ;; clear the freelist (foreach_pair_component_in_list (freelist) (locpair obloc) (assert_msg "check obloc" (is_a obloc class_objlocv) obloc) (let ( (oclearob (instance class_objclear :obi_loc nloc :oclr_vloc obloc )) ) (list_append olist oclearob) )) ;; add the cond (list_append olist ocond) ;; also add the gotothen (assert_msg "check gotothen" (is_object gotothen) gotothen) (list_append othenlist gotothen) ;; add into the oelselist the gotoelse (assert_msg "check gotoelse" (is_object gotoelse) gotoelse) (list_append oelselist gotoelse) (debug "compiltst_normtester_same return olist=" olist) (return olist ()) ) ) (install_method class_normtester_same compile_tester compiltst_normtester_same) ;;;;;;;;;;;;;;;; (defun compiltst_normtester_success (ntsu gcx tcx) (debug "compiltst_normtester_success ntsu=" ntsu " tcx=" tcx) (assert_msg "check ntsu" (is_a ntsu class_normtester_success) ntsu) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntsu)) (nmatched (unsafe_get_field :ntest_matched ntsu)) (nthen (unsafe_get_field :ntest_then ntsu)) (nelse (unsafe_get_field :ntest_else ntsu)) (nloclis (unsafe_get_field :ntest_locclist ntsu)) (normatch (unsafe_get_field :ntest_normatch ntsu)) (nsucdo (unsafe_get_field :ntsuccess_do ntsu)) (:long ntestix (get_int ntsu)) (gotoend (endmatch_gotoinstr normatch gcx nloc)) ) (assert_msg "check nil nloclis" (null nloclis) nloclis) (assert_msg "check nil nthen" (null nthen) nthen) (assert_msg "check nil nelse" (null nelse) nelse) (let ( (osucc (compile_obj nsucdo gcx)) ) ;; maybe we have to free all the location allocated for this test (if (is_list osucc) (progn (list_append osucc gotoend) (return osucc (list_last osucc))) (return (list osucc gotoend) osucc)) ))) (install_method class_normtester_success compile_tester compiltst_normtester_success) ;;;;;;;;;;;;;;;; (defun compiltst_normtester_orclear (ntoc gcx tcx) (debug "compiltst_normtester_orclear ntoc=" ntoc) (assert_msg "check ntoc" (is_a ntoc class_normtester_or_clear) ntoc) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntoc)) (nmatched (unsafe_get_field :ntest_matched ntoc)) (normatch (unsafe_get_field :ntest_normatch ntoc)) (nthen (unsafe_get_field :ntest_then ntoc)) (nelse (unsafe_get_field :ntest_else ntoc)) (nclear (unsafe_get_field :ntorclear_locsym ntoc)) (locmap (unsafe_get_field :gncx_locmap gcx)) (olist (make_list discr_list)) (gotothen (or (normtester_gotoinstr nthen gcx) (endmatch_gotoinstr normatch gcx nloc))) ;;; (gotoelse (or (normtester_gotoinstr nelse gcx) ;;; (endmatch_gotoinstr normatch gcx nloc))) ) (debug "compiltst_normtester_orclear nclear=" nclear " nthen=" nthen " nelse=" nelse) (assert_msg "check nclear" (is_multiple nclear) nclear) (foreach_in_multiple (nclear) (curlocs :long cix) (debug "compiltst_normtester_orclear curlocs=" curlocs " cix=" cix) (shortbacktrace_dbg "compiltst_normtester_orclear curlocs" 14) (let ( ;; TODO: perhaps we should not allocate a new obva but just ;; compile the curlocs (ocurl (let ( (oc (compile_obj curlocs gcx)) ) (debug "compiltst_normtester_orclear ocurl=" oc) oc)) (oclrloc (instance class_objclear :obi_loc nloc :oclr_vloc ocurl )) ) (debug "compiltst_normtester_orclear oclrloc=" oclrloc) (list_append olist oclrloc) ) ) (list_append olist gotothen) (debug "compiltst_normtester_orclear final olist=" olist) (return olist ()) )) (install_method class_normtester_or_clear compile_tester compiltst_normtester_orclear) ;;;;;;;;;;;;;;;; (defun compiltst_normtester_ortransmit (ntot gcx tcx) (debug "compiltst_normtester_ortransmit ntot=" ntot) (assert_msg "check ntot" (is_a ntot class_normtester_or_transmit) ntot) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (nloc (unsafe_get_field :nrep_loc ntot)) (nmatched (unsafe_get_field :ntest_matched ntot)) (normatch (unsafe_get_field :ntest_normatch ntot)) (ntupdst (unsafe_get_field :ntortransmit_dst ntot)) (ntupsrc (unsafe_get_field :ntortransmit_src ntot)) (nthen (unsafe_get_field :ntest_then ntot)) (nelse (unsafe_get_field :ntest_else ntot)) (olist (make_list discr_list)) (gotothen (or (normtester_gotoinstr nthen gcx) (endmatch_gotoinstr normatch gcx nloc))) ) (assert_msg "check null nelse" (null nelse) nelse) (assert_msg "check same size ntupsc ntupdst" (==i (multiple_length ntupdst) (multiple_length ntupsrc)) ntupsrc ntupdst) (foreach_in_multiple (ntupdst) (ncurdst :long nix) (let ( (ncursrc (multiple_nth ntupsrc nix)) ) (debug "compiltst_normtester_ortransmit ncursrc=" ncursrc " ncurdst=" ncurdst " nix=" nix) (let ( (osrc (compile_obj ncursrc gcx)) (dstype (get_field :nocc_ctyp ncurdst)) (odst (compile_obj ncurdst gcx)) (dstlist (make_list discr_list)) (ocomp (instance class_objcompute :obi_loc nloc :obdi_destlist dstlist :obcpt_type dstype :obcpt_expr osrc)) ) (list_append dstlist odst) (debug "compiltst_normtester_ortransmit osrc=" osrc " odst=" odst " ocomp=" ocomp) (list_append olist ocomp) ))) (list_append olist gotothen) (debug "compiltst_normtester_ortransmit final olist=" olist) (return olist ()) )) (install_method class_normtester_or_transmit compile_tester compiltst_normtester_ortransmit) ;;;;;;;;;;;;;;;; ;; to compile a disjunction, just goto the then case, because the ;; disjunction is only here to redistribute the then case inside the ;; disjuncts. (defun compiltst_normtester_disjunction (ntdj gcx tcx) (debug "compiltst_normtester_disjunction ntdj=" ntdj) (assert_msg "check ntdj" (is_a ntdj class_normtester_disjunction) ntdj) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (assert_msg "check tcx" (is_a tcx class_testercompilcontext) tcx) (let ( (locmap (unsafe_get_field :gncx_locmap gcx)) (nloc (unsafe_get_field :nrep_loc ntdj)) (nthen (unsafe_get_field :ntest_then ntdj)) (normatch (unsafe_get_field :ntest_normatch ntdj)) (ndisjlocsy (unsafe_get_field :ntdisj_freshorvar ntdj)) (gotothen (or (normtester_gotoinstr nthen gcx) (endmatch_gotoinstr normatch gcx nloc))) ;; not sure that freelist is needed! (freelist (normtester_free_objloc_list ntdj gcx tcx)) ) (debug "compiltst_normtester_disjunction ndisjlocsy=" ndisjlocsy " gotothen=" gotothen " freelist=" freelist) (compile_warning "do we need the freelist in compiltst_normtester_disjunction?") (foreach_in_multiple (ndisjlocsy) (curdisjloc :long lix) (debug "compiltst_normtester_disjunction curdisjloc=" curdisjloc " lix=" lix) (assert_msg "check curdisjloc" (is_a curdisjloc class_nrep_locsymocc) curdisjloc) (let ( (dbind (unsafe_get_field :nocc_bind curdisjloc)) (dsymb (unsafe_get_field :nocc_symb curdisjloc)) (dctyp (unsafe_get_field :nocc_ctyp curdisjloc)) (dobva (get_free_objloctyped gcx dsymb dctyp)) ) (debug "compiltst_normtester_disjunction dobva=" dobva) (mapobject_put locmap dbind dobva) ) ) (return gotothen ()) ) ) (install_method class_normtester_disjunction compile_tester compiltst_normtester_disjunction) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilmatcher_cmatcher (cmat mcx gcx) (debug "compilmatcher_cmatcher cmat=" cmat " mcx=" mcx) (assert_msg "check cmat" (is_a cmat class_cmatcher) cmat) (assert_msg "check mcx" (is_a mcx class_matchcompilcontext) mcx) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (cmins (unsafe_get_field :amatch_in cmat)) (cmbind (unsafe_get_field :amatch_matchbind cmat)) (cmouts (unsafe_get_field :amatch_out cmat)) (cmstate (unsafe_get_field :cmatch_state cmat)) (cmexptest (unsafe_get_field :cmatch_exptest cmat)) (cmexpfill (unsafe_get_field :cmatch_expfill cmat)) ;; the normtester (normtester (unsafe_get_field :mcx_normtester mcx)) ;; the subsitution map (substmap (make_mapobject discr_map_objects (+i 5 (*i 2 (+i (multiple_length cmins) (multiple_length cmouts)))))) (:long mcxcount (let ( (boxcnt (get_field :mcx_statecounter mcx)) (:long cnt (+i 1 (get_int boxcnt)) ) ) (put_int boxcnt cnt) cnt)) ;; generate a unique state string (uniqstate (let ( (sbuf (make_strbuf discr_strbuf)) ) (add2sbuf_cident sbuf (get_field :named_name cmstate)) (add2sbuf_strconst sbuf "_") (add2sbuf_string sbuf (get_field :mcx_suffix mcx)) (add2sbuf_strconst sbuf "_") (add2sbuf_longdec sbuf mcxcount) (strbuf2string discr_verbatim_string sbuf))) ;; fetch the olist to add instructions into (olist (get_field :mcx_olist mcx)) ) ;; map the state to the unique string (mapobject_put substmap cmstate uniqstate) ;; map the matched thing (let ( (nmatched (get_field :ntest_matched normtester)) ) (debug "compilmatcher_cmatcher nmatched=" nmatched) (let ( (obmatched (compile_obj nmatched gcx)) ) (debug "compilmatcher_cmatcher obmatched=" obmatched) (mapobject_put substmap (get_field :binder cmbind) obmatched ))) ;; (debug "compilmatcher_cmatcher normtester=" normtester) ;; map each input arguments (multiple_every_both (get_field :ntmatch_inargs normtester) cmins (lambda (curin formin :long ix) (debug "compilmatcher_cmatcher curin=" curin " formin=" formin " ix=" ix) (assert_msg "check formin" (is_a formin class_formal_binding) formin) (let ( (oin (compile_obj curin gcx)) ) (debug "compilmatcher_cmatcher oin=" oin) (mapobject_put substmap (get_field :binder formin) oin) ))) ;; map each output arguments (multiple_every_both (get_field :ntmatch_outlocs normtester) cmouts (lambda (curout formout :long ix) (debug "compilmatcher_cmatcher curout=" curout " formout=" formout " ix=" ix) (assert_msg "check formout" (is_a formout class_formal_binding) formout) (let ( (oout (compile_obj curout gcx)) ) (debug "compilmatcher_cmatcher oout=" oout " ix=" ix) (mapobject_put substmap (get_field :binder formout) oout)) )) (debug "compilmatcher_cmatcher substmap=" substmap) ;; expand (let ( (expander (lambda (tup) (multiple_map tup (lambda (c) (cond ( (is_a c class_symbol) (let ( (r (mapobject_get substmap c)) ) (if (null r) (error_strv (get_field :mcx_loc mcx) "invalid symbol to expand for cmatcher" (get_field :named_name c))) r)) ( (is_object c) (error_plain (get_field :mcx_loc mcx) "invalid object to expand for cmatcher")) ( (is_string c) (make_string discr_verbatim_string c)) (:else (error_plain (get_field :mcx_loc mcx) "invalid stuff to expand for cmatcher"))))))) (exptest (expander cmexptest)) (expfill (expander cmexpfill)) (mloc (get_field :mcx_loc mcx)) (testchunk (instance class_objlocatedexpv :obv_type ctype_long :obx_cont exptest :obcx_loc mloc)) (fillchunk (instance class_objlocatedexpv :obv_type ctype_void :obx_cont expfill :obcx_loc mloc)) ) (debug "compilmatcher_cmatcher exptest=" exptest " expfill=" expfill " testchunk=" testchunk " fillchunk=" fillchunk) (assert_msg "compilmatcher_cmatcher check exptest" exptest) (let ( (othenlist (make_list discr_list)) (othenbody (instance class_objplainblock :obi_loc mloc :oblo_bodyl othenlist )) (oelselist (make_list discr_list)) (oelsebody (instance class_objplainblock :obi_loc mloc :oblo_bodyl oelselist )) (ocond (instance class_objcond :obi_loc mloc :obcond_test testchunk :obcond_then othenbody :obcond_else oelsebody )) ) (debug "compilmatcher_cmatcher ocond=" ocond) (list_append olist ocond) (foreach_in_multiple (cmouts) (curout :long outix) (debug "compilmatcher_cmatcher curout=" curout " outix=" outix) (assert_msg "check curout" (is_a curout class_formal_binding) curout) (let ( (locout (mapobject_get substmap (unsafe_get_field :binder curout))) (oclearout (instance class_objclear :obi_loc mloc :oclr_vloc locout)) ) (debug "compilmatcher_cmatcher oclearout=" oclearout) (assert_msg "check locout" (is_object locout) locout) (list_append othenlist oclearout) ) ) (list_append othenlist fillchunk) (list_append othenlist (get_field :mcx_gotothen mcx)) (list_append oelselist (get_field :mcx_gotoelse mcx)) (debug "compilmatcher_cmatcher final ocond=" ocond) ) ))) (install_method class_cmatcher compile_matcher compilmatcher_cmatcher) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun compilmatcher_funmatcher (fmat mcx gcx) (debug "compilmatcher_funmatcher fmat=" fmat " mcx=" mcx) (assert_msg "check fmat" (is_a fmat class_funmatcher) fmat) (assert_msg "check mcx" (is_a mcx class_matchcompilcontext) mcx) (assert_msg "check gcx" (is_a gcx class_c_generation_context) gcx) (let ( (fmins (unsafe_get_field :amatch_in fmat)) (fmbind (unsafe_get_field :amatch_matchbind fmat)) (fmouts (unsafe_get_field :amatch_out fmat)) (ntma (get_field :mcx_normtester mcx)) ;; fetch the olist to add instructions into (olist (get_field :mcx_olist mcx)) (mloc (get_field :mcx_loc mcx)) ) (debug "compilmatcher_funmatcher ntma=" ntma) (assert_msg "check ntma" (is_a ntma class_normtester_matcher) ntma) (let ( (matndata (get_field :ntmatch_matndata ntma)) (omatdata (compile_obj matndata gcx)) (nmatched (get_field :ntest_matched ntma)) (omatched (compile_obj nmatched gcx)) (nins (get_field :ntmatch_inargs ntma)) (nouts (get_field :ntmatch_outlocs ntma)) (oins (multiple_map nins (lambda (thein) (compile_obj thein gcx) ))) (oouts (multiple_map nouts (lambda (theout) (compile_obj theout gcx) ))) (otestres (get_free_objlocptr gcx fmat)) (otestclos (get_free_objlocptr gcx '_closfunmatch)) ) (debug "compilmatcher_funmatcher matndata=" matndata " omatdata=" omatdata " fmins=" fmins " fmbind=" fmbind " fmouts=" fmouts " nins=" nins " nouts=" nouts " nmatched=" nmatched " omatched=" omatched " oins=" oins " oouts=" oouts " ntma=" ntma " otestres=" otestres " otestclos=" otestclos) ;; should generate a multiapplication etc... (let ( (oargs (make_multiple discr_multiple (+i 2 (multiple_length oins)))) (ogetclos (instance class_objgetslot :obi_loc mloc :obdi_destlist (list otestclos) :ogetsl_obj omatdata :ogetsl_field fmatch_matchf )) (omapp (instance class_objmultiapply :obi_loc mloc :obdi_destlist (list otestres) :obapp_clos otestclos :obapp_args oargs :obmultapp_xres oouts )) (othenlist (make_list discr_list)) (othenbody (instance class_objplainblock :obi_loc mloc :oblo_bodyl othenlist )) (oelselist (make_list discr_list)) (oelsebody (instance class_objplainblock :obi_loc mloc :oblo_bodyl oelselist )) (ocond (instance class_objcond :obi_loc mloc :obcond_test otestres :obcond_then othenbody :obcond_else oelsebody )) ) (multiple_put_nth oargs 0 omatdata) (multiple_put_nth oargs 1 omatched) (foreach_in_multiple (oins) (curins :long inix) (multiple_put_nth oargs (+i inix 2) curins) ) ;; add the clear of all the outs in the else branch (foreach_in_multiple (oouts) (curouts :long outix) (let ( (obcl (instance class_objclear :obi_loc mloc :oclr_vloc curouts)) ) (debug "compilmatcher_funmatcher obcl=" obcl) (list_append oelselist obcl) )) ;; dispose the temporary variables (dispose_objloc otestres gcx) (dispose_objloc otestclos gcx) ;; add the final gotos (list_append othenlist (get_field :mcx_gotothen mcx)) (list_append oelselist (get_field :mcx_gotoelse mcx)) (debug "compilmatcher_funmatcher ogetclos=" ogetclos " omapp=" omapp " ocond=" ocond) (list_append olist ogetclos) (list_append olist omapp) (list_append olist ocond) ) ) )) (install_method class_funmatcher compile_matcher compilmatcher_funmatcher) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; eof warmelt-genobj.melt