;; -*- Lisp -*- ;; file warmelt-first.melt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (comment "*** Copyright 2008, 2009 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-first.melt and ;; to the generated file warmelt-first*.c ;; This file is the first part of a bootstrapping compiler for the ;; MELT lisp dialect, compiler which should be able to ;; compile itself (into generated C file[s]) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;**************************************************************** ;; C L A S S E S ;;**************************************************************** ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ================ general classes ;; root class (defclass class_root :predef CLASS_ROOT :doc #{The $CLASS_ROOT is the topmost root of all classes. Every class should be some indirect subclass of $CLASS_ROOT. And $CLASS_ROOT should be the only class without superclass. Actually its super discriminant is $DISCR_ANY_RECEIVER.}# ) ;; class of everything with a property table (defclass class_proped :super class_root :fields (prop_table) :predef CLASS_PROPED :doc #{The $CLASS_PROPED is the common super-class for objects with a property table $PROP_TABLE (an object map associating property naming symbols to arbitrary value.}# ) ;; arbitrary container as class (defclass class_container :super class_root :predef CLASS_CONTAINER :fields (container_value) :doc #{The $CLASS_CONTAINER is a class for mutable containers (that is references). The contained value is $CONTAINER_VALUE.}#) ;; class of named objects (defclass class_named :super class_proped :fields (named_name) :predef CLASS_NAMED :doc #{The $CLASS_NAMED is the super-class of every named object. The $NAMED_NAME field is conventionally a string.}# ) ;; class of discriminants (defclass class_discriminant :super class_named :fields (disc_methodict disc_sender disc_super) :predef CLASS_DISCRIMINANT :doc #{The $CLASS_DISCRIMINANT is the class of every discriminant. It has the method dictionnary $DISC_METHODICT and the super-discriminant $DISC_SUPER. The $DISC_SENDER can hold a closure doing the send if the selector is not found. Otherwise, the default is to send thru the super-discriminant.}# ) ;; class of classes (defclass class_class :super class_discriminant :fields (class_ancestors class_fields class_data) :doc #{The $CLASS_CLASS is the class of all classes - which are therefore discriminants. The $CLASS_ANCESTORS field holds the sequence of ancestors. The $CLASS_FIELDS gives the sequence of inherited and own fields. The $CLASS_DATA is for class variables. Instances of $CLASS_CLASS are automagically created by the $DEFCLASS macro.}# :predef CLASS_CLASS ) ;; class of fields (defclass class_field ;; the fields' objnum is its offset :super class_named :fields (fld_ownclass fld_data) :doc #{The $CLASS_FIELD is the class of every field. Its objnum is its offset. Its $FLD_OWNCLASS is the class owning that field. The $FLD_DATA is for additional data. Instances of $CLASS_FIELD are automagically created by the $DEFCLASS macro.}# :predef CLASS_FIELD) ;; class of primitive (defclass class_primitive :super class_named :fields (prim_formals prim_type prim_expansion) :doc #{The $CLASS_PRIMITIVE is the class of descriptors of primitives. The $PRIM_FORMALS field is the sequence of formal arguments, the $PRIM_TYPE field is the type of the primitive, and its expansion is described by $PRIM_EXPANSION. Instances of $CLASS_PRIMITIVE are automagically created by the $DEFPRIMITIVE macro.}# :predef CLASS_PRIMITIVE) ;; class of C iterators (defclass class_citerator :super class_named :fields (citer_start_formals ;the formal start arguments citer_state ;the symbol representing the iterator state citer_body_formals ;the formal body arguments citer_expbefore ;expansion before body citer_expafter ;expansion after body ) :doc #{The $CLASS_CITERATOR is the class describing c-iterators. The formal start arguments are in the $CITER_START_FORMALS field, the $CITER_STATE field gives the state symbol, the $CITER_BODY_FORMALS gives the formal body arguments, and the before and after expansions are $CITER_EXPBEFORE and $CITER_EXPAFTER. Instances of $CLASS_CITERATOR are automagically created by the $DEFCITERATOR macro.}# :predef CLASS_CITERATOR) (defclass class_any_matcher :super class_named :fields (amatch_in ;the formal input arguments amatch_matchbind ;the matched formal binding amatch_out ;the formal output arguments ) :doc #{The $CLASS_ANY_MATCHER is the common super-class for matcher descriptors. The $AMATCH_IN gives the formal input arguments, the $AMATCH_MATCHBIND is the formal binding of the matched stuff, and $AMATCH_OUT is the formal output arguments. Instances of sub-classes of $CLASS_ANY_MATCHER are automagically created by macros like $DEFCMATCHER and $DEFUNMATCHER.}# ) ; class of C matchers (in patterns) (defclass class_cmatcher :super class_any_matcher :fields ( cmatch_state ;the symbol representing the match state cmatch_exptest ;expansion for test expr [in patterns] cmatch_expfill ;expansion for filling instr ;[in patterns] cmatch_expoper ;expansion for operator use ;[in expressions] using outs ) :doc #{The $CLASS_CMATCHER is the class for c-matcher descriptors. $CMATCH_STATE is the state symbol, $CMATCH_EXPTEST gives the expansion for testing in patterns, $CMATCH_EXPFILL is the expansion for filling a matched pattern. $CMATCH_EXPOPER is the expansion for operator uses. Instances of $CLASS_CMATCHER are automagically created by the $DEFCMATCHER macro.}# :predef CLASS_CMATCHER) ; class of function matcher (in patterns) (defclass class_funmatcher :super class_any_matcher :fields ( fmatch_matchf ;matching function ;; first argument to matching function is the funmatcher. ;; second argument is the stuff to match next arguments are input ;; primary result is non-nil iff the match succeeded. secondary results ;; are the deconstructed stuff fmatch_applyf ;applying function ;; first argument to applying function is the funmatcher. ;; next arguments are from the expression fmatch_data ;client data ) :doc #{The $CLASS_FUNMATCHER describes fun-matchers. $FMATCH_MATCHF is the matching function -for patterns. $FMATCH_APPLYF is the applying function -for expressions. $FMATCH_DATA is some additional client data. Instances of $CLASS_FUNMATCHER are automagically created by the $DEFUNMATCHER macro.}# :predef CLASS_FUNMATCHER ) ;; class of located stuff (defclass class_located :super class_proped :fields (loca_location) :doc #{The $CLASS_LOCATED is the super-class for located stuff, having a source file location given by the $LOCA_LOCATION field, conventionally a mixed location box with $DISCR_MIXED_LOCATION.}# :predef CLASS_LOCATED) ;; class of source expressions (defclass class_sexpr :predef CLASS_SEXPR :super class_located :fields (sexp_contents ;list of contents ) :doc #{The $CLASS_SEXPR is the class of source expressions, as parsed by the reader before their macro expansion into abstract syntax tree [see $CLASS_SOURCE]. The $SEXP_CONTENTS field is a list of contents.}# ) ;; class of message selectors (defclass class_selector :super class_named :fields (sel_signature sel_data) :doc #{The $CLASS_SELECTOR is the class of message selectors, created by the $DEFSELECTOR macro. The $SEL_SIGNATURE could give a signature (as a formal argument list) and the $SEL_DATA is for additional data.}# :predef CLASS_SELECTOR) ;; class of symbols (defclass class_symbol :predef CLASS_SYMBOL :super class_named :doc #{The $CLASS_SYMBOL is the class of symbols. The $SYMB_DATA is a field for some additional data. The reader may create instances of $CLASS_SYMBOL when encoutering new symbols. Symbols are interned inside the $INITIAL_SYSTEM_DATA.}# :fields (symb_data)) ;; class of generated (ie cloned) symbols - like lisp gensym-ed (defclass class_cloned_symbol :super class_symbol :fields (csym_urank ;unique rank as a boxed integer ) :doc #{The $CLASS_CLONED_SYMBOL is the sub-class of cloned symbols, e.g. like GENSYM-ed symbols is many Lisps. Cloned symbols are internally generated inside the MELT translator by the $CLONE_SYMBOL function. Their $CSYM_URANK field gives their unique rank as a boxed integer. Cloned symbols are not interned.}#) ;; class of keyword symbols (defclass class_keyword :predef CLASS_KEYWORD :super class_symbol :doc #{The $CLASS_KEYWORD is the sub-class of keywords, that is symbols starting with a colon, which are handled specially and implicitly quoted. Most ctypes are denoted by such keywords like @code{:long :value} etc. The reader parses as keyword any symbol starting with a colon. Keywords are interned inside the $INITIAL_SYSTEM_DATA.}# :fields ()) ;; class of C types keywords - it is predefined to ensure ;; install_ctype_descr always refer to the same class (defclass class_ctype :predef CLASS_CTYPE :super class_named :fields ( ctype_keyword ;the keyword associated to the ctype (e.g. :long) ctype_cname ;the name for C of the type (eg long) ctype_parchar ;the name of the melt parameter char (eg BPAR_LONG) ctype_parstring ;the name of the melt parameter string (eg BPARSTR_LONG) ctype_argfield ;the name of the melt argument union field (eg bp_long) ctype_resfield ;the name of the melt result union field (eg bp_longptr) ctype_marker ;the name of the marker routine ctype_descr ;descriptive string ctype_altkeyword ;the alternate keyword associated to the ctype (e.g. :longinteger) ) :doc #{The $CLASS_CTYPE is for predefined descriptors of C types (like long or tree). $CTYPE_KEYWORD gives the associated keywords (for formal argument lists, etc...), $CTYPE_CNAME gives the C identifier of the type. Parameter passing is described by $CTYPE_PARCHAR (for the character) and $CTYPE_PARSTRING (for the corresponding C string). Argument member in union is given by $CTYPE_ARGFIELD, and by $CTYPE_RESFIELD for results. The marking routine is $CTYPE_MARKER and $CTYPE_DESCR is some descriptive string or data. A possible alternate keyword is given by $CTYPE_ALTKEYWORD. Adding new c-types requires an update of MELT runtime!}# ) ;; class of system data -- be careful to keep the FSYSDAT_* ;; identifiers from melt-runtime.h in sync! (defclass class_system_data :predef CLASS_SYSTEM_DATA :super class_named :doc #{The $CLASS_SYSTEM_DATA has a singleton instance, the $INITIAL_SYSTEM_DATA. It contains lots of fields, starting by SYSDATA_, for various system facilities. It is very magical, and should be kept in sync with the MELT runtime. Only for gurus! So don't instanciate this class!}# :fields (sysdata_mode_dict ;stringmap for commands sysdata_cont_fresh_env ;closure to make a fresh environment sysdata_value_exporter ;closure to export a value sysdata_macro_exporter ;closure to export a macro sysdata_symboldict ; stringmap for symbols sysdata_keywdict ;stringmap for keywords sysdata_addsymbol ;closure to add a symbol of given name sysdata_addkeyw ;closure to add a keyword of given name sysdata_internsymbol ;closure to intern a symbol sysdata_internkeyw ;closure to intern a keyword sysdata_value_importer ;closure to import a value sysdata_pass_dict ;stringmap for passes sysdata_exit_finalizer ;;closure to be called after the passes, at finalization sysdata_meltattr_definer ;;closure to be called for melt attributes sysdata_patmacro_exporter ;closure to export a patmacro sysdata_debugmsg ;closure for debugmsg sysdata_stdout ;raw file for stdout sysdata_stderr ;raw file for stderr sysdata_dumpfile ;raw file for dump_file sysdata_unit_starter ;closure to be called at ;compilation unit start sysdata_unit_finisher ;closure to be called at ;compilation unit end ;;;keep these spare slots to ease the addition of other slots sysdata___spare1 sysdata___spare2 sysdata___spare3 sysdata___spare4 )) ;; class for debug information (used for debug_msg & dbgout* stuff) (defclass class_debug_information :super class_root :fields (dbgi_out ;the produced outbuf dbgi_occmap ;the occurrence map (to avoid outputing twice the same object) dbgi_maxdepth ;the boxed integer maximal depth ) :doc #{The $CLASS_DEBUG_INFORMATION is for debug information output, e.g. $DEBUG_MSG macro. The produced output or buffer is $DBGI_OUT, the occurrence map is $DBGI_OCCMAP, used to avoid outputting twice the same object. The boxed maximal depth is $DBGI_MAXDEPTH.}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ================ classes for environments & bindings ;;;; the class for environments - predefined to ensure all ;;;; environments have the same (super*)class (defclass class_environment :predef CLASS_ENVIRONMENT :super class_root :doc #{The $CLASS_ENVIRONMENT reifies environments. The binding map is $ENV_BIND, the previous environment is $ENV_PREV, and the procedure if any of this environment is $ENV_PROC. It is heavily used within the MELT translator. Module initialization produces fresh instances of it. See the $CURRENT_MODULE_ENVIRONMENT_CONTAINER and $PARENT_MODULE_ENVIRONMENT macros.}# :fields (env_bind ;the map of bindings env_prev ;the previous environment env_proc ;the procedure of this environment )) (defclass class_described_environment :super class_environment :fields (denv_descr ) :doc #{The $CLASS_DESCRIBED_ENVIRONMENT provides an extra descriptor $DENV_DESCR which can for example be a descriptive string.}#) ;; the (super-)class of any binding (defclass class_any_binding :super class_root :fields (binder) :doc #{The $CLASS_ANY_BINDING is the super-class of every binding. The $BINDER field is the bound name. Bindings are added by module initializers. Don't create bindings by instanciating this class in user code, they are created within the Melt translator.}# ) ;;; superclass of exported bindings (defclass class_exported_binding :super class_any_binding :fields ( ) :doc #{The $CLASS_EXPORTED_BINDING is the super-class of exported bindings.}# ) ;; macro binding (defclass class_macro_binding :super class_exported_binding :fields (mbind_expanser) :doc #{The $CLASS_MACRO_BINDING is the class of exported macro bindings. See the $EXPORT_MACRO macro.}# ) ;; pattern macro binding (defclass class_patmacro_binding :super class_macro_binding :fields (patbind_expanser) :doc #{The $CLASS_PATMACRO_BINDING is the class of exported pattern-macro bindings. See the $EXPORT_PATMACRO macro.}# ) ;; value binding - as exported (defclass class_value_binding :super class_exported_binding :fields (vbind_value) :doc #{The $CLASS_PATMACRO_BINDING is the class of exported value bindings. See The $EXPORT_VALUES macro.}# ) ; formal binding (used in generated defprimitive) (defclass class_formal_binding :super class_any_binding :fields (fbind_type) ;;the obj_num is the argument rank :predef CLASS_FORMAL_BINDING :doc #{The $CLASS_FORMAL_BINDING is the class of formal argument bindings [like in @code{defun lambda defprimitive defciterator} etc..]. The $FBIND_TYPE gives the formal's c-type.}# ) ;;; fixed bindings are defined in a compilation unit and can be ;;; implemented as constants in routine (defclass class_fixed_binding :super class_any_binding :fields (fixbind_data ;the common slot describing data ) :doc #{The internal $CLASS_FIXED_BINDING is a super-class of bindings inside a compilation unit. The data description is inside $FIXBIND_DATA. Fixed bindings are internal to the translator.}#) ;; selector binding (defclass class_selector_binding :super class_fixed_binding :fields (sbind_selectordef ;the "source" defselector ;; maybe we need an selectorval for the actual value ) :doc #{The internal $CLASS_SELECTOR_BINDING is a fixed binding for selectors. See $DEFSELECTOR macro. The $SBIND_SELECTORDEF gives the definition.}# ) ;; primitive binding (defclass class_primitive_binding :super class_fixed_binding :fields (pbind_primdef ;the source defprimitive pbind_primitive ;the primitive proper ) :doc #{The internal $CLASS_PRIMITIVE_BINDING is for primitive bindings. See $DEFPRIMITIVE macro. The $PBIND_PRIMDEF gives the definition, and the $PBIND_PRIMITIVE gives the primitive itself.}# ) ;; citerator binding (defclass class_citerator_binding :super class_fixed_binding :fields (cbind_citerdef ;the source defciterator cbind_citerator ;the citerator proper ) :doc #{The internal $CLASS_CITERATOR_BINDING is for c-iterator bindings. See the $DEFCITERATOR macro. The $CBIND_CITERDEF gives the definition, and the $CBIND_CITERATOR provides the c-iterator itself.}# ) ;; function binding (defclass class_function_binding :super class_fixed_binding :fields (fubind_defun ;the source definition ) :doc #{The internal $CLASS_FUNCTION_BINDING is for function bindings. See the $DEFUN macro. The $FUBIND_DEFUN provides the definition.}# ) ;; class binding (defclass class_class_binding :super class_fixed_binding :fields (cbind_defclass ;the source definition cbind_class ;the built class ) :doc #{The internal $CLASS_CLASS_BINDING is for class bindings. See the $DEFCLASS macro. The definition is provided by $CBIND_DEFCLASS, and the class itself is given by $CBIND_CLASS. A class definition also define fields.}# ) ;; field binding (defclass class_field_binding :super class_fixed_binding :fields (flbind_clabind ;the class binding flbind_field ;the field proper ) :doc #{The internal $CLASS_FIELD_BINDING is for field bindings. See the $DEFCLASS macro. The class binding is $FLBIND_CLABIND, and the defined field is $FLBIND_FIELD.}# ) ;; instance binding (defclass class_instance_binding :super class_fixed_binding :fields ( ibind_iclass ;the instance's class ) :doc #{The internal $CLASS_INSTANCE_BINDING is for instance bindings. See the $DEFINSTANCE macro. The instance's class is in $IBIND_ICLASS.}# ) ;; cmatcher binding (defclass class_cmatcher_binding :super class_fixed_binding :fields (cmbind_matcher ;the cmatcher ) :doc #{The internal $CLASS_CMATCHER_BINDING is for c-matcher bindings. See the $DEFCMATCHER macro. The c-matcher is in $CMBIND_MATCHER.}# ) ;; funmatcher binding (defclass class_funmatcher_binding :super class_fixed_binding :fields (fmbind_funmatcher ;the funmatcher (of class_funmatcher) fmbind_defunmatcher ;the source definition ) :doc #{The internal $CLASS_FUNMATCHER_BINDING is for funmatcher bindings. See the $DEFUNMATCHER macro. The funmatcher is in $FMBIND_FUNMATCHER and its definition in $FMBIND_DEFUNMATCHER.}#) ;; let binding (defclass class_let_binding :super class_any_binding :fields (letbind_type ;the ctype letbind_expr ;the expression letbind_loc ;the optional src location ) :doc #{The internal $CLASS_LET_BINDING is for internal let bindings. See The $LET macro and also the $CLASS_NORMAL_LET_BINDING. The c-type of the bound valus is $LETBIND_TYPE, the expression is $LETNIND_EXPR, the source location if any is $LEBIND_LOC.}# ) ;; letrec binding (defclass class_letrec_binding :doc #{The internal $CLASS_LETREC_BINDING is for internal letrec bindings. See the $LETREC macro. The bound expression should be recursively constructible (like $LAMBDA $TUPLE $LIST $INSTANCE ...)}# :super class_let_binding :fields ()) ;; normalized let binding (defclass class_normal_let_binding :super class_let_binding :fields () :doc #{The internal $CLASS_NORMAL_LET_BINDING is for internal normalized bindings. The bound expression is in normal form. Very often the $BINDER is a cloned symbol.}# ) ;no additional field, but letbind_expr is "normal" ;; label binding (defclass class_label_binding :super class_any_binding :fields (labind_loc ;location of the label ;;; following fields are filled later in the compilation phase labind_clonsy ;unique cloned symbol labind_res ;result localvar ) :doc #{The internal $CLASS_LABEL_BINDING is for labels. See The $FOREVER and $EXIT macros. The label source location is $LABIND_LOC, the cloned symbol unique to the label is $LABIND_CLONSY. The local variables for the result is $LABIND_RES.}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ================ GCC compiler passes (defclass class_gcc_pass :predef CLASS_GCC_PASS :super class_named ;; keep the fields list in sync with melt-runtime.h FGCCPASS_* :fields (gccpass_gate ;closure for gate gccpass_exec ;closure for execution gccpass_data ;extra data ;;;; the following fields are mimicking their equivalent in ;;;; struct opt_pass of gcc/tree-pass.h ;;;;;; if it is a boxed integer, get the integer ;;;;;; if it is a string or a named, translate it ;;;;;; if it is a list or a tuple, make an OR mask of them gccpass_properties_required gccpass_properties_provided gccpass_properties_destroyed gccpass_todo_flags_start gccpass_todo_flags_finish ) :doc #{ The $CLASS_GCC_PASS is the super-class of GCC compiler passes descriptors, as provided in MELT. Once correctly instanciated, such a pass descriptor should be registered thru the $INSTALL_MELT_GCC_PASS primitive. Pass descriptors are named (be careful to give a unique unused name!). The $GCCPASS_GATE is the pass gate function. The $GCCPASS_EXEC is the pass execution function. The field $GCCPASS_DATA can be used for client data. The fields $GCCPASS_PROPERTIES_REQUIRED $GCCPASS_PROPERTIES_PROVIDED $GCCPASS_PROPERTIES_DESTROYED $GCCPASS_TODO_FLAGS_START $GCCPASS_TODO_FLAGS_FINISH are like their counterparts in C, and can be a boxed integer, a string or named [i.e. symbol], or a tuple or list of them.}# ) (defclass class_gcc_gimple_pass :predef CLASS_GCC_GIMPLE_PASS :super class_gcc_pass :fields ( ) :doc #{ The $CLASS_GCC_GIMPLE_PASS is for GCC gimple pass descriptors. }# ) (defclass class_gcc_rtl_pass :predef CLASS_GCC_RTL_PASS :super class_gcc_pass :fields ( ) :doc #{ The $CLASS_GCC_RTL_PASS is for GCC RTL pass descriptors. }# ) (defclass class_gcc_simple_ipa_pass :predef CLASS_GCC_SIMPLE_IPA_PASS :super class_gcc_pass :fields ( ) :doc #{ The $CLASS_GCC_SIMPLE_IPA_PASS is for GCC simple IPA pass descriptors. }# ) ;;;; mode (defclass class_melt_mode :super class_named :predef CLASS_MELT_MODE :fields (meltmode_help meltmode_fun meltmode_data ) :doc #{ The $CLASS_MELT_MODE describe mode handlers, as given by the @code{-fmelt=} or @code{-fplugin-arg-melt-mode=} GCC program flag. The $MELTMODE_HELP is a help string. The $MELTMODE_FUN is the function to run the command, and the $MELTMODE_DATA gives additional client data. See the $INSTALL_MELT_MODE function. }# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ================ source program elements ;; common superclass of source abstract syntax tree elements (defclass class_source :super class_located :fields ( ) :doc #{The $CLASS_SOURCE is the common super-class of source elements, i.e. of abstract syntax tree elements after macro-expansion. Its subclasses are produced by macro expanders.}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; module compilation context (defclass class_module_context :super class_root :fields (mocx_modulename ;the module name mocx_expfieldict ;dict of exported fields mocx_expclassdict ;dict of exported classes mocx_initialenv ;the initial environment mocx_funcount ;a boxed counter for defined functions mocx_filetuple ;vector for different generated files ) :doc #{The internal $CLASS_MODULE_CONTEXT describes the whole module context of a translation. $MOCX_MODULENAME gives the module name, $MOCX_EXPFIELDICT gives the dictionnary of exported fields, $MOCX_EXPCLASSDICT gives the dictionnary of exported classes, and $MOCX_INITIALENV the initial environment. $MOCX_FUNCOUNT is a boxed integer counting the defined functions (excluding $LAMBDA-s, counting only $DEFUN), used to help generate C code in several files, described in $MOCX_FILETUPLE. For gurus!}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; normalization context (defclass class_normalization_context :super class_root :fields (nctx_initproc ;initial procedure nctx_proclist ;list of procedures nctx_datalist ;list of data nctx_valuelist ;list of imported values nctx_symbmap ;stringmap of name to interned symbols nctx_keywmap ;stringmap of name to interned keywords nctx_symbcachemap ;objmap of cached symbol -> occurrence nctx_predefmap ;objmap of predef -> boxedrank or symbols nctx_valmap ;objmap of values -> data nctx_valbindmap ;objmap of value binding -> data nctx_curproc ;current procedure nctx_modulcontext ;the module compilation context nctx_qdatcurmodenvbox ;quasi data for current_module_environment_container nctx_qdatparmodenv ;quasi data for parent_module_environment nctx_procurmodenvlist ;list of procedures using the current_module_environment_container construct ) :doc #{The internal $CLASS_NORMALIZATION_CONTEXT (for gurus only) is used for expression normalization by the translator. $NCTX_INITPROC gives the initial procedure. $NCTX_PROCLIST is the list of procedures. $NCTX_DATALIST is the list of data. $NCTX_VALUELIST gives the list of imported values. $NCTX_SYMBMAP and $NCTX_KEYWMAP are dictionnaries mapping symbol or keyword names to interned symbols or keywords. $NCTX_SYMBCACHEMAP is an object map to cache the occurrence of symbols. $NCTX_PREDEFMAP is a map from predefined to ranks. $NCTX_VALMAP is an object map from value to data, and $NCTX_VALBINDMAP is an object map from value binding to data. The Current procedure is $NCTX_CURPROC. The module compilation context is $NCTX_MODULCONTEXT. The quasidata for the current module environment container is $NCTX_QDATCURMODENVBOX. The quasi data for the parent module's environment is $NCTX_QDATPARMODENV. The list of procedures using the current module environment is in $NCTX_PROCURMODENVLIST.}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; ================ classes for code generation ;;; code generation context (defclass class_c_generation_context :super class_root :fields ( gncx_objrout ;the containing object routine gncx_locmap ;objmap from normal bindings to locals gncx_freeptrlist ;list of freed local pointers gncx_freelonglist ;list of freed local longs gncx_freeothermaps ;map keyed by ctypes of list of freed local others gncx_retloc ;return location gncx_compicache ;cache map of procedure to compiled routines gncx_modulcontext ;the module compilation context gncx_matchmap ;map keyed by normal matchers ;giving a unique label prefix ) :doc #{The internal $CLASS_C_GENERATION_CONTEXT (for gurus) is the class of contexts for C code generation, while generating a single C routine. The containing object routine is $GNCX_OBJROUT. The object map from normal bindings to local is given in $GNCX_LOCMAP. The list of freed local value pointers is in $GNCX_FREEPTRLIST. The list of free longs is in $GNCX_FREELONGLIST. For other c-types, each c-type has its list, associated to it in $GNCX_FREEOTHERMAPS. The return location is in $GNCX_RETLOC. The cached map of procedures to compiled routines is in $GNCX_COMPICACHE. The module compilation context is in $GNCX_MODULCONTEXT. A map keyed by normal matchers to give a unique label prefix is in $GNCX_MATCHMAP.}# ) ;; code generation context for initial routine (defclass class_initial_generation_context :super class_c_generation_context :fields (igncx_prevenvloc ;local for previous environment [parent_module_environment] igncx_contenvloc ;local for the container of environment igncx_procurmodenvlist ;list of routines using the current_module_environment_container igncx_importmap ;mapping of imported symbols to locvars ) :doc #{The internal $CLASS_INITIAL_GENERATION_CONTEXT (for gurus) is used when generating the initial routine of a module, which builds the current environment and evaluates the module toplevel expressions. The $IGNCX_PREVENVLOC is the local for the parent environment. The $IGNCX_CONTENVLOC is the local for the container of the current module's environment. The list of routines using it is in $IGNCX_PROCURMODENVLIST. The mapping of imported symbolts to locals is $IGNCX_IMPORTMAP.}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; common superclass for objcode (defclass class_generated_c_code :super class_root :fields ( ) :doc #{The super-class $CLASS_GENERATED_C_CODE is a common super-class for representing generated C abstract syntax trees inside the MELT translator. Within MELT, it has nothing in common with GCC compiled C abstract syntax trees (that is @code{:tree} and @code{:gimple}).}#) ;; ;;**************************************************************** ;; P R I M I T I V E S ;;**************************************************************** ;; primitive to ignore a value (defprimitive ignore (v) :void :doc #{Ignore the value passed as argument. Useful to avoid translation warnings, or to force the type of a conditional. See $CTYPE_VOID.}# #{/*ignore*/(void)($v)}#) ;; primitive to return a void (defprimitive void () :void :doc #{Return a void value. See $IGNORE and $CTYPE_VOID.}# #{/*void*/0}#) ;; primitive for converting a string constant into a string value (defprimitive stringconst2val (discr :cstring strc) :value :doc #{Convert a C-string constant $STRC into a string value of discriminant $DISCR. See also $QUOTE macro applied to a string.}# #{meltgc_new_string((meltobject_ptr_t)($discr), ($strc))}#) ;; primitive for testing if an object is a (sub) instance of a class (defprimitive is_a (obj cla) :long :doc #{Test if $OBJ is an instance of the $CLA class [or a subclass]. Return 0 otherwise, e.g. when $OBJ is not an object. See also $IS_NOT_A.}# #{melt_is_instance_of((melt_ptr_t)($obj), (melt_ptr_t)($cla))}#) ;; primitive for testing if an object is NOT a (sub) instance of a class (defprimitive is_not_a (obj cla) :long :doc #{Test if $OBJ is @emph{not} an instance of the $CLA class [or a subclass]. Negation of $IS_A.}# #{!melt_is_instance_of((melt_ptr_t)($obj), (melt_ptr_t)($cla))}#) ;; primitive for testing objectness (defprimitive is_object (obj) :long :doc #{Test if $OBJ is indeed an object. See also $IS_NOT_OBJECT.}# #{(melt_magic_discr((melt_ptr_t)($obj)) == OBMAG_OBJECT)}#) (defprimitive is_not_object (obj) :long :doc #{Test if $OBJ is not an object. Negation of $IS_OBJECT.}# #{(melt_magic_discr((melt_ptr_t)($obj)) != OBMAG_OBJECT)}#) ;; primitive to safely return a global predef by its index (defprimitive get_globpredef (:long ix) :value :doc #{Safely gives the predefined of index $IX or null.}# #{(melt_globpredef($ix))}#) ;; primitive to get the discriminant of a value (defprimitive discrim (v) :value :doc #{Safely gives the discriminant of a value (even if it is null).}# #{(melt_discr((melt_ptr_t)($v)))}#) ;; primitive to get the integer inside a boxed or mixed integer or objnum (defprimitive get_int (v) :long :doc #{Safely gets the integer number inside $V, a boxed or mixed integer, or an object.}# #{(melt_get_int((melt_ptr_t)($v)))}#) ;; primitive to put the integer inside a boxed or mixed integer or objnum (defprimitive put_int (v :long i) :void :doc #{Safely puts the integer number $I inside $V, a boxed or mixed integer, or an object.}# #{melt_put_int((melt_ptr_t)($v), ($i))}#) ;; primitive to get the hashcode of an object (or 0) (defprimitive obj_hash (v) :long :doc #{Safely gives the hashcode of object $V or else 0.}# #{(melt_obj_hash((melt_ptr_t)($v)))}#) ;; primitive to get the length of an object (or 0) (defprimitive obj_len (v) :long :doc #{Safely gives the length of object $V or else 0.}# #{(melt_obj_len((melt_ptr_t)($v)))}#) ;; primitive to get the number of an object (or 0) (defprimitive obj_num (v) :long :doc #{Safely gives the number of object $V or else 0.}# #{(melt_obj_num((melt_ptr_t)($v)))}#) ;; primitive to get the serial of an object (or 0 when ENABLE_CHECKING is not set) (defprimitive obj_serial (v):long :doc #{Safely gives the serial when ENABLE_CHECKING of object $V or else 0.}# #{(melt_obj_serial((melt_ptr_t)($v)))}#) ;; primitive to compute a nonzero hash (defprimitive nonzero_hash () :long :doc #{Gives a pseudo-random non-zero number suitable as an hash code.}# "(melt_nonzerohash())") ;; primitive for identity and non-identity test (defprimitive == (a b) :long :doc #{Test identity of values $A and $B.}# #{(($a) == ($b))}#) (defprimitive != (a b) :long :doc #{Test that values $A and $B are not identical.}# #{(($a) != ($b))}#) ;;; the call counter - do not redefine the name, it is used by expansion of debug_msg macro! (defprimitive the_callcount () :long "callcount") ;;; the current frame depth (defprimitive the_framedepth () :long "(melt_curframdepth())") ;;; the timestamp of compilation & md5 checksum of the generated C file (defprimitive out_cplugin_compiled_timestamp_err () :void "melt_puts(stderr,melt_compiled_timestamp)") (defprimitive out_cplugin_md5_checksum_err () :void "melt_puts(stderr,melt_md5)") ;; primitive to force garbage collection (defprimitive minor_garbcoll (:long siz) :void :doc #{Force a minor MELT garbage collection. The $SIZ is the amount of memory to reserve.}# #{melt_garbcoll(($siz), MELT_MINOR_OR_FULL)}#) (defprimitive full_garbcoll (:long siz) :void :doc #{Force a full MELT garbage collection. The $SIZ is the amount of memory to reserve.}# #{melt_garbcoll(($siz), MELT_NEED_FULL)}#) ;; primitive to get or create a symbol from a string value (defprimitive get_symbolstr (strv) :value :doc #{Get an existing symbol of given string value $STRV or null if not found.}# #{meltgc_named_symbol( melt_string_str((melt_ptr_t)($strv)), MELT_GET)}#) (defprimitive create_symbolstr (strv) :value :doc #{Retrieve an existing symbol of given string value $STRV or create it if not found.}# #{meltgc_named_symbol(melt_string_str((melt_ptr_t)($strv)), MELT_CREATE)}#) ;; primitive to get or create a keyword from a string value (defprimitive get_keywordstr (strv) :value :doc #{Get an existing keyword of given string value $STRV or null if not found.}# #{meltgc_named_keyword( melt_string_str((melt_ptr_t)($strv)), MELT_GET)}#) (defprimitive create_keywordstr (strv) :value :doc #{Retrieve an existing keyword of given string value $STRV or create it if not found.}# #{meltgc_named_keyword( melt_string_str((melt_ptr_t)($strv)), MELT_CREATE)}#) ;; runtime assertion with message called by expansion of assert_msg ;;; @@ UGLY HACK TO ALWAYS HAVE A filename (defprimitive assert_failed (:cstring msg :cstring filename :long lineno) :void :doc #{Internally used by $ASSERT_MSG macro. Runtime assert failed with message $MSG in file $FILENAME at line $LINENO.}# #{melt_assert_failed(($msg),($filename)?($filename):__FILE__, ($lineno)?($lineno):__LINE__, __FUNCTION__); }#) ;; check explicitly the call stack (defprimitive checkcallstack_msg (:cstring msg) :void :doc #{Low level costly primitive to check the entire call stack to help hunt memory or GC bugs. Displays the given $MSG if the check went wrong. Use it when desperate.}# #{melt_check_call_frames(MELT_ANYWHERE, $msg);}#) ;; for breakpoint (defprimitive cbreak_msg (:cstring msg) :void :doc #{Low level primitive for GDB breakpoints. Use it temporarily, given a string $MSG, with gdb when desperate.}# #{melt_cbreak($msg)}#) ;;; less, lessorequal, greater, greaterorequal, equal, different number (defprimitive i (:long a b) :long :doc #{Integer test that $A greater than $B.}# #{(($a) > ($b))}#) (defprimitive >=i (:long a b) :long :doc #{Integer test that $A greater or equal to $B.}# #{(($a) >= ($b))}#) (defprimitive !=i (:long a b) :long :doc #{Integer test that $A is unequal to $B.}# #{(($a) != ($b))}#) ;;; integer arithmetic (defprimitive +i (:long a b) :long :doc #{Integer binary addition of $a and $b.}# #{(($a) + ($b))}#) (defprimitive -i (:long a b) :long :doc #{Integer binary substraction of $a and $b.}# #{(($a) - ($b))}#) (defprimitive *i (:long a b) :long :doc #{Integer binary product of $a and $b.}# #{(($a) * ($b))}#) (defprimitive andi (:long a b) :long :doc #{Integer binary bitwise and of $a and $b.}# #{(($a) & ($b))}#) (defprimitive ori (:long a b) :long :doc #{Integer binary bitwise or of $a and $b.}# #{(($a) | ($b))}#) (defprimitive xori (:long a b) :long :doc #{Integer binary bitwise exclusive-or of $a and $b.}# #{(($a) ^ ($b))}#) (defprimitive negi (:long i) :long :doc #{Integer unary negation of $i.}# #{(-($i))}#) (defprimitive noti (:long i) :long :doc #{Integer unary bitwise complement of $i.}# #{(~($i))}#) (defprimitive /i (:long a b) :long :doc #{Integer binary division of $a and $b, robust to zero-divide.}# #{(melt_idiv(($a), ($b)))}#) (defprimitive %i (:long a b) :long :doc #{Integer binary modulus of $a and $b, robust to zero-divide.}# #{(melt_imod(($a), ($b)))}#) (defprimitive /iraw (:long a b) :long :doc #{Integer raw division of $a and $b, crash on zero-divide.}# #{(($a) / ($b))}#) (defprimitive %iraw (:long a b) :long :doc #{Integer raw modulus of $a and $b, crash on zero-divide.}##{(($a) % ($b))}#) ;; boolean not (defprimitive not (:long i) :long :doc #{Integer unary logical negation of $i.}# #{(!($i))}#) ;;; citerator on integers (defciterator foreach_long_upto (:long imin imax) ;start formals eachlong ;state (:long ix) ;local formals :doc #{The $FOREACH_LONG_UPTO c-iterator provides the usual ascending integer iterator. Start formals are $IMIN, the minimum start integer, and $IMAX, le maximal ending integer. Local formal is $IX, the current index. The body is executed for each integer value $IX from $IMIN to $IMAX included.}# ;before expansion #{/*start $eachlong */ long $eachlong#_min = $imin; long $eachlong#_max = $imax; long $eachlong#_cur = 0; for ($eachlong#_cur = $eachlong#_min; $eachlong#_cur <= $eachlong#_max; $eachlong#_cur ++) { $ix = $eachlong#_cur }# ;after expansion #{ } /*end eachlong */}# ) ;;; nullity test (for values) (defprimitive null (v) :long :doc #{Test that $V is the null value.}# #{(($v) == NULL)}#) (defprimitive notnull (v) :long :doc #{Test that $V is not the null value.}# #{(($v) != NULL)}#) ;;; zero test (for numbers) (defprimitive zerop (:long i) :long :doc #{Test that $I is zero.}# #{(($i) == OL)}#) ;; primitive for testing if debug (defprimitive need_dbg (:long depth) :long :doc #{Test if debug messages are needed for the given $DEPTH.}# #{(flag_melt_debug && melt_dbgcounter>=melt_debugskipcount && ($depth)>=0 && ($depth) <= MELTDBG_MAXDEPTH)}#) (defprimitive need_dbglim (:long depth limit) :long :doc #{Test if debug messages are needed for the given $DEPTH and $LIMIT.}# #{(flag_melt_debug && melt_dbgcounter>=melt_debugskipcount && ($depth)>=0 && ($depth) < ($limit))}#) ;;; debug on dumpfile (defprimitive outcstring_dbg (:cstring s) :void :doc #{output a debug string $S.}# #{melt_puts(dump_file,($s))}#) (defprimitive outnum_dbg (:cstring pref :long l :cstring suf) :void :doc #{debug output an integer $L with prefix $PREF and suffix $SUF.}# #{melt_putnum(dump_file,($pref), ($l), ($suf))}#) (defprimitive outstr_dbg (str) :void :doc #{output a debug string value $STR.}# #{melt_putstr(dump_file,(melt_ptr_t)($str))}#) (defprimitive outstrbuf_dbg (sbuf) :void :doc #{output a debug stringbuffer value $SBUF.}# #{melt_putstrbuf(dump_file,(melt_ptr_t)($sbuf))}#) (defprimitive outnewline_dbg () :void :doc #{output a debug newline.}# #{melt_newlineflush(dump_file)}#) ;;; output on stderr (defprimitive outnum_err (:cstring pref :long l :cstring suf) :void :doc #{output on stderr the number $L with prefix $PREF and suffix $SUF.}# #{melt_putnum(stderr,($pref), ($l), ($suf))}#) (defprimitive outcstring_err (:cstring s) :void :doc #{Output on stderr the string $s.}# #{melt_puts(stderr,($s))}#) (defprimitive outstrbuf_err (sbuf) :void :doc #{Output on stderr the stringbuffer value $sbuf.}# #{melt_putstrbuf(stderr,(melt_ptr_t)($sbuf))}#) (defprimitive outnewline_err () :void :doc #{Output on stderr a newline and flush.}# "melt_newlineflush(stderr)") (defprimitive outstr_err (str) :void :doc #{Output on stderr a MELT string.}# #{melt_putstr(stderr, (melt_ptr_t)($str))}#) (defprimitive message_dbg (:cstring msg) :void :doc #{Debug message $msg}# #{debugeputs(($msg))}#) (defprimitive messagenum_dbg (:cstring msg :long i) :void :doc #{Debug output with message $msg number $i}# #{debugnum(($msg), ($i))}#) (defprimitive messageval_dbg (:cstring msg :value val) :void :doc #{Debug output with message $msg value $val}# #{debugvalue(($msg), ((void*)($val)))}#) (defprimitive longbacktrace_dbg (:cstring msg :long maxdepth) :void :doc #{Detailed debug backtrace with message $MSG up to $MAXDEPTH.}# #{debugbacktrace(($msg), (int)(maxdepth))}#) (defprimitive shortbacktrace_dbg (:cstring msg :long maxdepth) :void :doc #{Short debug backtrace with message $MSG up to $MAXDEPTH.}# #{ #if ENABLE_CHECKING if (flag_melt_debug) melt_dbgshortbacktrace(($msg), ($maxdepth)); #endif }#) (defprimitive checkval_dbg (val :cstring msg) :value :doc #{Low-level costly check of value $VAL with message $MSG. Mostly useful for gurus.}# #{melt_checked_assignmsg (($val),($msg))}#) (defprimitive debugcstring (:cstring msg str) :void :doc #{Debug cstring $MSG $STR.}# #{debugeprintf("debugcstring %s '%s'", $msg, $str)}#) (defprimitive the_null_cstring () :cstring :doc #{The null const cstring.}# #{(char*)0}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; STRBUF primitives ;; primitive to make a strbuf (defprimitive make_strbuf (discr) :value :doc #{Make a new stringbuffer value of given $DISCR - or null if bad $DISCR.}# #{meltgc_new_strbuf((meltobject_ptr_t)($discr), (char*)0)}#) (defprimitive strbuf_usedlength (sbuf) :long :doc #{Give the used length of given $SBUF string buffer or else 0.}# #{melt_strbuf_usedlength((melt_ptr_t)($sbuf))}#) (defprimitive is_strbuf (v) :long :doc #{Test if value $V is a stringbuffer.}# #{(melt_magic_discr((melt_ptr_t)($v)) == OBMAG_STRBUF)}#) ;; actually all the sbuf routines now take an outbuf argument, which can be either a string buffer of a file (defprimitive is_out (v) :long :doc #{Test if value $V is a output value (a stringbuffer or a file).}# #{ (melt_is_out ((melt_ptr_t) $v)) }#) ;; primitive to add a string const into a strbuf (defprimitive add2sbuf_strconst (sbuf :cstring str) :void :doc #{Add into stringbuffer $SBUF the constant string $STR.}# #{meltgc_add_strbuf((melt_ptr_t)($sbuf), ($str))}#) ;; primitive to add a string value into a strbuf (defprimitive add2sbuf_string (sbuf str) :void :doc #{Add into stringbuffer $SBUF the string value $STR.}# #{meltgc_add_strbuf((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add the location info of a mixedloc into a strbuf (defprimitive add2sbuf_mixloc (sbuf mixl) :void :doc #{Add into stringbuffer $SBUF the mixed loc $MIXL.}# #{/*add2sbufmixloc*/ if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC) meltgc_strbuf_printf((melt_ptr_t)($sbuf), "{%s:%d}", LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl)), LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mixl))); }#) ;; primitive to add the short location info of a mixedloc into a strbuf (defprimitive add2sbuf_short_mixloc (sbuf mixl) :void :doc #{Add into stringbuffer $SBUF the mixed loc $MIXL in short form.}# #{/*add2sbufshortmixloc*/ { if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC) meltgc_strbuf_printf((melt_ptr_t)($sbuf), "{%s:%d}", lbasename(LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl))), LOCATION_LINE(melt_location_mixloc((melt_ptr_t)" mixl "))); }#) ;; primitive to add the texi location info of a mixedloc into a strbuf (defprimitive add2sbuf_texi_mixloc (sbuf mixl) :void :doc #{Add into stringbuffer $SBUF the mixed loc $MIXL in texinfo form.}# #{/*add2sbufteximixloc*/ if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC) meltgc_strbuf_printf((melt_ptr_t)($sbuf), "file @file{%s}, line %d", lbasename(LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl))), LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mixl))); }#) ;; primitive to add an indentation or space into a strbuf (defprimitive add2sbuf_indent (sbuf :long depth) :void :doc #{Add into stringbuffer $SBUF an indentation of given $DEPTH or a space.}# #{meltgc_strbuf_add_indent((melt_ptr_t)($sbuf), ($depth), 64)}#) ;; primitive to add an indented newline into a strbuf (defprimitive add2sbuf_indentnl (sbuf :long depth) :void :doc #{Add into stringbuffer $SBUF an indented newline of given $DEPTH.}# #{meltgc_strbuf_add_indent((melt_ptr_t)($sbuf), ($depth), 0)}#) ;; primitive to add a strbuf into a strbuf (defprimitive add2sbuf_sbuf (sbuf asbuf) :void :doc #{Add into stringbuffer $SBUF the content of stringbuffer $ASBUF.}# #{meltgc_add_strbuf((melt_ptr_t)($sbuf), melt_strbuf_str($asbuf))}#) ;; primitive to add a string value, C encoded, into a strbuf (defprimitive add2sbuf_cencstring (sbuf str) :void :doc #{Add into stringbuffer $SBUF the content of string $STR with C encoding.}# #{meltgc_add_strbuf_cstr((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add a strbuf, C encoded, into a strbuf (defprimitive add2sbuf_cencstrbuf (sbuf asbuf) :void :doc #{Add into stringbuffer $SBUF the content of stringbuffer $ASBUF with C encoding.}# #{meltgc_add_strbuf_cstr((melt_ptr_t)($sbuf), melt_strbuf_str((melt_ptr_t)($asbuf)))}#) ;; primitive to add a string value, Ccomment encoded, into a strbuf (defprimitive add2sbuf_ccomstring (sbuf str) :void :doc #{Add into stringbuffer $SBUF the content of string $STR with C-comment encoding, i.e. avoiding */.}# #{meltgc_add_strbuf_ccomment((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add a strbuf, C encoded, into a strbuf (defprimitive add2sbuf_ccomstrbuf (sbuf asbuf) :void :doc #{Add into stringbuffer $SBUF the content of stringbuffer $ASBUF with C-comment encoding, i.e. avoiding */.}# #{meltgc_add_strbuf_ccomment((melt_ptr_t)($sbuf), melt_strbuf_str((melt_ptr_t)($asbuf)))}#) ;; primitive to add a cstring const, Ccomment encoded, into a strbuf (defprimitive add2sbuf_ccomconst (sbuf :cstring cstr) :void :doc #{Add into stringbuffer $SBUF the constant string $CSTR with C-comment encoding so no */.}# #{meltgc_add_strbuf_ccomment(($sbuf), $cstr)}#) ;; primitive to add into a strbuf a string as C ident (nonalphanum ;; replaced by _) (defprimitive add2sbuf_cident (sbuf str) :void :doc #{Add into stringbuffer $SBUF the string $STR as a C identifier so nonalphanum replaced by _.}# #{meltgc_add_strbuf_cident((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add into a strbuf the prefix of a string as C ident (nonalphanum ;; replaced by _) limited by a small length (defprimitive add2sbuf_cidentprefix (sbuf str :long preflen) :void :doc #{Add into stringbuffer $SBUF the prefix string $STR as a C identifier so nonalphanum replaced by _ limited by $PREFLEN.}# #{meltgc_add_strbuf_cidentprefix((melt_ptr_t)($sbuf), melt_string_str((melt_ptr_t)($str)), ($preflen))}#) ;; primitive to add a long in decimal into a strbuf (defprimitive add2sbuf_longdec (sbuf :long num) :void :doc #{Add into stringbuffer $SBUF the number $NUM in decimal.}# #{meltgc_add_strbuf_dec((melt_ptr_t)($sbuf), ($num))}#) ;; primitive to add a long in hex into a strbuf (defprimitive add2sbuf_longhex (sbuf :long num) :void :doc #{Add into stringbuffer $SBUF the number $NUM in hexa.}# #{meltgc_add_strbuf_hex((melt_ptr_t)($sbuf), ($num))}#) ;; primitive to add a routine descr into a strbuf (defprimitive add2sbuf_routinedescr (sbuf rout) :void :doc #{Add into stringbuffer $SBUF the routine descriptor $ROUT.}# #{meltgc_add_strbuf((melt_ptr_t)($sbuf), melt_routine_descrstr((melt_ptr_t)($rout)))}#) ;;; primitive to output a strbuf into a file named by a cstring (defprimitive output_sbuf_strconst (sbuf :cstring nam) :void :doc #{Output into file named $NAM the content of strinbuffer $SBUF.}# #{ melt_output_strbuf_to_file(($sbuf), ($nam)) }#) ;;; primitive to output a strbuf into a file named by a stringval (defprimitive output_sbuf_strval (sbuf vnam) :void :doc #{Output into file named by string value $VNAM the content of strinbuffer $SBUF.}# #{ melt_output_strbuf_to_file(($sbuf), melt_string_str($vnam)) }#) ;;;;;;;;;;;;;;;; variant for outbuf ;; primitive to add a string const into a outbuf (defprimitive add2out_strconst (out :cstring str) :void :doc #{Add to output $OUT the cstring $STR.}# #{meltgc_add_out((melt_ptr_t)($out), ($str))}#) ;; primitive to add a string value into a outbuf (defprimitive add2out_string (out str) :void :doc #{Add to output $OUT the string value $STR.}# #{meltgc_add_out((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add the location info of a mixedloc into a outbuf (defprimitive add2out_mixloc (out mixl) :void :doc #{Add to output $OUT the mixed location $MIXL.}# #{/*add2outmixloc*/ { if (melt_magic_discr((melt_ptr_t)($mixl)) == OBMAG_MIXLOC) meltgc_out_printf((melt_ptr_t)(" out "), "{%s:%d}", LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mixl)), LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mixl))); }#) ;; primitive to add an indentation or space into a outbuf (defprimitive add2out_indent (out :long depth) :void :doc #{Add to output $OUT the indentation $DEPTH or a space.}# #{meltgc_out_add_indent((melt_ptr_t)($out), ($depth), 64)}#) ;; primitive to add an indented newline into a outbuf (defprimitive add2out_indentnl (out :long depth) :void :doc #{Add to output $OUT the indented newline of given $DEPTH.}# #{meltgc_out_add_indent((melt_ptr_t)($out), ($depth), 0)}#) ;; primitive to add a strbuf into a outbuf (defprimitive add2out_sbuf (out asbuf) :void :doc #{Add to output $OUT the stringbuffer $ASBUF.}# #{meltgc_add_out((melt_ptr_t)($out), melt_out_str($asbuf))}#) ;; primitive to add a string value, C encoded, into a outbuf (defprimitive add2out_cencstring (out str) :void :doc #{Add to output $OUT the C-encoded string value $STR.}# #{meltgc_add_out_cstr((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add a strbuf, C encoded, into a outbuf (defprimitive add2out_cencstrbuf (out asbuf) :void :doc #{Add to output $OUT the C-encoded stringbuffer $ASBUF.}# #{meltgc_add_out_cstr((melt_ptr_t)($out), melt_out_str((melt_ptr_t)($asbuf)))}#) ;; primitive to add a string value, Ccomment encoded, into a outbuf (defprimitive add2out_ccomstring (out str) :void :doc #{Add to output $OUT the C-comment encoded string value $STR.}# #{meltgc_add_out_ccomment((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add a strbuf, C encoded, into a outbuf (defprimitive add2out_ccomstrbuf (out asbuf) :void :doc #{Add to $OUT the C-comment encoded stringbuffer $ASBUF.}# #{meltgc_add_out_ccomment((melt_ptr_t)($out), melt_out_str((melt_ptr_t)($asbuf)))}#) ;; primitive to add a cstring const, Ccomment encoded, into a outbuf (defprimitive add2out_ccomconst (out :cstring cstr) :void :doc #{Add to $OUT the constant C-comment encoded raw $CSTR.}# #{meltgc_add_out_ccomment(($out), $cstr)}#) ;; primitive to add into a outbuf a string as C ident (nonalphanum ;; replaced by _) (defprimitive add2out_cident (out str) :void :doc #{Add to $OUT the MELT string $STR encocded as a C identifier, so with every non-alnum character replaced with an underscore.}# #{meltgc_add_out_cident((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)))}#) ;; primitive to add into a outbuf the prefix of a string as C ident (nonalphanum ;; replaced by _) limited by a small length (defprimitive add2out_cidentprefix (out str :long preflen) :void :doc #{Add to $OUT the prefix of a string encoded as a C identifier, limited by a small length $PREFLEN.}# #{meltgc_add_out_cidentprefix((melt_ptr_t)($out), melt_string_str((melt_ptr_t)($str)), ($preflen))}#) ;; primitive to add a long in decimal into a outbuf (defprimitive add2out_longdec (out :long num) :void :doc #{Add to $OUT the number $NUM in decimal.}# #{meltgc_add_out_dec((melt_ptr_t)($out), ($num))}#) ;; primitive to add a long in hex into a outbuf (defprimitive add2out_longhex (out :long num) :void :doc #{Add to $OUT the number $NUM in hex.}# #{meltgc_add_out_hex((melt_ptr_t)($out), ($num))}#) ;; primitive to add a routine descr into a outbuf (defprimitive add2out_routinedescr (out rout) :void :doc #{Add to $OUT the routine desscriptor $ROUT.}# #{meltgc_add_out((melt_ptr_t)($out), melt_routine_descrstr((melt_ptr_t)($rout)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; STRING primitives ;; primitive for testing if a value is a string (defprimitive is_string (str) :long :doc #{Test that $STR is a string values.}# #{(melt_magic_discr((melt_ptr_t)($str)) == OBMAG_STRING)}#) ;; string equal (defprimitive ==s (s1 s2) :long :doc #{Test that $S1 and $S2 are both string values and are equal.}# #{melt_string_same((melt_ptr_t)($s1), (melt_ptr_t)($s2))}#) (defprimitive !=s (s1 s2) :long :doc #{Test that $S1 and $S2 are not both string equal values.}# #{!melt_string_same((melt_ptr_t)($s1), (melt_ptr_t)($s2))}#) ;;; make a string (defprimitive make_string (dis str) :value :doc #{Make a new string of discriminant $DIS from string value $STR.}# #{(meltgc_new_stringdup((meltobject_ptr_t)($dis), melt_string_str((melt_ptr_t)($str))))}#) (defprimitive make_stringconst (dis :cstring cstr) :value :doc #{Make a new string of distriminant $DIS from raw string constant $CSTR.}# #{(meltgc_new_stringdup((meltobject_ptr_t)($dis), ($cstr)))}#) (defprimitive is_stringconst (str :cstring cs) :long :doc #{Test that value string $STR is the raw string constant $CS.}# #{(melt_is_string_const((melt_ptr_t)($str), ($cs)))}#) (defprimitive string_length (str) :long :doc #{Give the length of string value $STR.}# #{melt_string_length((melt_ptr_t)($str))}#) (defprimitive string= (s1 s2) :long :doc #{Test that value strings $S1 and $S2 are equal as strings.}# #{melt_string_same(($s1), ($s2))}#) (defprimitive string< (s1 s2) :long :doc #{Test that value string $S1 is less than $S2, compared alphanumerically as strings.}# #{melt_string_less((melt_ptr_t)($s1), (melt_ptr_t)($s2))}#) (defprimitive string> (s1 s2) :long :doc #{Test that value string $S1 is greater than $S2.}# #{melt_string_less((melt_ptr_t)($s2), (melt_ptr_t)($s1))}#) (defprimitive split_string_space (dis :cstring cs) :value :doc #{Split a cstring $CS into a list of space separated strings of discriminant $DIS.}# #{meltgc_new_split_string($cs, ' ', (melt_ptr_t) $dis)}#) (defprimitive split_string_comma (dis :cstring cs) :value :doc #{Split a cstring $CS into a list of comma separated strings of discriminant $DIS.}# #{meltgc_new_split_string($cs, ',', (melt_ptr_t) $dis)}#) (defprimitive split_string_colon (dis :cstring cs) :value :doc #{Split a cstring $CS into a list of colon separated strings of discriminant $DIS.}# #{meltgc_new_split_string($cs, ':', (melt_ptr_t)$dis)}#) ;;; convert a strbuf into a string (defprimitive strbuf2string (dis sbuf) :value :doc #{make a string value of discriminant $DIS from the stringbuffer $SBUF.}# #{(meltgc_new_stringdup((meltobject_ptr_t)($dis), melt_strbuf_str((melt_ptr_t)($sbuf))))}#) ;;; compute the naked basename (defprimitive make_string_nakedbasename (dis str) :value :doc #{make a string value of discriminant $DIS from the naked basename from file path $STR.}# #{(meltgc_new_string_nakedbasename((meltobject_ptr_t)($dis), melt_string_str((melt_ptr_t)($str))))}#) ;;; compute the naked temporary path for a basename with a suffix (defprimitive make_string_tempname_suffixed (dis str :cstring suff) :value #{(meltgc_new_string_tempname_suffixed((meltobject_ptr_t)($dis), melt_string_str((melt_ptr_t)($str)), ($suff)))}#) ;;;; compile a C code file as module and load it. First argument is an ;;;; environment, second argument is the string containing the C file ;;;; path. Return value is the new environment provided by the loaded ;;;; module. (defprimitive load_melt_module (env str) :value :doc #{load a MELT module by C compilation of file $STR with environment $ENV. Gives the new environment after loading the module.}# #{(meltgc_load_melt_module((melt_ptr_t)($env), melt_string_str((melt_ptr_t)($str))))}#) ;; generate a loadable module from a MELT generated C source file; the ;; out is the dynloaded module without any *.so suffix (defprimitive generate_melt_module (src outnam) :void :doc #{Generate and load a module whose source is named after $SRC and whose binary is named after $OUTNAM without any '.so' suffix.}# #{meltgc_generate_melt_module($src,$outnam);}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; OBJECT primitives ;; primitive to get an object length (defprimitive object_length (ob) :long :doc #{Gives the length of object $OB.}# #{((long)melt_object_length((melt_ptr_t)($ob)))}#) ;; primitive to get the nth field of an object (defprimitive object_nth_field (ob :long n) :value :doc #{Safely retrieve from object $OB its $N-th field or else null.}# #{(melt_field_object((melt_ptr_t)($ob), ($n)))}#) (defprimitive subclass_of (cl1 cl2) :long :doc #{Safely test if class $CL1 is a sub-class of class $CL2.}# #{melt_is_subclass_of((meltobject_ptr_t)($cl1), (meltobject_ptr_t)($cl2))}#) (defprimitive subclass_or_eq (cl1 cl2) :long :doc #{Safely test if class $CL1 is the same or a sub-class of class $CL2.}# #{(($cl1 == $cl2) || melt_is_subclass_of((meltobject_ptr_t)($cl1), (meltobject_ptr_t)($cl2)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; MULTIPLEs primitives ;;;; test (defprimitive is_multiple (mul) :long :doc #{Safely test if $MUL is a tuple.}# #{(melt_magic_discr((melt_ptr_t)($mul)) == OBMAG_MULTIPLE)}#) (defprimitive is_multiple_or_null (mul) :long :doc #{Safely test if $MUL is a tuple or null.}# #{(($mul) == NULL || (melt_unsafe_magic_discr((melt_ptr_t)($mul)) == OBMAG_MULTIPLE))}#) ;;; make (defprimitive make_multiple (discr :long ln) :value :doc #{Make a tuple of given discriminant $DISCR and length $LN - gives null otherwise.}# #{(meltgc_new_multiple((meltobject_ptr_t)($discr), ($ln)))}#) (defprimitive make_tuple1 (discr v1) :value :doc #{Make a 1-tuple of discriminant $DISCR and content $V1.}# #{(meltgc_new_mult1((meltobject_ptr_t)($discr), (melt_ptr_t)($v1)))}#) (defprimitive make_tuple2 (discr v1 v2) :value :doc #{Make a 2-tuple of discriminant $DISCR and content $V1 $V2.}# #{(meltgc_new_mult2((meltobject_ptr_t)($discr), (melt_ptr_t)($v1), (melt_ptr_t)($v2)))}#) (defprimitive make_tuple3 (discr v1 v2 v3) :value :doc #{Make a 3-tuple of discriminant $DISCR and content $V1 $V2 $V3.}# #{(meltgc_new_mult3((meltobject_ptr_t)($discr), (melt_ptr_t)($v1), (melt_ptr_t)($v2), (melt_ptr_t)($v3)))}#) (defprimitive make_tuple4 (discr v1 v2 v3 v4) :value :doc #{Make a 4-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4.}# #{(meltgc_new_mult4((meltobject_ptr_t)($discr), (melt_ptr_t)($v1), (melt_ptr_t)($v2), (melt_ptr_t)($v3), (melt_ptr_t)($v4)))}#) (defprimitive make_tuple5 (discr v1 v2 v3 v4 v5) :value :doc #{Make a 5-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4 $V5.}# #{(meltgc_new_mult5((meltobject_ptr_t)($discr), (melt_ptr_t)($v1), (melt_ptr_t)($v2), (melt_ptr_t)($v3), (melt_ptr_t)($v4), (melt_ptr_t)($v5)))}#) (defprimitive make_tuple6 (discr v1 v2 v3 v4 v5 v6) :value :doc #{Make a 6-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4 $V5 $V6.}# #{(meltgc_new_mult6((meltobject_ptr_t)($discr), (melt_ptr_t)($v1), (melt_ptr_t)($v2), (melt_ptr_t)($v3), (melt_ptr_t)($v4), (melt_ptr_t)($v5), (melt_ptr_t)($v6)))}#) (defprimitive make_tuple7 (discr v1 v2 v3 v4 v5 v6 v7) :value :doc #{Make a 7-tuple of discriminant $DISCR and content $V1 $V2 $V3 $V4 $V5 $V6 $V7.}# #{(meltgc_new_mult7((meltobject_ptr_t)($discr), (melt_ptr_t)($v1), (melt_ptr_t)($v2), (melt_ptr_t)($v3), (melt_ptr_t)($v4), (melt_ptr_t)($v5), (melt_ptr_t)($v6), (melt_ptr_t)($v7)))}#) ;; primitive to build the subsequence of a multiple (defprimitive subseq_multiple (mul :long startix endix) :value :doc #{Make a tuple from as subsequence of $MUL from indexes $STARTIX to $ENDIX.}# #{ meltgc_new_subseq_multiple((melt_ptr_t)($mul), (int)($startix), (int)($endix)) }#) ;; primitive to get the nth in a multiple (defprimitive multiple_nth (mul :long n) :value :doc #{Safely retrieve from tuple $MUL its $N-th component or else null.}# #{(melt_multiple_nth((melt_ptr_t)($mul), ($n)))}#) ;; primitive to get the length of a multiple (defprimitive multiple_length (mul) :long :doc #{Gives the length of tuple $MUL.}# #{(melt_multiple_length((melt_ptr_t)($mul)))}#) ;; put into a multiple. (defprimitive multiple_put_nth (mul :long n :value v) :void :doc #{Put into tuple $MUL at rank $N the component $V. Avoid circularities!}# #{meltgc_multiple_put_nth((melt_ptr_t)($mul), ($n), (melt_ptr_t)($V))}#) ;; sort a multiple, the compare function should return a boxed integer (defprimitive multiple_sort (mul cmp discrm) :value :doc #{Gives the sorted tuple from tuple $MUL using compare function $CMP (returning a boxed integer) and discriminant $DISCRM.}# #{meltgc_sort_multiple((melt_ptr_t)($mul), (melt_ptr_t)($cmp), (melt_ptr_t)($discrm))}#) ;; public comparator for named instances (defun compare_named_alpha (n1 n2) :doc #{Alphanumerical compare of named instances $N1 and $N2. Returns a boxed integer.}# (cond ( (== n1 n2) '0) ( (is_not_a n1 class_named) '1) ( (is_not_a n2 class_named) '-1) (:else (let ( (sn1 (unsafe_get_field :named_name n1)) (sn2 (unsafe_get_field :named_name n2)) ) (cond ( (string< sn1 sn2) '-1) ( (string> sn1 sn2) '1) (:else '0)))))) ;; cmatcher for the tuple nth argument (defcmatcher tuple_nth (matchedtup :long matchedrk) ;match & ins (outcomp) ;out tupnth ;statesymb :doc #{The $TUPLE_NTH matcher with input number $MATCHEDRK matches a tuple of length greater than $MATCHEDRK and retrieve the component of that index, and matches it against the sub-pattern.}# ;;test expansion #{/*$TUPNTH ?*/ (melt_is_multiple_at_least(((melt_ptr_t)$matchedtup), 1+ (int)($matchedrk)))}# ;;fill expansion #{/*$TUPNTH !*/ $outcomp = melt_multiple_nth((melt_ptr_t)($matchedtup),(int)($matchedrk)); }# ;; no operator expansion ) ;;; cmatcher for a cstring of a given content (defcmatcher cstring_same (:cstring str cstr) () strsam :doc #{The $CSTRING_SAME c-matcher match a string $STR and test if it equals to the constant string $CSTR. The match fails if $STR is a null string or different from $CSTR.}# #{/*$strsam test*/ ($str && $cstr && !strcmp($str, $cstr)) }# ;; no fill or operator ) ;; primitive to compute the length of a cstring (defprimitive cstring_length (:cstring cstr) :long :doc #{Compute safely the length a C-string $cstr. Gives 0 if null argument. }# #{(($cstr)?strlen($cstr):0)}#) ;; cmatcher for a tuple of a given exact size (defcmatcher tuple_sized (tup :long ln) ;match & ins () ;outs tupsiz ;statesymb :doc #{Match a tuple of given exact size.}# ;;test expansion #{(melt_is_multiple_of_length((melt_ptr_t)($tup), (int) ($ln)))}# ;; no fill expansion ;; no operator expansion ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; MAPOBJECTs primitives ;;;; test (defprimitive is_mapobject (map) :long :doc #{Test if given $MAP is an object map.}# #{(melt_magic_discr((melt_ptr_t)($map)) == OBMAG_MAPOBJECTS)}#) ;; primitive to get the allocated size of a mapobject (defprimitive mapobject_size (map) :long :doc #{Safely retrieve the allocated size of given object-map $MAP or else 0.}# #{(melt_size_mapobjects((meltmapobjects_ptr_t)($map)))}#) ;; primitive to get the attribute count of a mapobject (defprimitive mapobject_count (map) :long :doc #{Safely retrieve the count of given object-map $MAP or else 0.}# #{(melt_count_mapobjects((meltmapobjects_ptr_t)($map)))}#) ;; primitive to get the nth attribute of a mapobject (defprimitive mapobject_nth_attr (map :long n) :value :doc #{Safely retrieve from given object-map $MAP its $N-th attribute or else null.}# #{(melt_nthattr_mapobjects((meltmapobjects_ptr_t)($map), (int)($n)))}#) ;; primitive to get the nth value of a mapobject (defprimitive mapobject_nth_val (map :long n) :value :doc #{Safely retrieve from given object-map $MAP its $N-th value or else null.}# #{(melt_nthval_mapobjects((meltmapobjects_ptr_t)($map), (int)($n)))}#) ;; primitive to get the value of an attribute in a mapobject (defprimitive mapobject_get (map attr) :value :doc #{Safely get from given object-map $MAP the value associated to $ATTR or else null.}# #{melt_get_mapobjects((meltmapobjects_ptr_t)($map), (meltobject_ptr_t)($attr))}#) ;; primitive for making a new map of objects (defprimitive make_mapobject (discr :long len) :value :doc #{Make an object-map of discriminant $DISCR and initial size $LEN or null.}# #{(meltgc_new_mapobjects( (meltobject_ptr_t) ($discr), ($len)))}#) ;; primitive for putting into a map of objects (defprimitive mapobject_put (map key val) :void :doc #{Safely put into object-map $MAP the given $KEY with $VAL.}# #{meltgc_put_mapobjects( (meltmapobjects_ptr_t) ($map), (meltobject_ptr_t) ($key), (melt_ptr_t)($val))}#) ;; primitive for removing from a map of objects (defprimitive mapobject_remove (map key) :void :doc #{Safely remove from object-map $MAP the given $KEY.}# #{meltgc_remove_mapobjects( (meltmapobjects_ptr_t) ($map), (meltobject_ptr_t)($key))}#) ;;; iterator inside a map of object (defciterator foreach_in_mapobject (:value objmap) eachobmap (:value curat curva) :doc #{The $FOREACH_IN_MAPOBJECT c-iterator iterates inside the given $OBJMAP and retrieves a $CURAT attribute and its $CURVA value.}# ;; before expansion #{ /*$eachobmap :*/ int $eachobmap#_ix=0, $eachobmap#_siz=0; for ($eachobmap#_ix=0; /* we retrieve in $eachobmap#_siz the size at each iteration since it could change. */ $eachobmap#_ix>=0 && ($eachobmap#_siz= melt_size_mapobjects($objmap))>0 && $eachobmap#_ix < $eachobmap#_siz; $eachobmap#_ix++) { $curat = NULL; $curva = NULL; $curat = ((meltmapobjects_ptr_t)$objmap)->entab[$eachobmap#_ix].e_at; if ($curat == HTAB_DELETED_ENTRY) { $curat = NULL; continue; }; if (!$curat) continue; $curva = ((meltmapobjects_ptr_t)$objmap)->entab[$eachobmap#_ix].e_va; if (!$curva) continue; }# ;;; after expansion #{ /* end $eachobmap */ $curat = NULL; $curva = NULL; } }# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; MAPSTRINGs primitive ;; test (defprimitive is_mapstring (map) :long :doc #{Safely test if $MAP is a string-map.}# #{(melt_magic_discr((melt_ptr_t)($map)) == OBMAG_MAPSTRINGS)}#) ;; primitive to get the allocated size of a mapstring (defprimitive mapstring_size (map) :long :doc #{Safely return the current allocated size of a string-map $MAP or else 0.}# #{(melt_size_mapstrings((struct meltmapstrings_st*)($map)))}#) ;; primitive to get the attribute count of a mapstring (defprimitive mapstring_count (map) :long :doc #{Safely return the current count of a string-map $MAP or else 0.}# #{(melt_count_mapstrings((struct meltmapstrings_st*)($map)))}#) ;; get an entry in a mapstring from a C string (defprimitive mapstring_rawget (map :cstring cstr) :value :doc #{Safely get in a string-map $MAP the value associated with raw c-string $CSTR or else null.}# #{(melt_get_mapstrings((struct meltmapstrings_st*)($map), ($cstr)))}#) ;; primitive for making a new map of strings (defprimitive make_mapstring (discr :long len) :value :doc #{Make a new string-map of discriminant $DISCR and initial length $LEN - or null if failed.}# #{(meltgc_new_mapstrings( (meltobject_ptr_t) ($discr), ($len)))}#) ;; primitive for putting into a map of strings (defprimitive mapstring_rawput (map :cstring key :value val) :void :doc #{Safely put into a string-map $MAP the raw c-string $KEY associated to value $VAL.}# #{meltgc_put_mapstrings( (struct meltmapstrings_st *) ($map), ($key), (melt_ptr_t) ($val))}#) (defprimitive mapstring_putstr (map keystr val) :void :doc #{Safely put into a string-map $MAP the string value $KEYSTR associated to value $VAL.}# #{meltgc_put_mapstrings((struct meltmapstrings_st *) ($map), melt_string_str((melt_ptr_t)($keystr)), (melt_ptr_t)($val))}#) (defprimitive mapstring_getstr (map keystr) :value :doc #{Safely get in a string-map $MAP the value associated with a value string $KEYSTR or else null.}# #{(melt_get_mapstrings((struct meltmapstrings_st*)($map), melt_string_str((melt_ptr_t)($keystr))))}#) ;; primitives for removing from a map of strings (defprimitive mapstring_rawremove (map :cstring key) :void :doc #{Safely remove from a string-map $MAP the value associated with raw c-string $KEY.}# #{meltgc_remove_mapstrings((struct meltmapstrings_st*) ($map), ($key))}#) (defprimitive mapstring_removestr (map keystr) :void :doc #{Safely remove from a string-map $MAP the value associated with string value $KEYSTR.}# #{meltgc_remove_mapstrings((struct meltmapstrings_st*) ($map), melt_string_str((melt_ptr_t)$keystr))}#) ;; primitive to make the nth stringattr of a mapobject (defprimitive mapstring_nth_attrstr (map sdicr :long n) :value :doc #{Safely get from string-map $MAP the $N-th string and make a string value of discriminant $SDICR from it.}# #{(meltgc_new_stringdup((meltobject_ptr_t)($sdicr), melt_nthattrraw_mapstrings((struct meltmapstrings_st*)($map), (int)($n))))}#) ;; primitive to get the nth value of a mapobject (defprimitive mapstring_nth_val (map :long n) :value :doc #{Safely retrieve from string-map $MAP its $N-th value or null.}# #{(melt_nthval_mapstrings((struct meltmapstrings_st*)($map), (int)($n)))}#) ;;; iterator inside a map of strings (defciterator foreach_in_mapstring (:value strmap) eachstrmap (:value curat curva) :doc #{The $FOREACH_IN_MAPSTRING c-iterator iterates inside the given $STRMAP and retrieves a $CURAT string attribute value and its $CURVA value. If $CURVA happens to be an instance of $CLASS_NAMED with a name equal to the string key, we use it as $CURAT otherwise we make a $CURAT string.}# ;; before expansion #{ /*$eachstrmap :*/ int $eachstrmap#_ix=0, $eachstrmap#_siz=0; for ($eachstrmap#_ix=0; /* we retrieve in $eachstrmap#_siz the size at each iteration since it could change. */ $eachstrmap#_ix>=0 && ($eachstrmap#_siz= melt_size_mapstrings($strmap))>0 && $eachstrmap#_ix < $eachstrmap#_siz; $eachstrmap#_ix++) { const char* $eachstrmap#_str = NULL; const char* $eachstrmap#_nam = NULL; $curat = NULL; $curva = NULL; $eachstrmap#_str = ((struct meltmapstrings_st*)$strmap)->entab[$eachstrmap#_ix].e_at; if ($eachstrmap#_str == HTAB_DELETED_ENTRY) { $curat = NULL; continue; }; if (!$eachstrmap#_str) continue; $curva = ((struct meltmapstrings_st*)$strmap)->entab[$eachstrmap#_ix].e_va; if (!$curva) continue; if (melt_is_instance_of($curva, MELT_PREDEF (CLASS_NAMED)) && ($curat = melt_object_nth_field ((melt_ptr_t) $curva, FNAMED_NAME)) != NULL && ($eachstrmap#_nam = melt_string_str ((melt_ptr_t) $curat)) != (char*)0 && !strcmp ($eachstrmap#_nam, $eachstrmap#_str)) $curat = $curat; else { $curat = NULL; $curat = meltgc_new_stringdup((meltobject_ptr_t) MELT_PREDEF (DISCR_STRING), $eachstrmap#_str); } $eachstrmap#_str = (const char*)0; $eachstrmap#_nam = (const char*)0; }# ;;; after expansion #{ /* end $eachstrmap */ $curat = NULL; $curva = NULL; } }# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; ROUTINEs primitives ;; test (defprimitive is_routine (rou) :long :doc #{Test if value $ROU is a routine.}# #{(melt_magic_discr((melt_ptr_t)($rou)) == OBMAG_ROUTINE)}#) ;;; descriptive string of a routine (defprimitive routine_descr (rou) :value :doc #{Retrieve the descriptive value string of a routine $ROU or else null.}# #{(meltgc_new_stringdup(melt_routine_descrstr((melt_ptr_t)($rou))))}#) ;;; size of a routine (defprimitive routine_size (rou) :long :doc #{Gives the size of a routine value $ROU, i.e. its number of constants.}# #{(melt_routine_size((melt_ptr_t)($rou)))}#) ;;; nth comp in routine (defprimitive routine_nth (rou :long ix) :value :doc #{Retrieve in routine value $ROU its component of index $IX.}# #{(melt_routine_nth((melt_ptr_t)($rou), (int) ($ix)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; CLOSUREs primitives ;; test (defprimitive is_closure (clo) :long :doc #{Test if value $CLO is a closure, i.e. a functional value.}# #{(melt_magic_discr((melt_ptr_t)($clo)) == OBMAG_CLOSURE)}#) (defprimitive closure_size (clo) :long :doc #{Give the size of a closure value $CLO, i.e. the number of closed values.}# #{(melt_closure_size((melt_ptr_t)($clo)))}#) (defprimitive closure_routine (clo) :value :doc #{Give the routine value inside a closure value $CLO or else null.}# #{(melt_closure_routine((melt_ptr_t)($clo)))}#) (defprimitive closure_nth (clo :long ix) :value :doc #{Retrieve in closure value $CLO its component of index $IX.}# #{(melt_closure_nth((melt_ptr_t)($clo), (int)($ix)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; boxed INTEGERs primitives ;; test (defprimitive is_integerbox (ib) :long :doc #{Test if a value $IB is a boxed integer.}# #{(melt_magic_discr((melt_ptr_t)($ib)) == OBMAG_INT)}#) ;; to get the boxed integer use get_int ;; make (defprimitive make_integerbox (discr :long n) :value :doc #{Make a boxed integer of given discrimant $DISCR and integer $N.}# #{(meltgc_new_int((meltobject_ptr_t)($discr), ($n)))}#) ;;; pattern (defcmatcher integerbox_of (:value bx) (:long ict) iboxof :doc #{The $INTEGERBOX_OF matches a boxed integer $BX. If indeed it is a boxed integer, its integer content should match $ICT. The match fails if $BX is not a boxed integer (e.g. is the null value or non boxed-integer). See also $MAKE_INTEGERBOX $IS_INTEGERBOX.}# ;; test #{ /* $iboxof ?*/ $bx && melt_magic_discr($bx) == OBMAG_INT }# ;; fill #{ /* $iboxof !*/ $ict = ((struct meltint_st*)$bx)->val; }# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; BOX primitives (boxed values, i.e. reference) ;; test (defprimitive is_box (box) :long :doc #{Test if value $BOX is a box, ie a reference.}# #{(melt_magic_discr((melt_ptr_t)($box)) == OBMAG_BOX)}#) ;; safe fetch content (defprimitive box_content (box) :value :doc #{Safely retrieve the content of a box value $BOX or else null.}# #{melt_box_content((meltbox_ptr_t)($box))}#) ;; put into a box (defprimitive box_put (box val) :void :doc #{Safely put into box value $BOX the value $VAL.}# #{meltgc_box_put((melt_ptr_t)($box), (melt_ptr_t)($val))}#) ;; make a box (defprimitive make_box (discr valb) :value :doc #{Make a box value of discriminant $DISCR and content $VALB.}# #{meltgc_new_box((meltobject_ptr_t)($discr), (melt_ptr_t)($valb))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; LIST primitives ;; test (defprimitive is_list (li) :long :doc #{Test if value $LI is a list.}# #{(melt_magic_discr((melt_ptr_t)($li)) == OBMAG_LIST)}#) (defprimitive is_list_or_null (li) :long :doc #{Test iv value $LI is null or a list.}# #{(($li) == NULL || (melt_unsafe_magic_discr((melt_ptr_t)($li)) == OBMAG_LIST))}#) ;; first pair of list (defprimitive list_first (li) :value :doc #{Safely retrieve the first pair of list value $LI, or null.}# #{(melt_list_first((melt_ptr_t)($li)))}#) ;; last pair of list (defprimitive list_last (li) :value :doc #{Safely retrieve the last pair of list value $LI, or null.}# #{(melt_list_last((melt_ptr_t)($li)))}#) ;; length of list (defprimitive list_length (li) :long :doc #{Safely compute the length of list value $LI, or else 0.}# #{(melt_list_length((melt_ptr_t)($li)))}#) ;; append into list (defprimitive list_append (li el) :void :doc #{Safely append to list value $LI an element $EL thru a new pair.}# #{meltgc_append_list((melt_ptr_t)($li), (melt_ptr_t)($el))}#) ;; prepend into list (defprimitive list_prepend (li el) :void :doc #{Safely prepend to list value $LI an element $EL thru a new pair.}# #{meltgc_prepend_list((melt_ptr_t)($li), (melt_ptr_t)($el))}#) ;; pop first from list (defprimitive list_popfirst (li) :value :doc #{Pop the first element from a list $LI and give it, or else null.}# #{(meltgc_popfirst_list((melt_ptr_t)($li)))}#) ;; make list (defprimitive make_list (discr) :value :doc #{Make a new list value of given discriminant $DISCR.}# #{(meltgc_new_list((meltobject_ptr_t)($discr)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;; PAIR primitives ;; test (defprimitive is_pair (pa) :long :doc #{Test if a value $PA is a pair.}# #{(melt_magic_discr((melt_ptr_t)($pa)) == OBMAG_PAIR)}#) ;; head (defprimitive pair_head (pa) :value :doc #{Safely retrieve the head of pair value $PA or else null.}# #{(melt_pair_head((melt_ptr_t)($pa)))}#) ;; tail (defprimitive pair_tail (pa) :value :doc #{Safely retrieve the tail pair of pair value $PA or else null.}# #{(melt_pair_tail((melt_ptr_t)($pa)))}#) ;; change the head of a pair (defprimitive pair_set_head (pa hd) :void :doc #{Safely set in pair $PA its head to $HD. Please avoid using that to introduce circularities in lists.}# #{meltgc_pair_set_head((melt_ptr_t)($pa), ($hd))}#) ;; length of a pair list (defprimitive pair_listlength (pa) :long :doc #{Compute the linked length of given pair value $PA or else 0.}# #{(melt_pair_listlength((melt_ptr_t)($pa)))}#) ;; make (defprimitive make_pair (discr hd tl) :value :doc #{Create a new pair of given discrimiant $DISCR head $HD and tail $TL or else null.}# #{(meltgc_new_pair((meltobject_ptr_t)($discr), (melt_ptr_t)($hd), (melt_ptr_t)($tl)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; MIXINT primitives (use get_int to get the integer) ;; test (defprimitive is_mixint (mi) :long :doc #{Test if value $MI is a mixedint value.}# #{(melt_magic_discr((melt_ptr_t)($mi)) == OBMAG_MIXINT)}#) ;; get the value (defprimitive mixint_val (mi) :value :doc #{Get the value inside a mixedint value $MI. The integer can be retrieved using $GET_INT.}# #{(melt_val_mixint((melt_ptr_t)($mi)))}#) ;; make a mixint (defprimitive make_mixint (dis val :long num) :value :doc #{Make a mixint value of given discriminant $DIS value $VAL and number $NUM or else null.}# #{(meltgc_new_mixint((meltobject_ptr_t)($dis), (melt_ptr_t)($val), ($num)))}#) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; MIXLOC primitives (use get_int to get the integer) ;; test (defprimitive is_mixloc (mi) :long :doc #{Test if value $MI is a mixed location value.}# #{(melt_magic_discr((melt_ptr_t)($mi)) == OBMAG_MIXLOC)}#) ;; get the value (defprimitive mixloc_val (mi) :value :doc #{Safely retrieve the value inside a mixed location value $MI.}# #{(melt_val_mixloc((melt_ptr_t)($mi)))}#) (defprimitive mixloc_location (mi) :long :doc #{Safely retrieve as an opaque long the location of a mixed location value $MI.}# #{((long) melt_location_mixloc((melt_ptr_t)($mi)))}#) (defprimitive mixloc_locline (mi) :long :doc #{Retrieve the line of the location of a mixed location value $MI.}# #{(LOCATION_LINE(melt_location_mixloc((melt_ptr_t)$mi)))}#) (defprimitive mixloc_locfile (mi) :cstring :doc #{Retrieve the filename as a raw cstring of a mixed location value $MI.}# #{(LOCATION_FILE(melt_location_mixloc((melt_ptr_t)$mi)))}#) ;; make a mixloc (defprimitive make_mixloc (dis val :long num loc) :value :doc #{Make a mixed location value of given discriminant $DIS value $VAL number $NUM opaque location number $LOC.}# #{(meltgc_new_mixloc((meltobject_ptr_t)($dis), (melt_ptr_t)($val), ($num), (location_t)($loc)))}#) ;; test for mixbigint (defprimitive is_mixbigint (mb) :long :doc #{Test if value $MB is a mixed bigint.}# "(melt_magic_discr((melt_ptr_t)(" mb ")) == OBMAG_MIXBIGINT)") (defprimitive mixbigint_val (mb) :value :doc #{Retrieve the value inside a mixed bigint $MB.}# #{melt_val_mixbigint($mb)}#) (defprimitive ppstrbuf_mixbigint (:value sbuf :long indent :value mb) :void :doc #{Pretty prints into string buffer $SBUF at indentation $INDENT the mixed bigint $MB.}# #{meltgc_ppstrbuf_mixbigint($sbuf,$indent,$mb);}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; READ FILE primitive (defprimitive read_file (filnam) :value :doc #{Read from file named by the $FILNAM string balue a list of MELT s-expressions.}# #{(meltgc_read_file (melt_string_str((melt_ptr_t)($filnam)), (char*)0))}#) ;; to signal an error in a source with some additional string value (defprimitive error_strv (loc :cstring cmsg :value strv) :void :doc #{Show an error at boxed location $LOC with raw message string $CMSG and string value $STRV.}# #{melt_error_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)($strv))}#) ;; signal a plain error in a source (defprimitive error_plain (loc :cstring cmsg) :void :doc #{Show a plain error at boxed location $LOC with raw message string $CMSG.}# #{melt_error_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)0)}#) ;; to signal an warning in a source with some additional string value (defprimitive warning_strv (loc :cstring cmsg :value strv) :void :doc #{Show a warning at boxed location $LOC with raw message string $CMSG and string value $STRV.}# #{melt_warning_str(0, (melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)($strv))}#) ;; signal a plain warning in a source (defprimitive warning_plain (loc :cstring cmsg) :void :doc #{Show a plain warning at boxed location $LOC with raw message string $CMSG.}# #{melt_warning_str(0, (melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)0)}#) ;; signal a plain warning (defprimitive warningmsg_plain (:cstring cmsg) :void :doc #{Show a plain warning with raw message string $CMSG.}# #{warning(0, "MELT WARNING MSG [#%ld]::: %s", melt_dbgcounter, ($cmsg))}# ) ;; signal a plain warning (defprimitive warningmsg_strv (:cstring cmsg :value strv) :void :doc #{Show a plain warning with raw message string $CMSG and string value $STRV.}# #{warning (0, "MELT WARNING MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg), melt_string_str((melt_ptr_t)($strv)))}# ) ;; signal a plain error (defprimitive errormsg_plain (:cstring cmsg) :void :doc #{Show a plain error with raw message string $CMSG.}# #{error ("MELT ERROR MSG [#%ld]::: %s", melt_dbgcounter, ($cmsg))}# ) ;; signal a plain error (defprimitive errormsg_strv (:cstring cmsg :value strv) :void :doc #{Show a plain error with raw message string $CMSG and string value $STRV.}# #{error("MELT ERROR MSG [#%ld]::: %s - %s", melt_dbgcounter, ($cmsg), melt_string_str((melt_ptr_t)($strv)))}# ) ;; to signal an inform in a source with some additional string value (defprimitive inform_strv (loc :cstring cmsg :value strv) :void :doc #{Show a notice at boxed location $LOC with raw message string $CMSG and string value $STRV.}# #{melt_inform_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)($strv))}#) ;; signal a plain inform in a source (defprimitive inform_plain (loc :cstring cmsg) :void :doc #{Show a plain warning at boxed location $LOC with raw message string $CMSG.}# #{melt_inform_str((melt_ptr_t)($loc), ($cmsg), (melt_ptr_t)0)}#) (defprimitive informsg_strv (:cstring cmsg :value strv) :void :doc #{Show a plain notice with raw message string $CMSG and string value $STRV.}# #{inform(UNKNOWN_LOCATION, ("MELT INFORM [#%ld]: %s - %s"), melt_dbgcounter, ($cmsg), melt_string_str((melt_ptr_t)($strv)))}# ) (defprimitive informsg_plain (:cstring cmsg) :void :doc #{Show a plain notice with raw message string $CMSG.}# #{inform(UNKNOWN_LOCATION, "MELT INFORM [#%ld]: %s", melt_dbgcounter, ($cmsg))}# ) (defprimitive informsg_long (:cstring msg :long n) :void :doc #{Show a plain notice with raw message string $CMSG and number $N.}# #{inform(UNKNOWN_LOCATION, "MELT INFORM [#%ld]: %s * %ld", melt_dbgcounter, ($msg), ($n))}# ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; the discriminant for name strings (definstance discr_name_string class_discriminant :predef DISCR_NAME_STRING :obj_num OBMAG_STRING :doc #{The $DISCR_NAME_STRING is the discriminant of name strings, such as the $NAMED_NAME of symbols.}# ;;; :named_name '"DISCR_NAME_STRING" ;;; :disc_super discr_string ;; forward reference not allowed ) ;;; the discriminant for strings (definstance discr_string class_discriminant :predef DISCR_STRING :obj_num OBMAG_STRING :doc #{The $DISCR_STRING is the discriminant of strings. See also $DISCR_NAME_STRING and $DISCR_VERBATIM_STRING.}# :named_name '"DISCR_STRING") (unsafe_put_fields discr_name_string :disc_super discr_string) (unsafe_put_fields discr_name_string :named_name '"DISCR_NAME_STRING") ;;; the discriminant for verbatim strings (used for defprimitive) (definstance discr_verbatim_string class_discriminant :obj_num OBMAG_STRING :predef DISCR_VERBATIM_STRING :doc #{The $DISCR_VERBATIM_STRING is the discriminant of verbatim strings. See also $DISCR_STRING.}# :named_name '"DISCR_VERBATIM_STRING" :disc_super discr_string ) ;;; the discriminant for any receiver (used for sending to everything) (definstance discr_any_receiver class_discriminant :doc #{The $DISCR_ANY_RECEIVER is the topmost discriminant of any value. See also $CTYPE_VALUE.}# :named_name '"DISCR_ANY_RECEIVER" ) (unsafe_put_fields discr_string :disc_super discr_any_receiver) (unsafe_put_fields class_root :disc_super discr_any_receiver) ;;; the discriminant for null reciever (used for sending to nil) (definstance discr_null_receiver class_discriminant :doc #{The $DISCR_NULL_RECEIVER is the discriminant of the nil value, handling messages sent to nil.}# :predef DISCR_NULL_RECEIVER :disc_super discr_any_receiver :named_name '"DISCR_NULL_RECEIVER") ;;; the discriminant for strbuf (definstance discr_strbuf class_discriminant :doc #{The $DISCR_STRBUF is the discriminant of string buffer values.}# :predef DISCR_STRBUF :obj_num OBMAG_STRBUF :disc_super discr_any_receiver :named_name '"DISCR_STRBUF") ;;; the discriminant for integers (definstance discr_integer class_discriminant :doc #{The $DISCR_INTEGER is the discriminant of boxed integers. See also $CTYPE_LONG.}# :predef DISCR_INTEGER :obj_num OBMAG_INT :disc_super discr_any_receiver :named_name '"DISCR_INTEGER") ;;; the discriminant for constant integers, like '123 (definstance discr_constant_integer class_discriminant :predef DISCR_CONSTANT_INTEGER :obj_num OBMAG_INT :disc_super discr_integer :named_name '"DISCR_CONSTANT_INTEGER" :doc #{The $DISCR_CONSTANT_INTEGER is the discriminant for constant integer values, in particular those obtained by quoting an integer. The number inside is constant and remains unchanged by $PUT_INT. See also $DISCR_INTEGER.}# ) ;;; the discriminant for lists (definstance discr_list class_discriminant :doc #{The $DISCR_LIST is the discriminant of list values, made of pairs. See also $DISCR_PAIR.}# :predef DISCR_LIST :obj_num OBMAG_LIST :disc_super discr_any_receiver :named_name '"DISCR_LIST") ;;; the discriminant for pairs (definstance discr_pair class_discriminant :doc #{The $DISCR_PAIR is the discriminant of pairs, notably inside lists. See also $DISCR_LIST.}# :predef DISCR_PAIR :obj_num OBMAG_PAIR :disc_super discr_any_receiver :named_name '"DISCR_PAIR") ;;; the discriminant for multiples (definstance discr_multiple class_discriminant :doc #{The $DISCR_MULTIPLE is the discriminant of multiple values, i.e. tuples. See also $DISCR_FIELD_SEQUENCE and $DISCR_CLASS_SEQUENCE.}# :predef DISCR_MULTIPLE :obj_num OBMAG_MULTIPLE :disc_super discr_any_receiver :named_name '"DISCR_MULTIPLE") ;;; the discriminant for sequence of fields (definstance discr_field_sequence class_discriminant :doc #{The $DISCR_FIELD_SEQUENCE is the discriminant of field sequence tuple values, e.g. within classes. See also $DISCR_MULTIPLE and $CLASS_CLASS.}# :predef DISCR_FIELD_SEQUENCE :obj_num OBMAG_MULTIPLE :named_name '"DISCR_FIELD_SEQUENCE" :disc_super discr_multiple ) ;;; the discriminant for boxes (definstance discr_box class_discriminant :doc #{The $DISCR_BOX is the discriminant of box values, containing a single mutable value. See also $CLASS_CONTAINER.}# :predef DISCR_BOX :obj_num OBMAG_BOX :disc_super discr_any_receiver :named_name '"DISCR_BOX") ;;; the discriminant for trees (definstance discr_tree class_discriminant :doc #{The $DISCR_TREE is the discriminant of boxed GCC tree values. See also $CTYPE_TREE.}# :predef DISCR_TREE :obj_num OBMAG_TREE :disc_super discr_any_receiver :named_name '"DISCR_TREE") ;;; the discriminant for gimples (definstance discr_gimple class_discriminant :doc #{The $DISCR_GIMPLE is the discriminant of boxed GCC gimple values. See also $CTYPE_GIMPLE.}# :predef DISCR_GIMPLE :obj_num OBMAG_GIMPLE :disc_super discr_any_receiver :named_name '"DISCR_GIMPLE") ;;; the discriminant for gimple_seqs (definstance discr_gimple_seq class_discriminant :doc #{The $DISCR_GIMPLE_SEQ is the discriminant of boxed GCC gimple_seq values. See also $CTYPE_GIMPLE_SEQ.}# :predef DISCR_GIMPLE_SEQ :obj_num OBMAG_GIMPLESEQ :disc_super discr_any_receiver :named_name '"DISCR_GIMPLE_SEQ") ;;; the discriminant for edges (definstance discr_edge class_discriminant :doc #{The $DISCR_EDGE is the discriminant of boxed GCC edge values. See also $CTYPE_EDGE.}# :predef DISCR_EDGE :obj_num OBMAG_EDGE :disc_super discr_any_receiver :named_name '"DISCR_EDGE") (definstance discr_basic_block class_discriminant :doc #{The $DISCR_BASIC_BLOCK is the discriminant of boxed GCC basic_block values. See also $CTYPE_BASIC_BLOCK.}# :predef DISCR_BASIC_BLOCK :obj_num OBMAG_BASICBLOCK :disc_super discr_any_receiver :named_name '"DISCR_BASIC_BLOCK") ;;; the discriminant for maps of objects (definstance discr_map_objects class_discriminant :doc #{The $DISCR_MAP_OBJECTS is the discriminant of hash-map values associating MELT objects to non-nil value.}# :predef DISCR_MAP_OBJECTS :obj_num OBMAG_MAPOBJECTS :disc_super discr_any_receiver :named_name '"DISCR_MAP_OBJECTS") ;;; the discriminant for maps of strings (definstance discr_map_strings class_discriminant :doc #{The $DISCR_MAP_STRINGS is the discriminant of hash-map values associating raw strings to non-nil value. See also $CTYPE_CSTRING.}# :predef DISCR_MAP_STRINGS :obj_num OBMAG_MAPSTRINGS :disc_super discr_any_receiver :named_name '"DISCR_MAP_STRINGS") ;;; the discriminant for maps of trees (definstance discr_map_trees class_discriminant :doc #{The $DISCR_MAP_TREES is the discriminant of hash-map values associating raw GCC tree-s to non-nil value. See also $CTYPE_TREE.}# :predef DISCR_MAP_TREES :obj_num OBMAG_MAPTREES :disc_super discr_any_receiver :named_name '"DISCR_MAP_TREES") ;;; the discriminant for maps of gimples (definstance discr_map_gimples class_discriminant :doc #{The $DISCR_MAP_GIMPLES is the discriminant of hash-map values associating raw GCC gimple-s to non-nil value. See also $CTYPE_GIMPLE.}# :predef DISCR_MAP_GIMPLES :obj_num OBMAG_MAPGIMPLES :disc_super discr_any_receiver :named_name '"DISCR_MAP_GIMPLES") ;;; the discriminant for maps of gimple_seqs (definstance discr_map_gimple_seqs class_discriminant :doc #{The $DISCR_MAP_GIMPLE_SEQS is the discriminant of hash-map values associating raw GCC gimple_seq-s to non-nil value. See also $CTYPE_GIMPLE_SEQ.}# :predef DISCR_MAP_GIMPLE_SEQS :obj_num OBMAG_MAPGIMPLESEQS :disc_super discr_any_receiver :named_name '"DISCR_MAP_GIMPLE_SEQS") ;;; the discriminant for maps of edges (definstance discr_map_edges class_discriminant :doc #{The $DISCR_MAP_EDGES is the discriminant of hash-map values associating raw GCC edge-s to non-nil value. See also $CTYPE_EDGE.}# :predef DISCR_MAP_EDGES :obj_num OBMAG_MAPEDGES :disc_super discr_any_receiver :named_name '"DISCR_MAP_EDGES") ;;; the discriminant for maps of basic_blocks (definstance discr_map_basic_blocks class_discriminant :doc #{The $DISCR_MAP_BASIC_BLOCKS is the discriminant of hash-map values associating raw GCC basic_block-s to non-nil value. See also $CTYPE_BASIC_BLOCK.}# :predef DISCR_MAP_BASIC_BLOCKS :obj_num OBMAG_MAPBASICBLOCKS :disc_super discr_any_receiver :named_name '"DISCR_MAP_BASIC_BLOCKS") ;;; the discriminant for PPL constraint system (not predefined) (definstance discr_ppl_constraint_system class_discriminant :obj_num OBMAG_SPECPPL_CONSTRAINT_SYSTEM :doc #{The $DISCR_PPL_CONSTRAINT_SYSTEM is the discriminant of boxed PPL constraint systems.}# :disc_super discr_any_receiver :named_name '"DISCR_PPL_CONSTRAINT_SYSTEM" ) ;;; the discriminant for PPL polyhedron (definstance discr_ppl_polyhedron class_discriminant :obj_num OBMAG_SPECPPL_POLYHEDRON :doc #{The $DISCR_PPL_POLYHEDRON is the discriminant of boxed PPL polyhedra.}# :disc_super discr_any_receiver :named_name '"DISCR_PPL_POLYHEDRON" ) ;;; the discriminant for files [closed by the garbage collector] (not ;;; predefined) (definstance discr_file class_discriminant :obj_num OBMAG_SPEC_FILE :doc #{The $DISCR_FILE is the discriminant of boxed FILE*, which are fclose-d when the boxed value is inaccessible. See also $DISCR_RAWFILE.}# :disc_super discr_any_receiver :named_name '"DISCR_FILE" ) ;; the discrimiant for raw files [not closed implicitly] (not ;;; predefined) (definstance discr_rawfile class_discriminant :doc #{The $DISCR_RAWFILE is the discriminant of boxed FILE*, The MELT garbage collector dont fclose them. See also $DISCR_FILE.}# :obj_num OBMAG_SPEC_RAWFILE :disc_super discr_file :named_name '"DISCR_RAWFILE" ) ;;; the discriminant for sequence of classes (definstance discr_class_sequence class_discriminant :doc #{The $DISCR_CLASS_SEQUENCE is the discriminant of class sequence tuple values, e.g. inside classes. See also $CLASS_CLASS and $DISCR_MULTIPLE.}# :predef DISCR_CLASS_SEQUENCE :obj_num OBMAG_MULTIPLE :named_name '"DISCR_CLASS_SEQUENCE" :disc_super discr_multiple ) ;;; the discriminant for method dictionnary maps (definstance discr_method_map class_discriminant :doc #{The $DISCR_METHOD_MAP is the discriminant of method dictionnary maps, associating selector values to closure value. See also $CLASS_CLASS, $CLASS_SELECTOR, $DISCR_CLOSURE and $DISCR_MAP_OBJECTS.}# :predef DISCR_METHOD_MAP :obj_num OBMAG_MAPOBJECTS :disc_super discr_map_objects :named_name '"DISCR_METHOD_MAP") ;;; the discriminant for charcode integers (definstance discr_character_integer class_discriminant :doc #{The $DISCR_CHARACTER_INTEGER is the discriminant of 'character' boxed integer values. See also $DISCR_INTEGER.}# :predef DISCR_CHARACTER_INTEGER :obj_num OBMAG_INT :named_name '"DISCR_CHARACTER_INTEGER" :disc_super discr_integer ) ;;; the discriminant for mixedintegers (definstance discr_mixed_integer class_discriminant :doc #{The $DISCR_MIXED_INTEGER is the discriminant of mixed integer values, containing both a number and a value component.}# :predef DISCR_MIXED_INTEGER :obj_num OBMAG_MIXINT :disc_super discr_any_receiver :named_name '"DISCR_MIXED_INTEGER") ;;; the discriminant for mixedintegers (definstance discr_mixed_bigint class_discriminant :doc #{The $DISCR_MIXED_BIGINT is the discriminant of mixed bigint values, containing both a GMP number and a value component.}# :predef DISCR_MIXED_BIGINT :obj_num OBMAG_MIXBIGINT :disc_super discr_any_receiver :named_name '"DISCR_MIXED_BIGINT") ;;; the discriminant for mixed locations (definstance discr_mixed_location class_discriminant :doc #{The $DISCR_MIXED_LOCATION is the discriminant of mixed location values, containing both a GCC location and a value component.}# :predef DISCR_MIXED_LOCATION :obj_num OBMAG_MIXLOC :disc_super discr_any_receiver :named_name '"DISCR_MIXED_LOCATION") ;;; the discriminant for closures (definstance discr_closure class_discriminant :doc #{The $DISCR_CLOSURE is the discriminant of MELT function closures, i.e. functional values. See also $DISCR_ROUTINE.}# :predef DISCR_CLOSURE :obj_num OBMAG_CLOSURE :disc_super discr_any_receiver :named_name '"DISCR_CLOSURE") ;;; the discriminant for routines (definstance discr_routine class_discriminant :doc #{The $DISCR_ROUTINE is the discriminant of MELT routine values, which boxes the routine pointer and the constants inside MELT function closure values. See also $DISCR_CLOSURE.}# :predef DISCR_ROUTINE :obj_num OBMAG_ROUTINE :disc_super discr_any_receiver :named_name '"DISCR_ROUTINE") ;;; by having the install_ctype_descr called inside each ctype ;;; initialization, we are sure it is called once for each, because ;;; ctype-s are predefined (defun install_ctype_descr (ctyp :cstring descr) :doc #{Install a new ctype $CTYP with descriptive string $DESCR. Also add the ctype as symbol data in the keyword and the alternate keyword if provided.}# ;(debug_msg ctyp "install_ctype_descr") (assert_msg "check ctyp" (is_a ctyp class_ctype)) (if (unsafe_get_field :ctype_descr ctyp) (return)) (let ( (ckw (unsafe_get_field :ctype_keyword ctyp)) (altkw (unsafe_get_field :ctype_altkeyword ctyp)) (ds (make_stringconst discr_string descr)) ) (assert_msg "check ctype ckw" (is_a ckw class_keyword)) (unsafe_put_fields ckw :symb_data ctyp) (if (is_a altkw class_keyword) (put_fields altkw :symb_data ctyp)) ds )) ;;; every ctype should be predefined. normexp_defprimitive requires this ;;; while predef are somehow costly, we don't have that much many ctype-s ;;; and each of them nearly requires some code in melt-runtime.h ;;; which should be enhanced for any new ctype ;; the C type for values (definstance ctype_value class_ctype :doc #{The $CTYPE_VALUE is the c-type of any MELT value. See also $DISCR_ANY_RECEIVER, $CLASS_ROOT etc. Keyword is :value.}# :predef CTYPE_VALUE :named_name '"CTYPE_VALUE" :ctype_keyword ':value :ctype_cname '"melt_ptr_t" :ctype_parchar '"BPAR_PTR" :ctype_parstring '"BPARSTR_PTR" ;; value have to be passed specially, we need to pass the address of the pointer :ctype_argfield '"bp_aptr" :ctype_resfield '"bp_aptr" :ctype_marker '"gt_ggc_mx_melt_un" ) (install_ctype_descr ctype_value "any melt value pointer") ;; the C type for long (definstance ctype_long class_ctype :doc #{The $CTYPE_LONG is the c-type of raw long number stuff. See also $DISCR_INTEGER. Keyword is :long.}# :predef CTYPE_LONG :named_name '"CTYPE_LONG" :ctype_keyword ':long :ctype_cname '"long" :ctype_parchar '"BPAR_LONG" :ctype_parstring '"BPARSTR_LONG" :ctype_argfield '"bp_long" :ctype_resfield '"bp_longptr" ) (install_ctype_descr ctype_long "C long unboxed integer") ;; the C type for gcc trees (definstance ctype_tree class_ctype :doc #{The $CTYPE_TREE is the c-type of raw GCC tree stuff. See also $DISCR_TREE. Keyword is :tree.}# :predef CTYPE_TREE :named_name '"CTYPE_TREE" :ctype_keyword ':tree :ctype_cname '"tree" :ctype_parchar '"BPAR_TREE" :ctype_parstring '"BPARSTR_TREE" :ctype_argfield '"bp_tree" :ctype_resfield '"bp_treeptr" :ctype_marker '"gt_ggc_mx_tree_node" ) (install_ctype_descr ctype_tree "GCC tree pointer") ;; the C type for gcc gimples (definstance ctype_gimple class_ctype :doc #{The $CTYPE_GIMPLE is the c-type of raw GCC gimple stuff. See also $DISCR_GIMPLE. Keyword is :gimple.}# :predef CTYPE_GIMPLE :named_name '"CTYPE_GIMPLE" :ctype_keyword ':gimple :ctype_cname '"gimple" :ctype_parchar '"BPAR_GIMPLE" :ctype_parstring '"BPARSTR_GIMPLE" :ctype_argfield '"bp_gimple" :ctype_resfield '"bp_gimpleptr" :ctype_marker '"gt_ggc_mx_gimple_statement_d" ) (install_ctype_descr ctype_gimple "GCC gimple pointer") ;; the C type for gcc gimple_seqs (definstance ctype_gimple_seq class_ctype :doc #{The $CTYPE_GIMPLE_SEQ is the c-type of raw GCC gimple_seq stuff. See also $DISCR_GIMPLE_SEQ. Keyword is :gimple_seq.}# :predef CTYPE_GIMPLE_SEQ :named_name '"CTYPE_GIMPLE_SEQ" :ctype_keyword ':gimple_seq ; :ctype_altkeyword ':gimpleseq :ctype_cname '"gimple_seq" :ctype_parchar '"BPAR_GIMPLESEQ" :ctype_parstring '"BPARSTR_GIMPLESEQ" :ctype_argfield '"bp_gimpleseq" :ctype_resfield '"bp_gimpleseqptr" :ctype_marker '"gt_ggc_mx_gimple_seq_d" ) (install_ctype_descr ctype_gimple_seq "GCC gimpleseq pointer") ;; the C type for gcc basic_blocks (definstance ctype_basic_block class_ctype :doc #{The $CTYPE_BASIC_BLOCK is the c-type of raw GCC basic_block stuff. See also $DISCR_BASIC_BLOCK. Keyword is :basic_block.}# :predef CTYPE_BASIC_BLOCK :named_name '"CTYPE_BASIC_BLOCK" :ctype_keyword ':basic_block ; :ctype_altkeyword ':basicblock :ctype_cname '"basic_block" :ctype_parchar '"BPAR_BB" :ctype_parstring '"BPARSTR_BB" :ctype_argfield '"bp_bb" :ctype_resfield '"bp_bbptr" :ctype_marker '"gt_ggc_mx_basic_block_def" ) (install_ctype_descr ctype_basic_block "GCC basic_block") ;; the C type for gcc edges (definstance ctype_edge class_ctype :doc #{The $CTYPE_EDGE is the c-type of raw GCC edge stuff. See also $DISCR_EDGE. Keyword is :edge.}# :predef CTYPE_EDGE :named_name '"CTYPE_EDGE" :ctype_keyword ':edge :ctype_cname '"edge" :ctype_parchar '"BPAR_EDGE" :ctype_parstring '"BPARSTR_EDGE" :ctype_argfield '"bp_edge" :ctype_resfield '"bp_edgeptr" :ctype_marker '"gt_ggc_mx_edge_def" ) (install_ctype_descr ctype_edge "GCC edge") ;;; the ctype for PPL coefficients (definstance ctype_ppl_coefficient class_ctype :predef CTYPE_PPL_COEFFICIENT :doc #{The $CTYPE_PPL_COEFFICIENT is the c-type of raw PPL coefficient stuff. See also $DISCR_PPL_POLYHEDRON. Keyword is :ppl_coefficient.}# :named_name '"CTYPE_PPL_COEFFICIENT" :ctype_keyword ':ppl_coefficient :ctype_cname '"ppl_Coefficient_t" :ctype_parchar '"BPAR_PPL_COEFFICIENT" :ctype_parstring '"BPARSTR_PPL_COEFFICIENT" :ctype_argfield '"bp_ppl_coefficient" :ctype_resfield '"bp_ppl_coefficientptr" ) (install_ctype_descr ctype_ppl_coefficient "PPL coefficient") ;;;; PPL linear expressions (definstance ctype_ppl_linear_expression class_ctype :predef CTYPE_PPL_LINEAR_EXPRESSION :doc #{The $CTYPE_PPL_LINEAR_EXPRESSION is the c-type of raw PPL linear expression stuff. Keyword is :ppl_linear_expression.}# :named_name '"CTYPE_PPL_LINEAR_EXPRESSION" :ctype_keyword ':ppl_linear_expression :ctype_cname '"ppl_Linear_Expression_t" :ctype_parchar '"BPAR_PPL_LINEAR_EXPRESSION" :ctype_parstring '"BPARSTR_PPL_LINEAR_EXPRESSION" :ctype_argfield '"bp_ppl_linear_expression" :ctype_resfield '"bp_ppl_linear_expressionptr" ) (install_ctype_descr ctype_ppl_linear_expression "PPL linear expression") ;;; the ctype for PPL constraints (definstance ctype_ppl_constraint class_ctype :predef CTYPE_PPL_CONSTRAINT :doc #{The $CTYPE_PPL_CONSTRAINT is the c-type of raw PPL constraint stuff. Keyword is :ppl_constraint.}# :named_name '"CTYPE_PPL_CONSTRAINT" :ctype_keyword ':ppl_constraint :ctype_cname '"ppl_Constraint_t" :ctype_parchar '"BPAR_PPL_CONSTRAINT" :ctype_parstring '"BPARSTR_PPL_CONSTRAINT" :ctype_argfield '"bp_ppl_constraint" :ctype_resfield '"bp_ppl_constraintptr" ) (install_ctype_descr ctype_ppl_constraint "PPL constraint") ;;; the ctype for PPL constraint_systems (definstance ctype_ppl_constraint_system class_ctype :predef CTYPE_PPL_CONSTRAINT_SYSTEM :doc #{The $CTYPE_PPL_CONSTRAINT_SYSTEM is the c-type of raw PPL constraint system stuff. Keyword is :ppl_constraint_system.}# :named_name '"CTYPE_PPL_CONSTRAINT_SYSTEM" :ctype_keyword ':ppl_constraint_system :ctype_cname '"ppl_Constraint_System_t" :ctype_parchar '"BPAR_PPL_CONSTRAINT_SYSTEM" :ctype_parstring '"BPARSTR_PPL_CONSTRAINT_SYSTEM" :ctype_argfield '"bp_ppl_constraint_system" :ctype_resfield '"bp_ppl_constraint_systemptr" ) (install_ctype_descr ctype_ppl_constraint_system "PPL constraint_system") ;;; the ctype for PPL polyhedra (=polyhedrons) (definstance ctype_ppl_polyhedron class_ctype :predef CTYPE_PPL_POLYHEDRON :named_name '"CTYPE_PPL_POLYHEDRON" :doc #{The $CTYPE_PPL_POLYHEDRON is the c-type of raw PPL polyhedron stuff. Keyword is :ppl_polyhedron.}# :ctype_keyword ':ppl_polyhedron :ctype_cname '"ppl_Polyhedron_t" :ctype_parchar '"BPAR_PPL_POLYHEDRON" :ctype_parstring '"BPARSTR_PPL_POLYHEDRON" :ctype_argfield '"bp_ppl_polyhedron" :ctype_resfield '"bp_ppl_polyhedronptr" ) (install_ctype_descr ctype_ppl_polyhedron "PPL polyhedron") ;;;;;;;;;;;;;;;; ;; the C type for void (definstance ctype_void class_ctype :predef CTYPE_VOID :doc #{The $CTYPE_VOID is the c-type of void stuff, used for expressions, e.g. primitive invocations, with only a side effect and no results. Keyword is :void but cannot be used to type an argument or a result.}# :named_name '"CTYPE_VOID" :ctype_keyword ':void :ctype_cname '"void" ;; void is never passed as argument or as extra result ) (install_ctype_descr ctype_void "void type for side-effecting primitives without results") ;; the C type for constant C strings (definstance ctype_cstring class_ctype :doc #{The $CTYPE_CSTRING is the c-type of raw C string [const char*] stuff. See also DISCR_STRING. Keyword is :cstring.}# :predef CTYPE_CSTRING :named_name '"CTYPE_CSTRING" :ctype_keyword ':cstring :ctype_cname (stringconst2val discr_name_string "const char*") :ctype_parchar '"BPAR_CSTRING" :ctype_parstring '"BPARSTR_CSTRING" :ctype_argfield '"bp_cstring" ) (install_ctype_descr ctype_cstring "C constant strings (statically allocated outside of any heap)") ;; function to add a new symbol [called by meltgc_named_symbol in the runtime] (defun add_new_symbol_token (syda str) (assert_msg "check syda" (is_a syda class_system_data)) (let ( (sy (instance class_symbol :named_name str)) (sydict (unsafe_get_field :sysdata_symboldict syda)) ) (mapstring_putstr sydict str sy) sy)) ;; function to add a new keyword [called by meltgc_named_keyword in the runtime] (defun add_new_keyword_token (syda str) (assert_msg "check syda" (is_a syda class_system_data)) (let ( (kw (instance class_keyword :named_name str)) (kwdict (unsafe_get_field :sysdata_keywdict syda)) ) (mapstring_putstr kwdict str kw) kw)) ;; function to intern a symbol (or return the previous one) (defun intern_symbol (inidat symb) (assert_msg "check inidat" (is_a inidat class_system_data)) (assert_msg "check sym" (is_a symb class_symbol)) (let ( (syname (unsafe_get_field :named_name symb)) (sydict (unsafe_get_field :sysdata_symboldict inidat)) (oldsy (mapstring_getstr sydict syname)) ) (if oldsy oldsy (progn (mapstring_putstr sydict syname symb) ; (messageval_dbg "warm interning symbol" symb) symb)) )) ;; function to intern a keyword (or return the previous one) (defun intern_keyword (inidat keyw) (assert_msg "check inidat" (is_a inidat class_system_data)) (assert_msg "check keyw" (is_a keyw class_keyword)) (let ( (kwname (unsafe_get_field :named_name keyw)) (kwdict (unsafe_get_field :sysdata_keywdict inidat)) (oldkw (mapstring_getstr kwdict kwname)) ) (if oldkw oldkw (progn (mapstring_putstr kwdict kwname keyw) keyw)) )) ;;; container of a mapstring for cloning symbol, maping symbol names to boxed integer (definstance container_clonemapstring class_container :container_value (make_mapstring discr_map_strings 200) ) (defun clone_symbol (symb) :doc #{Function to clone a given symbol or string $SYMB, producing a new instance of class_cloned_symbol}# (let ( (mapstr (unsafe_get_field :container_value container_clonemapstring)) (synam (cond ( (is_string symb) symb) ( (is_a symb class_named) (unsafe_get_field :named_name symb)) (:else (let ( (discrinam (get_field :named_name (discrim symb))) ) (warningmsg_strv "clone_symbol got invalid argument of discriminant" discrinam) (shortbacktrace_dbg "clone_symbol error.." 15) (debug_msg symb "clone_symbol bad symb") (messageval_dbg "clone_symbol symn not named or string" symb) (let ( (:cstring namcstr (the_null_cstring) ) ) (code_chunk clonamstr #{ static char clonambuf[100]; const char *s = melt_string_str ($discrinam); if (s) s = strchr(s, '_'); if (!s) s = "_What"; memset (clonambuf, 0, sizeof(clonambuf)); snprintf (clonambuf, sizeof(clonambuf)-1, "Cloned_Melt%s", s); $namcstr = clonambuf; }# ) (make_stringconst discr_string namcstr) ))) )) (boxi (mapstring_getstr mapstr synam)) ) (assert_msg "check synam" (is_string synam)) (if (not (is_integerbox boxi)) (progn (setq boxi (make_integerbox discr_integer 0)) (mapstring_putstr mapstr synam boxi))) (let ( (:long i (get_int boxi)) ) (setq i (+i i 1)) (put_int boxi i) (instance class_cloned_symbol :named_name synam :csym_urank (make_integerbox discr_integer i))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; initial fresh environment container maker - inside INITIAL_SYSTEM_DATA (defun initfresh_contenvmaker (prevenv :cstring modnam) (if (need_dbg 0) (shortbacktrace_dbg "initfresh_contenvmaker" 15)) (let ( (descr (if modnam (make_stringconst discr_string modnam))) (newenv (fresh_env prevenv descr)) (newcont (instance class_container :container_value newenv)) ) ;(debug_msg newcont "initfresh_contenvmaker result newcont") (return newcont) )) ;; initial value exporter - inside INITIAL_SYSTEM_DATA (defun initvalue_exporter (sym val contenv) ;;(debug_msg sym "initvalue_exporter sym") ;;(debug_msg val "initvalue_exporter val") ;;(debug_msg contenv "initvalue_exporter contenv") ;;(if (need_dbg 0) ;; (shortbacktrace_dbg "initvalue_exporter" 15)) (let ( (parenv (parent_module_environment)) ) (if (null contenv) (progn (if parenv (warningmsg_strv "exporting value too early with null environment container" (unsafe_get_field :named_name sym))) (return) )) (assert_msg "check sym" (is_a sym class_symbol)) (assert_msg "check contenv" (is_a contenv class_container)) (let ( (env (unsafe_get_field :container_value contenv)) ) (if (and (null env) parenv) (progn (informsg_strv "exporting value too early with null environment" (unsafe_get_field :named_name sym)) (return) )) (assert_msg "check good env" (is_a env class_environment)) (let ( (prevbind (if parenv (find_env parenv sym))) (valbind (instance class_value_binding :binder sym :vbind_value val )) (symnam (unsafe_get_field :named_name sym)) ) (cond ( (null prevbind) () ) ( (and (is_a prevbind class_selector_binding) (is_a val class_selector)) (warningmsg_strv "not exporting previous bound selector" symnam) (return)) ( (and (is_a prevbind class_instance_binding) (is_object val)) (warningmsg_strv "not exporting previous bound instance" symnam) (return)) ( (and (is_a prevbind class_primitive_binding) (is_a val class_primitive)) (warningmsg_strv "not exporting previous bound primitive" symnam) (return)) ( (and (is_a prevbind class_function_binding) (is_closure val)) (warningmsg_strv "not exporting previous bound function" symnam) (return)) ( (and (is_a prevbind class_class_binding) (is_a val class_class)) (warningmsg_strv "not exporting previous bound class" symnam) (return)) ( (and (is_a prevbind class_field_binding) (is_a val class_class)) (warningmsg_strv "not exporting previous bound field" symnam) (return) ) ( (and (is_a prevbind class_instance_binding) (is_object val)) (warningmsg_strv "not exporting previous bound instance" symnam) (return) ) ( (is_a prevbind class_value_binding) (let ( (preval (unsafe_get_field :vbind_value prevbind)) (prevdiscr (discrim preval)) (curdiscr (discrim val)) ) (if (== prevdiscr curdiscr) (progn (warningmsg_strv "not exporting previous bound homogenous value" symnam) (warningmsg_strv "common value discrim" (unsafe_get_field :named_name prevdiscr)) (return))) )) ) (assert_msg "check valbind" (is_a valbind class_any_binding)) (put_env env valbind) (return) )))) ;; initial value importer - inside INITIAL_SYSTEM_DATA (defun initvalue_importer (sym parenv :cstring strnam modnam) (code_chunk ensuremodnam #{ /* $ensuremodnam */ if (!$modnam) $modnam = "???"; }#) (if (is_not_a sym class_symbol) (progn (debug_msg sym "initvalue_importer bad symb") (code_chunk errfailimport #{ /* $errfailimport */ if ($strnam) error ("MELT [%s]: imported symbol %s not found", $modnam, $strnam); else error ("MELT [%s]: importing non symbol", $modnam); }#) (return) )) (assert_msg "check sym" (is_a sym class_symbol)) (assert_msg "check parenv" (is_a parenv class_environment)) (let ( (valbind (find_env parenv sym)) ) (if (is_not_a valbind class_value_binding) (let ( (symnam (get_field :named_name sym)) (bindiscr (discrim valbind)) (bindiscrnam (get_field :named_name bindiscr)) ) (assert_msg "check symnam" (is_string symnam)) (code_chunk errbadimport #{ /* $errbadimport */ const char* $errbadimport#_str = melt_string_str ((melt_ptr_t)$symnam); error ("MELT [%s]: imported symbol %s has unexpected binding of %s", $modnam, $errbadimport#_str?$errbadimport#_str:$strnam, melt_string_str ((melt_ptr_t)$bindiscrnam)); }#) (return) )) (assert_msg "check valbind" (is_a valbind class_value_binding)) (return (unsafe_get_field :vbind_value valbind)) )) ;; initial macro exporter - inside INITIAL_SYSTEM_DATA (defun initmacro_exporter (sym val contenv) (assert_msg "check sym" (is_a sym class_symbol)) (if (null contenv) (progn (if (parent_module_environment) (warningmsg_strv "exporting macro too early with null environment container" (unsafe_get_field :named_name sym))) (return) )) (assert_msg "check contenv" (is_a contenv class_container)) (let ( (env (unsafe_get_field :container_value contenv)) ) ;(if (need_dbg 0) (shortbacktrace_dbg "initmacro_exporter" 15)) (if (null env) (progn (informsg_strv "exporting macro too early with null environment" (unsafe_get_field :named_name sym)) (return) )) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check val is closure" (is_closure val)) (let ( (macbind (instance class_macro_binding :binder sym :mbind_expanser val)) ) (put_env env macbind) (debug_msg macbind "initmacro_exporter macbind") (return) ))) ;; initial patmacro exporter - inside INITIAL_SYSTEM_DATA (defun initpatmacro_exporter (sym macval patval contenv) (debug_msg sym "initpatmacro_exporter sym") (assert_msg "check sym" (is_a sym class_symbol)) (if (null contenv) (progn ;;(if (parent_module_environment) ;; (warningmsg_strv "exporting patmacro too early with null environment container" ;; (unsafe_get_field :named_name sym))) (return) )) (assert_msg "check contenv" (is_a contenv class_container)) (let ( (env (unsafe_get_field :container_value contenv)) ) (if (null env) (progn (informsg_strv "exporting patmacro too early with null environment" (unsafe_get_field :named_name sym)) (return) )) (assert_msg "check env" (is_a env class_environment)) (assert_msg "check macval is closure" (is_closure macval)) (assert_msg "check patval is closure" (is_closure patval)) (let ( (macbind (instance class_patmacro_binding :binder sym :mbind_expanser macval :patbind_expanser patval)) ) (put_env env macbind) (debug_msg macbind "initpatmacro_exporter macbind") (return) ))) ;; internal non-exported class for delayed queues. (defclass class_delayed_queue :super class_named :fields (delqu_first delqu_last delqu_data )) ;; private final queue (definstance final_delayed_queue class_delayed_queue :named_name '"final_delayed_queue" :delqu_first (make_list discr_list) :delqu_last (make_list discr_list) ) ;;;;;; the queue for full exit (defun init_exitfinalizer () (debug_msg final_delayed_queue "init_exitfinalizer final_delayed_queue at start") (let ( (firstlist (unsafe_get_field :delqu_first final_delayed_queue)) (lastlist (unsafe_get_field :delqu_last final_delayed_queue)) (revlastlist (make_list discr_list)) (rescont (instance class_container)) ) ;;; call the first routines in natural order (list_every firstlist (lambda (firstproc) (let ( (prevres (unsafe_get_field :container_value rescont)) (nextres (firstproc prevres final_delayed_queue)) ) (unsafe_put_fields rescont :container_value nextres) ))) ;;; reverse the last list (list_every lastlist (lambda (lastproc) (if (is_closure lastproc) (list_prepend revlastlist lastproc)))) ;;; call the last routines in reverse order (list_every revlastlist (lambda (lastproc) (let ( (prevres (unsafe_get_field :container_value rescont)) (nextres (lastproc prevres final_delayed_queue)) ) (unsafe_put_fields rescont :container_value nextres) ))) (debug_msg rescont "init_exitfinalizer ending rescont") )) (defun at_exit_first (fun) :doc #{Use $AT_EXIT_FIRST to register a function to be run at MELT exit, in first place.}# (let ( (firstlist (unsafe_get_field :delqu_first final_delayed_queue)) ) (if (is_closure fun) (list_append firstlist fun))) ) (defun at_exit_last (fun) :doc #{Use $AT_EXIT_LAST to register a function to be run at MELT exit, in last place.}# (let ( (lastlist (unsafe_get_field :delqu_last final_delayed_queue)) ) (if (is_closure fun) (list_append lastlist fun))) ) ;;;;;; private queue for start of compilation unit (definstance start_unit_delayed_queue class_delayed_queue :named_name '"start_unit_delayed_queue" :delqu_first (make_list discr_list) :delqu_last (make_list discr_list) ) (defun init_unitstarter () (debug_msg start_unit_delayed_queue "init_unitstarter start_unit_delayed_queue at start") (let ( (firstlist (unsafe_get_field :delqu_first start_unit_delayed_queue)) (lastlist (unsafe_get_field :delqu_last start_unit_delayed_queue)) (revlastlist (make_list discr_list)) (rescont (instance class_container)) ) ;;; call the first routines in natural order (list_every firstlist (lambda (firstproc) (let ( (prevres (unsafe_get_field :container_value rescont)) (nextres (firstproc prevres start_unit_delayed_queue)) ) (unsafe_put_fields rescont :container_value nextres) ))) ;;; reverse the last list (list_every lastlist (lambda (lastproc) (if (is_closure lastproc) (list_prepend revlastlist lastproc)))) ;;; call the last routines in reverse order (list_every revlastlist (lambda (lastproc) (let ( (prevres (unsafe_get_field :container_value rescont)) (nextres (lastproc prevres start_unit_delayed_queue)) ) (unsafe_put_fields rescont :container_value nextres) ))) (debug_msg rescont "init_unitstarter ending rescont") )) (defun at_start_unit_first (fun) :doc #{Use $AT_START_UNIT_FIRST to register a function to be run at start of translation unit, in first place.}# (let ( (firstlist (unsafe_get_field :delqu_first start_unit_delayed_queue)) ) (if (is_closure fun) (list_append firstlist fun))) ) (defun at_start_unit_last (fun) :doc #{Use $AT_START_UNIT_LAST to register a function to be run at start of translation unit, in first place.}# (let ( (lastlist (unsafe_get_field :delqu_last start_unit_delayed_queue)) ) (if (is_closure fun) (list_append lastlist fun))) ) ;;;; the private queue for compilation unit finish (definstance finish_unit_delayed_queue class_delayed_queue :named_name '"finish_unit_delayed_queue" :delqu_first (make_list discr_list) :delqu_last (make_list discr_list) ) (defun init_unitfinisher () (debug_msg finish_unit_delayed_queue "init_unitfinisher finish_unit_delayed_queue at start") (let ( (firstlist (unsafe_get_field :delqu_first finish_unit_delayed_queue)) (lastlist (unsafe_get_field :delqu_last finish_unit_delayed_queue)) (revlastlist (make_list discr_list)) (rescont (instance class_container)) ) ;;; call the first routines in natural order (list_every firstlist (lambda (firstproc) (let ( (prevres (unsafe_get_field :container_value rescont)) (nextres (firstproc prevres finish_unit_delayed_queue)) ) (unsafe_put_fields rescont :container_value nextres) ))) ;;; reverse the last list (list_every lastlist (lambda (lastproc) (if (is_closure lastproc) (list_prepend revlastlist lastproc)))) ;;; call the last routines in reverse order (list_every revlastlist (lambda (lastproc) (let ( (prevres (unsafe_get_field :container_value rescont)) (nextres (lastproc prevres finish_unit_delayed_queue)) ) (unsafe_put_fields rescont :container_value nextres) ))) (debug_msg rescont "init_unitfinisher ending rescont") )) (defun at_finish_unit_first (fun) :doc #{Use $AT_FINISH_UNIT_FIRST to register a function to be run at end of compilation unit in first place}# (let ( (firstlist (unsafe_get_field :delqu_first finish_unit_delayed_queue)) ) (if (is_closure fun) (list_append firstlist fun))) ) (defun at_finish_unit_last (fun) :doc #{Use $AT_FINISH_UNIT_LAST to register a function to be run at end of compilation unit in last place}# (let ( (lastlist (unsafe_get_field :delqu_last finish_unit_delayed_queue)) ) (if (is_closure fun) (list_append lastlist fun))) ) ;;;;;;;;;;;;;;;;;;;;;;;; debug message function ;; this is a rarely used function (defun display_debug_message (val :cstring msgstr :long count) :doc #{Display in a debug-style the value $VAL with message raw string $MSGSTR and counter $COUNT. Rarely useful.}# (let ( (:long dbgcounter 0) (sbuf (make_strbuf discr_strbuf)) (occmap (make_mapobject discr_map_objects 50)) (boxedmaxdepth (make_integerbox discr_integer 14)) (dbgi (instance class_debug_information :dbgi_out sbuf :dbgi_occmap occmap :dbgi_maxdepth boxedmaxdepth)) ) (code_chunk setdbgcounter #{$dbgcounter= ++melt_dbgcounter}#) (outnum_err "!*!#" dbgcounter "/") (outnum_err "" (-i (the_framedepth) 1) ":") (outcstring_err msgstr) (if (>i count 0) (outnum_err " !" count ": ")) (dbg_output val dbgi 0) (outstrbuf_err sbuf) (outnewline_err) )) ;;;; ;; this function is inside INITIAL_SYSTEM_DATA and is internally used by the debug_msg macro (defun debugmsg (val :cstring msgstr :long count) (if (need_dbg 0) (let ( (:long dbgcounter 0) (sbuf (make_strbuf discr_strbuf)) (occmap (make_mapobject discr_map_objects 53)) (boxedmaxdepth (make_integerbox discr_integer 10)) ;;;; @@@ DEBUGDEPTH (dbgi (instance class_debug_information :dbgi_out sbuf :dbgi_occmap occmap :dbgi_maxdepth boxedmaxdepth)) ) (code_chunk setdbgcounter #{$dbgcounter= ++melt_dbgcounter}#) (outnum_dbg "!!!***###" dbgcounter "/") (outnum_dbg "" (-i (the_framedepth) 1) ":") (outcstring_dbg msgstr) (if (>i count 0) (outnum_dbg " !" count ": ")) (dbg_out val dbgi 0) (outstrbuf_dbg sbuf) (outnewline_dbg) ))) ;;;;;;;;;;;;;;;;;;;; initial system data (definstance initial_system_data class_system_data :doc #{The $INITIAL_SYSTEM_DATA is the unique instance of $CLASS_SYSTEM_DATA. Only for gurus. It normally should not be accessed or updated but is intenally useful to many MELT mechanisms.}# :predef INITIAL_SYSTEM_DATA :named_name '"INITIAL_SYSTEM_DATA" :sysdata_mode_dict (make_mapstring discr_map_strings 40) ;stringmap for modes :sysdata_cont_fresh_env initfresh_contenvmaker ;fresh environment maker in module :sysdata_value_exporter initvalue_exporter ;value exporter in module :sysdata_macro_exporter initmacro_exporter ;macro exporter in module :sysdata_symboldict (make_mapstring discr_map_strings 600) ;stringmap for symbols :sysdata_keywdict (make_mapstring discr_map_strings 100) ;stringmap for keywords :sysdata_addsymbol add_new_symbol_token ;closure to add a symbol of given name :sysdata_addkeyw add_new_keyword_token ;closure to add a keyword of given name :sysdata_internsymbol intern_symbol ;closure to intern a symbol :sysdata_internkeyw intern_keyword ;closure to intern a keyword :sysdata_value_importer initvalue_importer :sysdata_pass_dict (make_mapstring discr_map_strings 100) ;stringmap for gcc passes :sysdata_exit_finalizer init_exitfinalizer :sysdata_patmacro_exporter initpatmacro_exporter ; patmacro exporter in module :sysdata_debugmsg debugmsg :sysdata_stdout () ;initialized later :sysdata_stderr () ;initialized later :sysdata_dumpfile () ;initialized late :sysdata_unit_starter init_unitstarter :sysdata_unit_finisher init_unitfinisher ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;; general purpose utility functions ;;; iterate fully in map of objects (defun mapobject_every (map f) :doc #{For a given hash-map of objects $MAP and a function $F, apply $F to every attribute object and value in the map. Returns nil.}# (if (is_mapobject map) (if (is_closure f) (foreach_in_mapobject (map) (curat curval) (f curat curval)) ))) ;;; iterate & test over a map of objects - if the called f returns nil ;;; (with perhaps a secondary value result) the iteration is stopped ;;; and returns the "failing" attr, value, & f's secundary result (defun mapobject_iterate_test (map f) :doc #{With a given object hash-map $MAP and function $F which returns a boolean [=nil or not] test value and perhaps a secundary other value, iterate on the map and apply $F to every attribute and value in the $MAP. If $F returns a nil primary result, stop the iteration, and return the failed attribute, associated value, and an eventual other secundary results value returned by $F.}# (if (is_mapobject map) (if (is_closure f) (foreach_in_mapobject (map) (curat curval) (multicall (test other) (f curat curval) (if (null test) (return curat curval other))))))) ;;; iterate fully in a map of strings (defun mapstring_every (map f) :doc #{For a given hash-map of strings $MAP and a function $F, apply $F to every attribute object and [perhaps allocated] string value. Returns nil.}# (if (is_mapstring map) (if (is_closure f) (foreach_in_mapstring (map) (curat curval) (f curat curval))))) ;;; iterate & test over a map of strings - if the called f returns nil the ;;; iteration is stopped (defun mapstring_iterate_test (map f) :doc #{For a given hash-map of strings $MAP and a function $F, apply $F to every attribute object and string value. If it returns a null value, with an other secundary value, gives the failing attribute, its value, and the other.}# (if (is_mapstring map) (if (is_closure f) (foreach_in_mapstring (map) (curat curval) (multicall (test other) (f curat curval) (if (null test) (return curat curval other) )))))) ;;;;;;;;;;;;;;;; ;;; citerator on lists (defciterator foreach_in_list (lis) ;start formals eachlist ;state (curpair curcomp) ;local formals :doc #{The $FOREACH_IN_LIST iterator goes within a list, given by the start formal $LIS. Local formals are $CURPAIR, bound to the current pair, and $CURCOMP, bound to the current component within the list.}# #{/* start $eachlist */ for ($curpair = melt_list_first($lis); melt_magic_discr($curpair) == OBMAG_PAIR; $curpair = melt_pair_tail($curpair)) { $curcomp = melt_pair_head($curpair); }# #{ } /* end $eachlist */}# ) ;;; full iterator on a list (defun list_every (lis f) :doc #{Given a list $LIS and a function $F, apply $F to every element of the list. Return nil.}# (if (is_list lis) (if (is_closure f) (foreach_in_list (lis) (curpair curcomp) (f curcomp) )))) ;;; iterator on a list, if the called f returns nil the iteration is stopped (defun list_iterate_test (lis f) :doc #{Given a list $LIS and a function $F, apply $F to every element and its pair in the list. If it returns nil with an other secondary value, return the element and the other.}# (if (is_list lis) (if (is_closure f) (foreach_in_list (lis) (curpair curcomp) (multicall (test other) (f curcomp curpair) (if (null test) (return curcomp other)) ))))) ;; add to a destination list a source list (defun list_append2list (dlist slist) :doc #{Add to the destination list $DLIST the source list $SLIST: add every element of the source list at end of the destination. Return the $DLIST.}# (if (not (is_list slist)) (return dlist)) (if (not (is_list dlist)) (setq dlist (make_list discr_list))) (foreach_in_list (slist) (curpair curcomp) (list_append dlist curcomp)) (return dlist)) ;;; map on a list (list_map lis f) where lis is (e1 ... en) is ((f e1) .... (f en)) (defun list_map (lis f) (if (is_list lis) (if (is_closure f) (let ( (reslis (make_list discr_list)) (curpair (list_first lis)) ) (forever lisloop (if (not (is_pair curpair)) (exit lisloop reslis)) (let ( (curelem (pair_head curpair)) ) (list_append reslis (f curelem))) (setq curpair (pair_tail curpair))) )))) ;; find in a list LIS an element E verifying F E X or E == X if F is null (defun list_find (lis x f) (if (is_list lis) (let ( (curpair (list_first lis)) ) (if (is_closure f) (forever lisloop (if (not (is_pair curpair)) (exit lisloop)) (let ( (curelem (pair_head curpair)) (t (f curelem x)) ) (if t (return t)) (setq curpair (pair_tail curpair))) ) (forever memloop (if (not (is_pair curpair)) (exit memloop)) (let ( (curelem (pair_head curpair)) ) (if (== curelem x) (return curelem)) (setq curpair (pair_tail curpair))) ) ) ))) ;;; translate a list to a multiple - with each element transformed by a function f (default the identity) (defun list_to_multiple (lis disc f) (if (null disc) (setq disc discr_multiple)) (if (is_list lis) (let ( (:long ln (list_length lis)) (tup (make_multiple disc ln)) (ixb (make_integerbox discr_integer 0)) (curpair (list_first lis)) ) (list_every lis (lambda (c) (let ( (:long ix (get_int ixb)) (tc (if (is_closure f) (f c) c)) ) (put_int ixb (+i ix 1)) (multiple_put_nth tup ix tc)) )) tup ))) ;;; translate a pairlist to a tuple - with each element transformed by a function f (default the identity) (defun pairlist_to_multiple (pair disc f) :doc #{Make a multiple from a list of pairs: given a pair list starting with $PAIR and a multiple discriminant $DISC and an optional function $F [by default the identity], return a multiple of discriminant $DISC made of the result of applying $F to every head of pairs.}# (if (null disc) (setq disc discr_multiple)) (let ( (:long ln 0) ) (let ( (curpair pair) ) (forever loopln (if (not (is_pair curpair)) (exit loopln)) (setq ln (+i ln 1)) (setq curpair (pair_tail curpair)))) (let ( (tup (make_multiple disc ln)) (:long ix 0) (curpair pair) ) (forever loopfi (if (not (is_pair curpair)) (exit loopfi)) (let ( (c (pair_head curpair)) (tc (if (is_closure f) (f c) c)) ) (multiple_put_nth tup ix tc) (setq ix (+i ix 1)) (setq curpair (pair_tail curpair)))) (return tup) ))) ;;;;;;;;;;;;;;;; ;; citerator on tuple (defciterator foreach_in_multiple (tup) ;start formal eachtup ;state (comp :long ix) ;local formals :doc #{Iterate in the given tuple $TUP for each component $COMP at index $IX}# #{ /* start $eachtup: */ long $eachtup#_ln = melt_multiple_length((melt_ptr_t)$tup); for ($ix = 0; ($ix >= 0) && ($ix < $eachtup#_ln); $ix++) { $comp = melt_multiple_nth((melt_ptr_t)($tup), $ix); }# #{ if ($ix<0) break; } /* end $eachtup */ }# ) (defciterator foreach_in_multiple_backward (tup) ;start formal eachtupback ;state (comp :long ix) ;local formals :doc #{Iterate backwards from last to first in the given tuple $TUP for each component $COMP at index $IX}# #{ /* start $eachtupback: */ long $eachtupback#_ln = melt_multiple_length((melt_ptr_t)$tup); long $eachtupback#_ix = 0; for ($eachtupback#_ix = $eachtupback#_ln - 1; $eachtupback#_ix >= 0; $eachtupback#_ix--) { $comp = melt_multiple_nth((melt_ptr_t)($tup), $eachtupback#_ix); $ix = $eachtupback#_ix;}# #{ } /* end $eachtupback */ }# ) ;;; full iterator on tuple - ;;; the function is called with the component and its index (defun multiple_every (tup f) :doc #{Apply to every component of tuple $TUP and its index the given function $F. Return nil.}# (if (is_multiple tup) (if (is_closure f) (foreach_in_multiple (tup) (comp :long ix) (f comp ix))))) ;; full iterator backward (defun multiple_backward_every (tup f) :doc #{Apply to every component (from last to first) of tuple $TUP backwards, and its index the given function $F. Return nil.}# (if (is_multiple tup) (if (is_closure f) (foreach_in_multiple_backward (tup) (comp :long ix) (f comp ix))))) ;; iterator on two tuples (defun multiple_every_both (tup1 tup2 f) :doc #{Given two tuples $TUP1 and $TUP2, apply function $F to every component of $TUP1 with component of $TUP2 and index. Stop when either end is reached. Return nil.}# (if (is_multiple tup1) (if (is_multiple tup2) (if (is_closure f) (let ( (:long ln1 (multiple_length tup1)) (:long ln2 (multiple_length tup2)) (:long ix 0) ) (forever tuploop (if (>=i ix ln1) (exit tuploop)) (if (>=i ix ln2) (exit tuploop)) (f (multiple_nth tup1 ix) (multiple_nth tup2 ix) ix) (setq ix (+i ix 1)))))))) ;;; iterator on tuple , if the called f returns nil the iteration is stopped ;;; the function is called with the component and its index (defun multiple_iterate_test (tup f) :doc #{Given a multiple $TUP and a function $F, find the first component on which $F returns nil and some other value. Return the component, its index, and that other value.}# (if (is_multiple tup) (if (is_closure f) (foreach_in_multiple (tup) (comp :long ix) (multicall (test other) (f comp ix) (if (null test) (return comp ix other))))))) ;;; map on tuple -- with tup= (t0 t1 ... t_n-1) return ((f t0 0) (f t1 1) ... (f t_n-1 n-1) (defun multiple_map (tup f) :doc #{Given a multiple $TUP and a function $F, make a multiple made of the application of $F to every component and its index.}# (if (is_multiple tup) (if (is_closure f) (let ( (:long ln (multiple_length tup)) (:long ix 0) (res (make_multiple discr_multiple ln)) ) (forever tuploop (if (>=i ix ln) (exit tuploop res)) (let ( (curcomp (multiple_nth tup ix)) ) (multiple_put_nth res ix (f curcomp ix))) (setq ix (+i ix 1))) )))) (defun multiple_to_list (tup disc transf) :doc #{Given a multiple $TUP, a list discriminant $DISC [by default $DISCR_LIST], a function $TRANSF [by default the identity], make a list of every element of the tuple transformed by $TRANSF.}# (if (null disc) (setq disc discr_list)) (if (is_multiple tup) (let ( (lis (make_list disc)) ) (foreach_in_multiple (tup) (comp :long ix) (if (is_closure transf) (list_append lis (transf comp)) (list_append lis comp))) (return lis) ))) ;;; full iterator on closures ;;; the function is called with the component and its index (defun closure_every (clo f) :doc #{Apply to every value inside closure $CLO the function $F}# (if (is_closure clo) (if (is_closure f) (let ( (:long ln (closure_size clo)) (:long ix 0) ) (forever cloloop (if (>=i ix ln) (exit cloloop)) (f (closure_nth clo ix) ix) (setq ix (+i ix 1))))))) ;;; full iterator on routine ;;; the function is called with the component and its index (defun routine_every (rou f) :doc #{Apply to every value inside routine $ROU the function $F}# (if (is_routine rou) (if (is_closure f) (let ( (:long ln (routine_size rou)) (:long ix 0) ) (forever rouloop (if (>=i ix ln) (exit rouloop)) (f (routine_nth rou ix) ix) (setq ix (+i ix 1))))))) ;; utility function to make a list of 1 (defun list1 (v1) :doc #{Make a list of one value $V1}# (let ( (lis (make_list discr_list)) ) (list_append lis v1) lis)) ;; utility function to make a list of 2 (defun list2 (v1 v2) :doc #{Make a list of two values $V1 and $V2}# (let ( (lis (make_list discr_list)) ) (list_append lis v1) (list_append lis v2) lis)) ;; utility function to make a list of 3 (defun list3 (v1 v2 v3) :doc #{Make a list of 3 values $V1 $V2 $V3.}# (let ( (lis (make_list discr_list)) ) (list_append lis v1) (list_append lis v2) (list_append lis v3) lis)) ;; utility function to make a list of 4 (defun list4 (v1 v2 v3 v4) :doc #{Make a list of 4 values $V1 $V2 $V3 $V4.}# (let ( (lis (make_list discr_list)) ) (list_append lis v1) (list_append lis v2) (list_append lis v3) (list_append lis v4) lis)) ;; utility function to make a list of 5 (defun list5 (v1 v2 v3 v4 v5) :doc #{Make a list of 5 values $V1 $V2 $V3 $V4 $V5.}# (let ( (lis (make_list discr_list)) ) (list_append lis v1) (list_append lis v2) (list_append lis v3) (list_append lis v4) (list_append lis v5) lis)) ;; utility function to make a list of 6 (defun list6 (v1 v2 v3 v4 v5 v6) :doc #{Make a list of 6 values $V1 $V2 $V3 $V4 $V5 $V6.}# (let ( (lis (make_list discr_list)) ) (list_append lis v1) (list_append lis v2) (list_append lis v3) (list_append lis v4) (list_append lis v5) (list_append lis v6) lis)) ;;; installation of a method in a class or discriminant (defun install_method (cla sel fun) :doc #{Install in class or discriminant $CLA for selector $SEL the function $FUN as method body.}# (if (is_a cla class_discriminant) (if (is_a sel class_selector) (if (is_closure fun) (let ( (mapdict (unsafe_get_field :disc_methodict cla)) ) (if (is_mapobject mapdict) (mapobject_put mapdict sel fun) (let ( (newmapdict (make_mapobject discr_method_map 35)) ) (unsafe_put_fields cla :disc_methodict newmapdict) (mapobject_put newmapdict sel fun) )))))) ) ;;; selector to output for debugging ;;; reciever: any object or value ;;; arguments: the debuginfo (instance of class_debug_information), the depth (long) (defselector dbg_output class_selector :formals (recv dbginfo :long depth) :doc #{Selector for debug output. Output for debugging the $RECV into $DBGINFO (of $CLASS_DEBUG_INFORMATION) at given $DEPTH.}# ) ;;; selector to output again for debugging ;;; reciever: any object (already output) ;;; arguments: the debuginfo (instance of class_debug_information), the depth (long) (defselector dbg_outputagain class_selector :formals (recv dbginfo :long depth) :doc #{Selector for debug output again, used to output a value already encountered. Output again for debugging the $RECV into $DBGINFO (of $CLASS_DEBUG_INFORMATION) at given $DEPTH.}# ) (defun dbg_outobject (obj dbgi :long depth) :doc #{Output for debugging object $OBJ using debug information $DBGI at given $DEPTH}# (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (occmap (unsafe_get_field :dbgi_occmap dbgi)) ) (if (is_mapobject occmap) (let ( (occ (mapobject_get occmap obj)) ) (checkcallstack_msg "in dbg_outobject") (if (is_integerbox occ) (progn (dbg_outputagain obj dbgi depth) (put_int occ (+i (get_int occ) 1)) ) (let ( (newocc (make_integerbox discr_integer 1)) ) (mapobject_put occmap obj newocc) (checkcallstack_msg "in dbg_outobject output") (dbg_output obj dbgi depth) ))))) ) (defun dbg_out (obj dbgi :long depth) :doc #{Output for debugging value $OBJ using debug information $DBGI at given $DEPTH}# (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (checkcallstack_msg "start dbg_out") (let ( (out (unsafe_get_field :dbgi_out dbgi)) (discr (discrim obj)) ) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (if (is_object obj) (progn ;; (checkcallstack_msg "start dbg_out outobject") (dbg_outobject obj dbgi depth) ) (if obj (progn ;; (checkcallstack_msg "start dbg_out output") (dbg_output obj dbgi depth) ) (if out (add2out_strconst out "()") ))) (if out (add2out_strconst out "..") )))) ;; utility to dump fields in an object from a given rank to a given rank (defun dbgout_fields (obj dbgi :long depth fromrank torank) :doc #{Utility to output for debugging value in $OBJ using debug information $DBGI at given $DEPTH the fields from $FROMRANK to $TORANK}# (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check obj" (is_object obj)) (let ( (:long nbf (object_length obj)) (cla (discrim obj)) (:long ix fromrank) (:long fldcnt 0) (clafieldseq (unsafe_get_field :class_fields cla)) (out (unsafe_get_field :dbgi_out dbgi)) ) (if (=i ix nbf) (exit fldloop)) (and (>i torank 0) (>i ix torank) (exit fldloop)) (let ( (curfld (multiple_nth clafieldseq ix)) (curval (object_nth_field obj ix)) ) (if curval (progn (if (%iraw fldcnt 2) (add2out_indentnl out depth)) (setq fldcnt (+i fldcnt 1)) (add2out_string out (unsafe_get_field :named_name curfld)) (add2out_strconst out "=") (dbg_out curval dbgi (+i depth 1)) (add2out_indent out depth)) )) (setq ix (+i ix 1)) ) ))) ;; utility to dump again fields in an object from a given rank to a given rank (defun dbgoutagain_fields (obj dbgi :long depth fromrank torank) :doc #{Utility to output again for debugging value in $OBJ using debug information $DBGI at given $DEPTH the fields from $FROMRANK to $TORANK}# (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check obj" (is_object obj)) (let ( (:long nbf (object_length obj)) (cla (discrim obj)) (:long ix fromrank) (clafieldseq (unsafe_get_field :class_fields cla)) (out (unsafe_get_field :dbgi_out dbgi)) ) (assert_msg "check out" (is_out out)) (if (=i ix nbf) (exit fldloop)) (and (>i torank 0) (>i ix torank) (exit fldloop)) (let ( (curfld (multiple_nth clafieldseq ix)) (curval (object_nth_field obj ix)) ) (if curval (progn (add2out_indent out depth) (add2out_string out (unsafe_get_field :named_name curfld)) (add2out_strconst out "=") (dbg_outputagain curval dbgi (+i depth 1)) (add2out_indent out depth)) ) (setq ix (+i ix 1)) ) )))) ;; null debug output (defun dbgout_null_method (self dbgi :long depth) (let ( (out (unsafe_get_field :dbgi_out dbgi)) ) (add2out_strconst out "()"))) (install_method discr_null_receiver dbg_output dbgout_null_method) (install_method discr_null_receiver dbg_outputagain dbgout_null_method) ;; string debug output (defun dbgout_string_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_STRING) (progn (add2sbuf_strconst sbuf " \"") (add2sbuf_cencstring sbuf self) (add2sbuf_strconst sbuf "\"") ) (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "\"") (add2sbuf_cencstring sbuf self) (add2sbuf_strconst sbuf "\"") )))) (install_method discr_string dbg_output dbgout_string_method) ;(install_method discr_name_string dbg_output dbgout_string_method) ;(install_method discr_verbatim_string dbg_output dbgout_string_method) ;; integer debug output (defun dbgout_integer_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_INTEGER) (progn (add2sbuf_strconst sbuf " #") (add2sbuf_longdec sbuf (get_int self))) (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "#") (add2sbuf_longdec sbuf (get_int self))) ))) (install_method discr_integer dbg_output dbgout_integer_method) (install_method discr_character_integer dbg_output dbgout_integer_method) ;; mixint debug value (defun dbgout_mixint_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis discr_mixed_integer) (progn (add2sbuf_strconst sbuf " #[") (add2sbuf_longdec sbuf (get_int self))) (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "#[") (add2sbuf_longdec sbuf (get_int self))) ) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (progn (add2sbuf_strconst sbuf ",") (dbg_out (mixint_val self) dbgi (+i depth 1)) ) (add2sbuf_strconst sbuf ",..") ) (add2sbuf_strconst sbuf "]") )) (install_method discr_mixed_integer dbg_output dbgout_mixint_method) ;; mixloc debug value (defun dbgout_mixloc_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self mixloc" (is_mixloc self)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_MIXED_LOCATION) (progn (add2sbuf_strconst sbuf " #![") (add2sbuf_longdec sbuf (get_int self))) (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "#![") (add2sbuf_longdec sbuf (get_int self))) ) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (progn (add2sbuf_strconst sbuf ",") (add2sbuf_mixloc sbuf self) ) (add2sbuf_strconst sbuf ",..") ) (add2sbuf_strconst sbuf "]") )) (install_method discr_mixed_location dbg_output dbgout_mixloc_method) ;; mixbigint debug value (defun dbgout_mixbigint_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self mixbigint" (is_mixbigint self)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "#![") (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (progn (dbg_out (mixbigint_val self) dbgi (+i depth 1)) (add2sbuf_strconst sbuf ",") (ppstrbuf_mixbigint sbuf (+i depth 1) self) ) (add2sbuf_strconst sbuf ",..") ) (add2sbuf_strconst sbuf "]") )) (install_method discr_mixed_bigint dbg_output dbgout_mixbigint_method) ;; multiple debug out (defun dbgout_multiple_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_MULTIPLE) (add2sbuf_strconst sbuf " *") (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "*"))) (let ( (:long ln (multiple_length self)) ) (add2sbuf_longdec sbuf ln) (add2sbuf_strconst sbuf "[") (if (need_dbg depth) (let ( (:long ix 0) ) (forever comploop (if (>=i ix ln) (exit comploop)) (add2sbuf_indent sbuf depth) (let ( (:long curulen (strbuf_usedlength sbuf)) ) (dbg_out (multiple_nth self ix) dbgi (+i 1 depth)) (and (>i (-i (strbuf_usedlength sbuf) curulen) 100) (0 (defun dbgout_routine_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) (boxdepthp1 (make_integerbox discr_integer (+i depth 1))) ) (if (== dis DISCR_ROUTINE) (add2sbuf_strconst sbuf " *rou[%") (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "[%"))) (add2sbuf_routinedescr sbuf self) (if (=i ix (closure_size self)) (exit outloop)) (add2sbuf_indent sbuf depth) (let ( (:long curulen (strbuf_usedlength sbuf)) ) (dbg_out (closure_nth self ix) dbgi (+i depth 1)) (if (>i (-i (strbuf_usedlength sbuf) curulen) 100) (add2sbuf_indentnl sbuf (+i 1 depth)))) (setq ix (+i ix 1)) ))) (add2sbuf_strconst sbuf ">") )) (install_method discr_closure dbg_output dbgout_closure_method) ;; list debug out (defun dbgout_list_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_LIST) (add2sbuf_strconst sbuf " *li(") (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "("))) (let ( (curpair (list_first self)) (:long ix 0) ) (checkcallstack_msg "before loop dbgout_list_method") (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (forever listloop (checkcallstack_msg "start loop dbgout_list_method") (if (>i ix 300) (progn (add2sbuf_strconst sbuf "...") (exit listloop))) (if (not (is_pair curpair)) (exit listloop)) (add2sbuf_indent sbuf depth) (let ( (:long curulen (strbuf_usedlength sbuf)) ) (dbg_out (pair_head curpair) dbgi (+i depth 1)) (setq curpair (pair_tail curpair)) (checkcallstack_msg "near endloop dbgout_list_method") (if (null curpair) (exit listloop)) (setq ix (+i ix 1)) (if (>i (-i (strbuf_usedlength sbuf) curulen) 100) (add2sbuf_indentnl sbuf (+i 1 depth)))) )) (checkcallstack_msg "end dbgout_list_method") (add2sbuf_strconst sbuf ")"))) ) (install_method discr_list dbg_output dbgout_list_method) ;; pair debug output (defun dbgout_pair_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_PAIR) (add2sbuf_strconst sbuf " *pa(.") (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "(."))) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (progn (dbg_out (pair_head self) dbgi (+i depth 1)) (add2sbuf_indent sbuf depth) (dbg_out (pair_tail self) dbgi (+i depth 1)))) (add2sbuf_strconst sbuf ".)"))) (install_method discr_pair dbg_output dbgout_pair_method) ;; box debug output (defun dbgout_box_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (if (== dis DISCR_BOX) (add2sbuf_strconst sbuf " *box[<") (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "[<"))) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (dbg_out (box_content self) dbgi (+i depth 1))) (add2sbuf_strconst sbuf ">]"))) (install_method discr_box dbg_output dbgout_box_method) ;; an internal compare function used to display mapobject-s & mapstring-s in a canonical order. (defun compare_obj_ranked (x1 bxrk1 x2 bxrk2 vless veq vgreat) (if (== x1 x2) (return veq) (let ( (x1dis (discrim x1)) (x2dis (discrim x2)) (:long rk1 (get_int bxrk1)) (:long rk2 (get_int bxrk2)) ) (cond ( (!= x1dis x2dis) (if (string< (unsafe_get_field :named_name x1dis) (unsafe_get_field :named_name x2dis)) (return vless) (return vgreat) )) ( (is_a x1 class_cloned_symbol) (let ( (n1 (unsafe_get_field :named_name x1)) (n2 (unsafe_get_field :named_name x2)) ) (cond ( (string< n1 n2) (return vless)) ( (string> n1 n2) (return vgreat)) (:else (let ( (yr1 (unsafe_get_field :csym_urank x1)) (yr2 (unsafe_get_field :csym_urank x2)) (:long nr1 (get_int yr1)) (:long nr2 (get_int yr2)) ) (cond ( (i nr1 nr2) (return vgreat)) (:else ;; this should not happen, two distinct cloned symbols with same name & rank (assert_msg "corrupted same cloned symbols" ()) (return ())) )))) )) ( (is_a x1 class_named) (let ( (n1 (unsafe_get_field :named_name x1)) (n2 (unsafe_get_field :named_name x2)) ) (cond ( (string< n1 n2) (return vless)) ( (string> n1 n2) (return vgreat)) ( (i rk1 rk2) (return vgreat)) (:else (return veq))) ) ) ( (is_a x1 class_any_binding) (let ( (bsy1 (unsafe_get_field :binder x1)) (bsy2 (unsafe_get_field :binder x1)) ) (return (compare_obj_ranked bsy1 bxrk1 bsy2 bxrk2 vless veq vgreat)))) ( (is_string x1) (cond ( (string< x1 x2) (return vless)) ( (string> x1 x2) (return vgreat)) ( (i rk1 rk2) (return vgreat)) (:else (return veq)))) ( (i rk1 rk2) (return vgreat)) (:else (return veq)) )))) (defun dbgout_mapobject_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (out (get_field :dbgi_out dbgi)) (:long mapcount (mapobject_count self)) ) (assert_msg "check out at start" (is_out out)) (if (== dis DISCR_MAP_OBJECTS) (add2out_strconst out " {") (progn (add2out_strconst out " |") (add2out_string out (unsafe_get_field :named_name dis)) (add2out_strconst out "{"))) (add2out_strconst out "/") (add2out_longdec out (mapobject_count self)) (if (need_dbglim (+i depth 2) (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (let ( (nextdepthbox (make_integerbox discr_integer (+i 2 depth))) (countbox (make_integerbox discr_integer 0)) (boxedone (make_integerbox discr_integer 1)) (boxedzero (make_integerbox discr_integer 0)) (boxedminusone (make_integerbox discr_integer -1)) (tupl (make_multiple discr_multiple mapcount)) ) ;; fill the tupl with (attribute value rank) entries (mapobject_every self (lambda (at va) (let ( (:long curcount (get_int countbox)) (ent (make_tuple3 discr_multiple at va (make_integerbox discr_integer curcount))) ) (multiple_put_nth tupl curcount ent) (put_int countbox (+i curcount 1)) ))) (assert_msg "check tupl" (is_multiple tupl)) ;;; sort the tuple and output in sorted order (let ( (sortupl (multiple_sort tupl (lambda (e1 e2) (let ( (e1at (multiple_nth e1 0)) (e1va (multiple_nth e1 1)) (e1rk (multiple_nth e1 2)) (e2at (multiple_nth e2 0)) (e2va (multiple_nth e2 1)) (e2rk (multiple_nth e2 2)) ) (compare_obj_ranked e1at e1rk e2at e2rk boxedminusone boxedzero boxedone) )) discr_multiple )) ) (assert_msg "check sortupl" (is_multiple sortupl)) (multiple_every sortupl (lambda (el :long ix) (let ( (elat (multiple_nth el 0)) (elva (multiple_nth el 1)) ) (let ( (:long nextdepth (get_int nextdepthbox)) (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) ) (assert_msg "check out" (is_out out)) (add2out_indentnl out nextdepth) (add2out_strconst out "**") (put_int (unsafe_get_field :dbgi_maxdepth dbgi) 0) (dbg_outobject elat dbgi nextdepth) (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth) (add2out_strconst out " ==") (add2out_indent out (+i nextdepth 1)) (dbg_out elva dbgi (+i nextdepth 2)) (add2out_strconst out "; ") ))))) (add2out_strconst out "}"))))) (install_method discr_map_objects dbg_output dbgout_mapobject_method) ;; utility to give a "sorted" tuple of attributes in a mapobject (defun mapobject_sorted_attribute_tuple (mapo) :doc #{Give the alphabetically sorted tuple of attributes in a given object map $MAPO}# (let ( (:long mapcount (mapobject_count mapo)) (countbox (make_integerbox discr_integer 0)) (boxedone (make_integerbox discr_integer 1)) (boxedzero (make_integerbox discr_integer 0)) (boxedminusone (make_integerbox discr_integer -1)) (tupl (make_multiple discr_multiple mapcount)) ) ;; fill the tupl with (attribute value rank) entries (mapobject_every mapo (lambda (at va) (let ( (:long curcount (get_int countbox)) (ent (make_tuple3 discr_multiple at va (make_integerbox discr_integer curcount))) ) (multiple_put_nth tupl curcount ent) (put_int countbox (+i curcount 1)) ))) ;;; sort the tuple and output in sorted order (let ( (sortupl (multiple_sort tupl (lambda (e1 e2) (let ( (e1at (multiple_nth e1 0)) (e1va (multiple_nth e1 1)) (e1rk (multiple_nth e1 2)) (e2at (multiple_nth e2 0)) (e2va (multiple_nth e2 1)) (e2rk (multiple_nth e2 2)) ) (compare_obj_ranked e1at e1rk e2at e2rk boxedminusone boxedzero boxedone) )) discr_multiple )) ) (multiple_map sortupl (lambda (el) (multiple_nth el 0))) ) ) ) ;; multiple debug out (defun dbgout_mapstring_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) (:long ix 0) (:long mapcount (mapstring_count self)) (nextdepthbox (make_integerbox discr_integer (+i 2 depth))) (countbox (make_integerbox discr_integer 0)) (boxedone (make_integerbox discr_integer 1)) (boxedzero (make_integerbox discr_integer 0)) (boxedminusone (make_integerbox discr_integer -1)) (tupl (make_multiple discr_multiple mapcount)) ) (if (== dis DISCR_MAP_STRINGS) (add2sbuf_strconst sbuf " <(") (progn (add2sbuf_strconst sbuf " |") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "<("))) (add2sbuf_strconst sbuf "/") (add2sbuf_longdec sbuf mapcount) (if (need_dbg (+i depth 2)) (progn ;; fill the tuple with string, value, rank triples (mapstring_every self (lambda (str val) (let ( (:long curcount (get_int countbox)) (ent (make_tuple3 discr_multiple str val (make_integerbox discr_integer curcount))) ) (multiple_put_nth tupl curcount ent) (put_int countbox (+i curcount 1)) ))) ;; sort the tuple and display it (let ( (sortupl (multiple_sort tupl (lambda (e1 e2) (let ( (e1at (multiple_nth e1 0)) (e1va (multiple_nth e1 1)) (e1rk (multiple_nth e1 2)) (e2at (multiple_nth e2 0)) (e2va (multiple_nth e2 1)) (e2rk (multiple_nth e2 2)) ) (compare_obj_ranked e1at e1rk e2at e2rk boxedminusone boxedzero boxedone) )) discr_multiple )) ) (assert_msg "check sortupl" (is_multiple sortupl)) (multiple_every sortupl (lambda (el :long ix) (let ( (curstr (multiple_nth el 0)) (curval (multiple_nth el 1)) (:long nextdepth (get_int nextdepthbox)) ) (if (and (is_string curstr) (notnull curval)) (progn (add2sbuf_indentnl sbuf nextdepth) (add2sbuf_strconst sbuf "!*") (dbg_out curstr dbgi nextdepth) (add2sbuf_strconst sbuf " => ") (add2sbuf_indent sbuf nextdepth) (dbg_out curval dbgi (+i nextdepth 2)) )))))))) (add2sbuf_strconst sbuf " )>"))) (install_method discr_map_strings dbg_output dbgout_mapstring_method) ;;;; generic object debug (defun dbgout_anyobject_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (add2sbuf_strconst sbuf "|") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "/") (add2sbuf_longhex sbuf (obj_hash self)) (let ( (:long onum (obj_num self)) (:long oserial (obj_serial self)) ) (if onum (progn (add2sbuf_strconst sbuf "#") (add2sbuf_longdec sbuf onum))) (if oserial (progn (add2sbuf_strconst sbuf "##") (add2sbuf_longdec sbuf oserial))) ) (add2sbuf_strconst sbuf "{") (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (dbgout_fields self dbgi (+i depth 1) 0 0) ) (add2sbuf_strconst sbuf "}") )) (install_method class_root dbg_output dbgout_anyobject_method) ;;;; generic value debug (defun dbgout_anyrecv_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) ) (add2sbuf_strconst sbuf " ?.") (if (is_a dis class_named) (add2sbuf_string sbuf (unsafe_get_field :named_name dis))) (add2sbuf_strconst sbuf ".? ") )) (install_method discr_any_receiver dbg_output dbgout_anyrecv_method) ;;; generic object debug outputagain (defun dbgoutagain_anyobject_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (sbuf (unsafe_get_field :dbgi_out dbgi)) (:long onum (obj_num self)) (:long oserial (obj_serial self)) ) (add2sbuf_strconst sbuf " ^^|") (add2sbuf_string sbuf (unsafe_get_field :named_name dis)) (add2sbuf_strconst sbuf "/") (add2sbuf_longhex sbuf (obj_hash self)) (if onum (progn (add2sbuf_strconst sbuf "#") (add2sbuf_longdec sbuf onum))) (if oserial (progn (add2sbuf_strconst sbuf "##") (add2sbuf_longdec sbuf oserial) )) )) (install_method class_root dbg_outputagain dbgoutagain_anyobject_method) ;;;; named object debug (defun dbgout_namedobject_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (out (unsafe_get_field :dbgi_out dbgi)) (onam (unsafe_get_field :named_name self)) (oprop (unsafe_get_field :prop_table self)) ) (assert_msg "check out" (is_out out)) (add2out_strconst out "`") (add2out_string out onam) (add2out_strconst out "|") (add2out_string out (unsafe_get_field :named_name dis)) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (let ( (:long onum (obj_num self)) (:long oserial (obj_serial self)) ) (if onum (progn (add2out_strconst out "#") (add2out_longdec out onum))) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial))) (add2out_strconst out "{") (if oprop (progn (add2out_strconst out "prop=") (dbg_out oprop dbgi (+i depth 3)) )) (dbgout_fields self dbgi (+i depth 3) 2 0) (add2out_strconst out "}") )))) (install_method class_named dbg_output dbgout_namedobject_method) ;;; we explicitly export dbgout_namedobject_method needed afterwards (export_values dbgout_namedobject_method) ;;;; named object debug outputagain (defun dbgoutagain_namedobject_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (let ( (dis (discrim self)) (out (unsafe_get_field :dbgi_out dbgi)) (onam (unsafe_get_field :named_name self)) (:long oserial (obj_serial self)) ) (add2out_strconst out " ^^`") (add2out_string out onam) (add2out_strconst out "|") (add2out_string out (unsafe_get_field :named_name dis)) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial) )) )) (install_method class_named dbg_outputagain dbgoutagain_namedobject_method) ;;;; symbol output debug & again (defun dbgout_symbol_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_symbol)) (if (<=i depth 0) (dbgout_namedobject_method self dbgi 0) (dbgoutagain_symbol_method self dbgi depth))) (install_method class_symbol dbg_output dbgout_symbol_method) (defun dbgoutagain_symbol_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_symbol)) (let ( (out (unsafe_get_field :dbgi_out dbgi)) (onam (unsafe_get_field :named_name self)) (:long oserial (obj_serial self)) ) (add2out_strconst out " $") (add2out_string out onam) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial) )) )) (install_method class_symbol dbg_outputagain dbgoutagain_symbol_method) ;;;; class output debug & again (defun dbgout_class_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_class)) (if (<=i depth 0) (dbgout_namedobject_method self dbgi 0) (dbgoutagain_namedobject_method self dbgi depth))) (install_method class_class dbg_output dbgout_class_method) ;;;; keyword output debug & again (defun dbgout_keyword_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_keyword)) (if (<=i depth 0) (dbgout_namedobject_method self dbgi 0) (dbgoutagain_keyword_method self dbgi depth))) (install_method class_keyword dbg_output dbgout_keyword_method) (defun dbgoutagain_keyword_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_keyword)) (let ( (out (unsafe_get_field :dbgi_out dbgi)) (onam (unsafe_get_field :named_name self)) (:long oserial (obj_serial self)) ) (add2out_strconst out " $:") (add2out_string out onam) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial) )) )) (install_method class_keyword dbg_outputagain dbgoutagain_keyword_method) ;;;; cloned_symbol output debug & again (defun dbgout_cloned_symbol_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_cloned_symbol)) (if (<=i depth 0) (dbgout_namedobject_method self dbgi 0) (dbgoutagain_cloned_symbol_method self dbgi depth) )) (install_method class_cloned_symbol dbg_output dbgout_cloned_symbol_method) (defun dbgoutagain_cloned_symbol_method (self dbgi :long depth) (let ( (dis (discrim self)) (out (unsafe_get_field :dbgi_out dbgi)) (ourank (unsafe_get_field :csym_urank self)) (:long lrk (get_int ourank)) (:long oserial (obj_serial self)) (onam (unsafe_get_field :named_name self)) ) (add2out_strconst out " $$") (add2out_string out onam) (add2out_strconst out ":") (add2out_longdec out lrk) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial) )) )) (install_method class_cloned_symbol dbg_outputagain dbgoutagain_cloned_symbol_method) ;;;; environment output debug (defun dbgout_environment_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_environment)) (let ( (dis (discrim self)) (out (unsafe_get_field :dbgi_out dbgi)) (:long oserial (obj_serial self)) (:long onum (obj_num self)) ) (if (== dis class_environment) (add2out_strconst out "env") (progn (add2out_strconst out "|") (add2out_string out (unsafe_get_field :named_name dis)) )) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (if onum (progn (add2out_strconst out "#") (add2out_longdec out onum))) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial))) (add2out_strconst out "{") (let ( (:long offprev (get_int env_prev)) (:long oldmaxdepth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (:long newmaxdepth (-i (/i oldmaxdepth 2) 1)) ) (if (i depth 0) (>i oldmaxdepth 3) (put_int (unsafe_get_field :dbgi_maxdepth dbgi) newmaxdepth)) (dbgout_fields self dbgi (+i depth 1) 0 offprev) (if (need_dbglim (+i depth 2) newmaxdepth) (dbgoutagain_fields self dbgi (+i depth 2) offprev 0) (add2out_strconst out ".._..")) (put_int (unsafe_get_field :dbgi_maxdepth dbgi) oldmaxdepth) ))) (add2out_strconst out "}") )) (install_method class_environment dbg_output dbgout_environment_method) ;;;; ctype output debug & again (defun dbgout_ctype_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_ctype)) (if (<=i depth 0) (dbgout_namedobject_method self dbgi 0) (dbgoutagain_ctype_method self dbgi depth) )) (install_method class_ctype dbg_output dbgout_ctype_method) (defun dbgoutagain_ctype_method (self dbgi :long depth) (let ( (dis (discrim self)) (out (unsafe_get_field :dbgi_out dbgi)) (:long oserial (obj_serial self)) (onam (unsafe_get_field :named_name self)) ) (add2out_strconst out " $!") (add2out_string out onam) (add2out_strconst out "!/") (add2out_longhex out (obj_hash self)) (if oserial (progn (add2out_strconst out "##") (add2out_longdec out oserial) )) )) (install_method class_ctype dbg_outputagain dbgoutagain_ctype_method) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; make a fresh environment (defun fresh_env (parenv descr) ;usually descr is not given :doc #{Make a fresh environment of parent $PARENV and optional description $DESCR. See also $CLASS_ENVIRONMENT and $CLASS_DESCRIBED_ENVIRONMENT.}# (if (or (null parenv) (is_a parenv class_environment)) (if descr (instance class_described_environment :env_bind (make_mapobject discr_map_objects 26) :env_prev parenv :denv_descr descr) (instance class_environment :env_bind (make_mapobject discr_map_objects 6) :env_prev parenv)))) ;; the initial environment (definstance initial_environment class_described_environment :doc #{The initial environment of $CLASS_DESCRIBED_ENVIRONMENT.}# :env_bind (make_mapobject discr_map_objects 500) :denv_descr '"Initial Environment" ) ;; find a binding inside an environment (defun find_env (env binder) :doc #{Find a binding inside environement $ENV for binder symbol $BINDER}# (assert_msg "check arg env" (is_a env class_environment)) (assert_msg "check arg binder" (is_object binder)) (forever findloop (if (null env) (exit findloop ())) (assert_msg "check env obj" (is_object env)) (assert_msg "check good env" (is_a env class_environment)) (let ( (bindmap (unsafe_get_field :env_bind env)) ) (assert_msg "check bindmap" (is_mapobject bindmap)) (let ( (bnd (mapobject_get bindmap binder)) ) (if bnd (exit findloop bnd)) )) (setq env (unsafe_get_field :env_prev env)) ) ) ;; find a binding inside an environment with debugging (defun find_env_debug (env binder) (assert_msg "check arg env" (is_a env class_environment)) (assert_msg "check arg binder" (is_object binder)) (debug_msg env "find_env_debug initial env") (debug_msg binder "find_env_debug binder") (forever findloop (if (null env) (exit findloop ())) (debug_msg env "find_env_debug current env") (assert_msg "check env obj" (is_object env)) (assert_msg "check good env" (is_a env class_environment)) (let ( (bindmap (unsafe_get_field :env_bind env)) ) (assert_msg "check bindmap" (is_mapobject bindmap)) (let ( (bnd (mapobject_get bindmap binder)) ) (debug_msg bnd "find_env_debug current bnd") (if bnd (exit findloop bnd)) )) (debug_msg binder "find_env_debug at end of loop binder") (setq env (unsafe_get_field :env_prev env)) ) ) ;; find a binding inside an environment and also returns the reversed list of enclosing procedures (defun find_enclosing_env (env binder) :doc #{Find the binding in environment $ENV for given $BINDER symbol and secondarily return the reversed list of enclosing procedures.}# (assert_msg "check env" (is_a env class_environment)) (assert_msg "check binder" (is_object binder)) (let ( (proclist (make_list discr_list)) ) (forever findloop (if (is_not_a env class_environment) (exit findloop)) (let ( (bindmap (unsafe_get_field :env_bind env)) (eproc (unsafe_get_field :env_proc env)) ) (assert_msg "check bindmap" (is_mapobject bindmap)) (let ( (bnd (mapobject_get bindmap binder)) ) (if bnd (return bnd proclist))) (if eproc (list_prepend proclist eproc)) (setq env (unsafe_get_field :env_prev env)) )))) ;; put a binding at top of an environment (defun put_env (env binding) :doc #{Put into environment $ENV the given $BINDING. See also $CLASS_ANY_BINDING and $CLASS_ENVIRONMENT.}# (assert_msg "check binding is obj" (is_object binding)) (assert_msg "check env is obj" (is_object env)) (assert_msg "check env" (is_a env class_environment)) (if (not (is_a binding class_any_binding)) (progn (debug_msg binding "put_env invalid binding") (shortbacktrace_dbg "put_env invalid binding" 15))) (assert_msg "check binding" (is_a binding class_any_binding)) (let ( (bindmap (unsafe_get_field :env_bind env)) (binderv (unsafe_get_field :binder binding)) ) (if (not (is_object binder)) (progn (debug_msg binding "put_env bad binder in binding") (debug_msg binderv "put_env bad binderv") (shortbacktrace_dbg "put_env bad binder in binding" 5))) (assert_msg "check bindmap" (is_mapobject bindmap)) (assert_msg "check binderv" (is_object binderv)) (mapobject_put bindmap binderv binding) )) ;; overwrite a binding in the environment where it has been already bound (defun overwrite_env (env binding) :doc #{Overwrite in environment $ENV or its ancestor the given $BINDING, in the environment where it has already been bound. See also $CLASS_ANY_BINDING and $CLASS_ENVIRONMENT.}# (assert_msg "check env" (is_a env class_environment)) (assert_msg "check binding" (is_a binding class_any_binding)) (let ( (binderv (unsafe_get_field :binder binding)) ) (assert_msg "check binderv" (is_object binderv)) (forever findloop (if (not (is_a env class_environment)) (exit findloop)) (let ( (bindmap (unsafe_get_field :env_bind env)) ) (assert_msg "check bindmap" (is_mapobject bindmap)) (let ( (oldbinding (mapobject_get bindmap binder)) ) (if oldbinding (progn (mapobject_put bindmap binderv binding) (exit findloop oldbinding)) )) (setq env (unsafe_get_field :env_prev env)) )))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; debug_msg support is done by calling this debug_msg_fun (defun debug_msg_fun (val :cstring msgstr :long count :cstring filenam :long lineno) :doc #{Internal function called by $DEBUG_MSG macro to output for debugging the value $VAL with message $MSGSTR, given $COUNT, at $FILENAM and $LINENO}# (code_chunk incrdbgcounter #{++melt_dbgcounter}#) (if (need_dbg 0) (let ( (:long dbgcounter 0) (out (get_field :sysdata_dumpfile initial_system_data)) (occmap (make_mapobject discr_map_objects 50)) (boxedmaxdepth (make_integerbox discr_integer 17)) ;;;; @@@ DEBUGDEPTH ) (code_chunk getdbgcounter #{$dbgcounter = melt_dbgcounter}#) ;; it may happen that OUT is null, e.g. because the dumpfile ;; is not yet initialized in initial_system_data... (if (null out) (setq out (make_strbuf discr_strbuf))) (assert_msg "check good out" (is_out out)) (let ( (:long nulloutfile 0) ) (code_chunk getfile #{ if (melt_is_file($out)) $nulloutfile = (melt_get_file($out)==NULL)?1:0 ; }#) (if nulloutfile (progn (shortbacktrace_dbg "debug_msg_fun null output file" 5) (setq out (get_field :sysdata_stderr initial_system_data)) ))) (let ( (dbgi (instance class_debug_information :dbgi_out out :dbgi_occmap occmap :dbgi_maxdepth boxedmaxdepth)) (:long framdepth (the_framedepth)) ) (add2out_strconst out "!!!!****####") (add2out_longdec out dbgcounter) (add2out_strconst out "#^") (add2out_longdec out (-i framdepth 1)) (add2out_strconst out ":") (if filenam (progn (add2out_strconst out filenam) (add2out_strconst out ":") (add2out_longdec out lineno) (add2out_strconst out ":") )) (add2out_strconst out msgstr) (if (>i count 0) (progn (add2out_strconst out " !") (add2out_longdec out count) (add2out_strconst out ": ") )) (if val (dbg_out val dbgi 0) (add2out_strconst out "() ;;;NIL!!!") ) (add2out_indentnl out 0) ) (if (is_strbuf out) (progn (code_chunk debugstrbuf #{ fprintf (stderr, "\n**debug_msg thru strbuffer:\n%s\n", melt_strbuf_str ($out)) ; fflush (stderr) ; }#) )) ))) ;;;; any binding debug output (defun dbgout_anybinding_method (self dbgi :long depth) (assert_msg "check dbgi" (is_a dbgi class_debug_information)) (assert_msg "check self" (is_a self class_any_binding)) (let ( (dis (discrim self)) (out (unsafe_get_field :dbgi_out dbgi)) (binderv (unsafe_get_field :binder self)) ) (add2out_indent out depth) (add2out_strconst out "[~") (add2out_string out (unsafe_get_field :named_name dis)) (add2out_strconst out "/") (add2out_longhex out (obj_hash self)) (add2out_strconst out ":") (dbg_outputagain binderv dbgi (+i depth 2)) (if (need_dbglim depth (get_int (unsafe_get_field :dbgi_maxdepth dbgi))) (progn (add2out_strconst out "; ") (dbgout_fields self dbgi (+i depth 1) 1 0) )) (add2out_strconst out "~]") )) (install_method class_any_binding dbg_output dbgout_anybinding_method) (install_method class_any_binding dbg_outputagain dbgout_anybinding_method) ;;;**************************************************************** ;; before the update_current_module_environment_container below, most ;; constants for current_module_environment_container or ;; parent_module_environment are null because there is not enough ;; stuff yet to build them. (update_current_module_environment_container) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; a special function to be called when compiling with compilinit mode. ;;; which magically adds a call to it at end of the read list (defun post_initialization (unusedarg :cstring meltfilnam) (let ( (curmodenvcont (current_module_environment_container)) ) (if (not (is_a curmodenvcont class_container)) (progn (warningmsg_strv "post_initialization strange curmodenvcont of discr" (unsafe_get_field :named_name (discrim curmodenvcont))) (return) )) (debug_msg curmodenvcont "post_initialization curmodenvcont at start") ;(shortbacktrace_dbg "post_initialization" 10) (assert_msg "check curmodenvcont" (is_a curmodenvcont class_container)) (let ( (curmodenv (unsafe_get_field :container_value curmodenvcont)) ) (if (is_a curmodenv class_environment) (let ( (curbindmap (unsafe_get_field :env_bind curmodenv)) ) (informsg_long "post_initialization boundvars num" (mapobject_count curbindmap)) ) (let ( (curmenvdiscr (discrim curmodenv)) ) (informsg_strv "post_initialization strange curmodenv of discr" (unsafe_get_field :named_name curmenvdiscr))) ))) ) (put_fields initial_system_data :sysdata_stdout (let ( (f ()) (d discr_rawfile) ) (code_chunk makestdout #{ $f = meltgc_new_file($d, stdout) ; }# ) f) :sysdata_stderr (let ( (f ()) (d discr_rawfile) ) (code_chunk makestderr #{ $f = meltgc_new_file($d, stderr) ; }# ) f) :sysdata_dumpfile (let ( (f ()) (d discr_rawfile) ) ;; the FILE* of dumpfile is also set in pass executions. (code_chunk makedump #{ $f = meltgc_new_file($d, dump_file) ; }# ) f) ) ;;;;;; export the above classes (export_class ;;in alphabetical order, one per line, for convenience class_any_binding class_any_matcher class_citerator class_citerator_binding class_class class_class_binding class_cloned_symbol class_container class_cmatcher_binding class_cmatcher class_ctype class_debug_information class_described_environment class_discriminant class_environment class_exported_binding class_field class_field_binding class_fixed_binding class_formal_binding class_function_binding class_funmatcher class_funmatcher_binding class_c_generation_context class_gcc_gimple_pass class_gcc_pass class_gcc_rtl_pass class_gcc_simple_ipa_pass class_initial_generation_context class_instance_binding class_keyword class_label_binding class_let_binding class_letrec_binding class_located class_macro_binding class_melt_mode class_module_context class_named class_normalization_context class_normal_let_binding class_generated_c_code class_patmacro_binding class_primitive class_primitive_binding class_proped class_root class_selector class_selector_binding class_sexpr class_source class_symbol class_system_data class_value_binding ) ;end of export class ;;;;;;;;;;;;;;;; ;;;; export the above primitives (export_values ;in alphanumerical order != !=i %i %iraw *i +i -i /i /iraw <=i =i >i add2out_ccomconst add2out_ccomstrbuf add2out_ccomstring add2out_cencstrbuf add2out_cencstring add2out_cident add2out_cidentprefix add2out_indent add2out_indentnl add2out_longdec add2out_longhex add2out_mixloc add2out_routinedescr add2out_sbuf add2out_strconst add2out_string add2sbuf_ccomconst add2sbuf_ccomstrbuf add2sbuf_ccomstring add2sbuf_cencstrbuf add2sbuf_cencstring add2sbuf_cident add2sbuf_cidentprefix add2sbuf_indent add2sbuf_indentnl add2sbuf_longdec add2sbuf_longhex add2sbuf_mixloc add2sbuf_routinedescr add2sbuf_sbuf add2sbuf_short_mixloc add2sbuf_texi_mixloc add2sbuf_strconst add2sbuf_string andi assert_failed box_content box_put cbreak_msg checkcallstack_msg checkval_dbg closure_nth closure_routine closure_size create_keywordstr create_symbolstr discrim debugcstring error_plain error_strv errormsg_plain errormsg_strv full_garbcoll generate_melt_module get_globpredef get_int get_keywordstr get_symbolstr ignore inform_plain inform_strv informsg_long informsg_plain informsg_strv is_a is_box is_closure is_integerbox is_list is_list_or_null is_mapobject is_mapstring is_mixbigint is_mixint is_mixloc is_multiple is_multiple_or_null is_not_a is_not_object is_object is_pair is_routine is_strbuf is_string is_stringconst list_append list_first list_find list_last list_length list_popfirst list_prepend load_melt_module longbacktrace_dbg make_box make_integerbox make_list make_mapobject make_mapstring make_multiple make_mixint make_mixloc make_pair make_strbuf make_string make_string_nakedbasename make_string_tempname_suffixed make_stringconst make_tuple1 make_tuple2 make_tuple3 make_tuple4 make_tuple5 make_tuple6 make_tuple7 mapobject_count mapobject_get mapobject_nth_attr mapobject_nth_val mapobject_put mapobject_remove mapobject_size mapstring_count mapstring_getstr mapstring_nth_attrstr mapstring_nth_val mapstring_putstr mapstring_rawget mapstring_rawput mapstring_rawremove mapstring_removestr mapstring_size message_dbg messagenum_dbg messageval_dbg minor_garbcoll mixbigint_val mixint_val mixloc_location mixloc_locline mixloc_locfile mixloc_val multiple_length multiple_nth multiple_put_nth multiple_sort need_dbg need_dbglim negi nonzero_hash not noti notnull null obj_hash obj_len obj_num obj_serial object_length object_nth_field ori out_cplugin_compiled_timestamp_err out_cplugin_md5_checksum_err outcstring_dbg outcstring_err outnewline_dbg outnewline_err outnum_dbg outnum_err output_sbuf_strconst output_sbuf_strval outstr_dbg outstr_err outstrbuf_dbg outstrbuf_err pair_head pair_listlength pair_set_head pair_tail ppstrbuf_mixbigint put_int read_file routine_descr routine_nth routine_size shortbacktrace_dbg split_string_colon split_string_comma split_string_space strbuf2string strbuf_usedlength string< string= string> string_length stringconst2val subclass_of subclass_or_eq subseq_multiple the_callcount the_framedepth the_null_cstring void warning_plain warning_strv xori zerop ) ;; export the discriminants and instances and selectors defined above (export_values ;alphabetical order ctype_basic_block ctype_cstring ctype_edge ctype_gimple ctype_gimple_seq ctype_long ctype_ppl_coefficient ctype_ppl_constraint ctype_ppl_constraint_system ctype_ppl_linear_expression ctype_tree ctype_value ctype_void dbg_output dbg_outputagain discr_any_receiver discr_basic_block discr_box discr_character_integer discr_class_sequence discr_closure discr_constant_integer discr_edge discr_field_sequence discr_file discr_gimple discr_gimple_seq discr_integer discr_list discr_map_basic_blocks discr_map_edges discr_map_gimples discr_map_gimple_seqs discr_map_objects discr_map_strings discr_map_trees discr_method_map discr_mixed_bigint discr_mixed_integer discr_mixed_location discr_multiple discr_name_string discr_null_receiver discr_pair discr_ppl_constraint_system discr_ppl_polyhedron discr_rawfile discr_routine discr_strbuf discr_string discr_tree discr_verbatim_string initial_environment initial_system_data ) ;;;end export discriminants, instances, selectors ;; export the functions & matchers defined above (export_values at_exit_first at_exit_last at_finish_unit_first at_finish_unit_last at_start_unit_first at_start_unit_last clone_symbol closure_every compare_named_alpha compare_obj_ranked cstring_length cstring_same dbg_out dbg_outobject dbgout_fields dbgoutagain_fields debug_msg_fun debugmsg display_debug_message find_enclosing_env find_env find_env_debug fresh_env install_ctype_descr install_method list1 list2 list3 list4 list5 list6 list_append2list list_every list_iterate_test list_map list_to_multiple mapobject_every mapobject_iterate_test mapobject_sorted_attribute_tuple mapstring_every mapstring_iterate_test multiple_backward_every multiple_every multiple_every_both multiple_iterate_test multiple_map multiple_to_list overwrite_env pairlist_to_multiple post_initialization put_env routine_every tuple_nth tuple_sized ) ;; export the citerators & cmatchers defined above (export_values foreach_in_list foreach_in_mapobject foreach_in_mapstring foreach_in_multiple foreach_in_multiple_backward foreach_long_upto integerbox_of ) ;; we predefine :true as the TRUE. Currently no handcoded C function ;; uses it, but perhaps that could change!! (let ( ( truekeyword :true) ) (code_chunk storetruekeyword #{MELT_STORE_PREDEF(TRUE,$truekeyword)}#)) ;; we export displaydebugmsg because a previous version of warmelt-genobj-0 used it (export_synonym displaydebugmsg display_debug_message) ;; eof warmelt-first.melt