2 /* Interpreter for the Kernel programming language*/
4 /*_ . Credits and License */
6 Copyright (C) 2010,2011 Tom Breton (Tehom)
8 This program is free software: you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation, either version 3 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program. If not, see <http://www.gnu.org/licenses/>.
24 #include "klink-private.h"
29 #define snprintf _snprintf
48 # define stricmp strcasecmp
52 /* Used for documentation purposes, to signal functions in 'interface' */
60 stricmp (const char *s1
, const char *s2
)
76 #endif /* __APPLE__ */
92 /*_ . Configuration */
94 #define banner "Klink 0.0\n"
97 # define prompt "klink> "
101 # define InitFile "init.krn"
104 /*_ , Internal declarations */
106 /*_ , Name-mangling */
107 #define KEY(C_NAME) _k_key_##C_NAME
108 #define DESTR_NAME(C_NAME) _k_destructure_##C_NAME
109 #define OPER(C_NAME) _k_oper_##C_NAME
110 #define APPLICATIVE(C_NAME) _k_appl_##C_NAME
111 #define CHAIN_NAME(C_NAME) _k_chain_##C_NAME
112 #define CHKARRAY(C_NAME) _k_chkvec_##C_NAME
114 /*_ , For forward declarations of combiners */
115 #define FORWARD_DECL_CFUNC(LINKAGE,SUFFIX,C_NAME) \
116 LINKAGE KERNEL_FUN_SIG_##SUFFIX (C_NAME); \
117 kt_boxed_cfunc OPER(C_NAME)
119 #define FORWARD_DECL_PRED(LINKAGE,C_NAME) \
120 FORWARD_DECL_CFUNC(LINKAGE,b00a1,C_NAME)
122 #define FORWARD_DECL_T_PRED(LINKAGE,C_NAME) \
123 LINKAGE kt_boxed_T OPER(C_NAME)
125 #define FORWARD_DECL_CHAIN(LINKAGE,C_NAME) \
126 LINKAGE kt_boxed_vector OPER(C_NAME)
128 #define FORWARD_DECL_APPLICATIVE(LINKAGE,SUFFIX,C_NAME) \
129 FORWARD_DECL_CFUNC(LINKAGE,SUFFIX,C_NAME); \
130 kt_boxed_encap APPLICATIVE(C_NAME); \
134 /* No noun/number agreement for WITH_1_ARGS because I prefer name
136 #define WITH_1_ARGS(A1) \
138 #define WITH_2_ARGS(A1,A2) \
139 WITH_1_ARGS(A1), A2 = arg2
140 #define WITH_3_ARGS(A1,A2,A3) \
141 WITH_2_ARGS(A1,A2), A3 = arg3
142 #define WITH_4_ARGS(A1,A2,A3,A4) \
143 WITH_3_ARGS(A1,A2,A3), A4 = arg4
144 #define WITH_5_ARGS(A1,A2,A3,A4,A5) \
145 WITH_4_ARGS(A1,A2,A3,A4), A5 = arg5
146 /*_ , WITH_REPORTER */
147 #define WITH_REPORTER(SC) \
148 sc_or_null _err_reporter = (SC)
149 /*_ , Defining sub-T types */
151 #define VEC_DEF_FROM_ARRAY(ARRAY_NAME) \
153 sizeof(ARRAY_NAME)/sizeof(ARRAY_NAME[0]), \
157 #define DEF_VEC(T_ENUM, NAME, ARRAY_NAME) \
158 kt_boxed_vector NAME = \
161 VEC_DEF_FROM_ARRAY (ARRAY_NAME), \
164 /*_ , Checking type */
165 /*_ . Certain destructurers and type checks */
166 #define K_ANY REF_OPER(is_any)
167 #define K_NO_TYPE REF_KEY(K_TYCH_NO_TYPE)
168 #define K_ANY_SINGLETON REF_OBJ(_K_any_singleton)
170 /*_ . Internal: Arrays to be in typechecks and destructurers */
171 /* Elements of this array should not call Kernel - should be T_NO_K */
172 /* $$IMPROVE ME Check that when registering combiners */
173 #define SIG_CHKARRAY(C_NAME) pko CHKARRAY(C_NAME)[]
174 /*_ . Boxed destructurers */
175 #define REF_DESTR(C_NAME) REF_OBJ(DESTR_NAME(C_NAME))
176 #define DESTR_DEF_FROM_ARRAY(ARRAY_NAME) \
177 { VEC_DEF_FROM_ARRAY (ARRAY_NAME), -1, }
179 #define DEF_DESTR(NAME,ARRAY_NAME) \
180 kt_boxed_destr_list NAME = \
182 T_DESTRUCTURE | T_IMMUTABLE | T_NO_K, \
183 DESTR_DEF_FROM_ARRAY(ARRAY_NAME), \
186 /* DEF_VEC(T_DESTRUCTURE | T_IMMUTABLE | T_NO_K, NAME, ARRAY_NAME) */
188 #define DEF_SIMPLE_DESTR(C_NAME) \
189 DEF_DESTR(DESTR_NAME(C_NAME), CHKARRAY(C_NAME))
194 /* Awkward because we both declare stuff and assign stuff. */
195 #define ALLOC_BOX(NAME,T_ENUM,BOXTYPE) \
196 typedef BOXTYPE _TT; \
197 _TT * NAME = GC_MALLOC(sizeof(_TT)); \
200 /* ALLOC_BOX_PRESUME defines the following:
201 pbox - a pointer to the box
202 pdata - a pointer to the box's contents
204 #define ALLOC_BOX_PRESUME(TYPE,T_ENUM) \
206 ALLOC_BOX(pbox,T_ENUM,BOX_OF(TYPE)); \
207 pdata = &(pbox)->data
211 #define WITH_BOX_TYPE(NAME,P) \
212 _kt_tag * NAME = &((kt_boxed_any *)(P))->type;
215 /* This could mostly be an inlined function, but it wouldn't know
217 #define WITH_UNBOXED_RAW(P,NAME,TYPE,BOXTYPE) \
220 typedef BOXTYPE _TT; \
221 _TT * _pbox = (_TT *)(P); \
222 NAME = &_pbox->data; \
225 /*_ , Entry points */
226 #define WITH_UNBOXED_UNSAFE(NAME,TYPE,P) \
227 WITH_UNBOXED_RAW(P,NAME,TYPE,BOX_OF(TYPE))
230 /* WITH_PSYC_UNBOXED defines the following:
231 pdata - a pointer to the box's contents
233 #define WITH_PSYC_UNBOXED(TYPE,P,T_ENUM,SC) \
234 assert_type(SC,(P),T_ENUM); \
235 WITH_UNBOXED_UNSAFE(pdata,TYPE,P)
239 #define REF_KEY(NAME) REF_OBJ(KEY(NAME))
241 #define BOX_OF_VOID(NAME) \
242 kt_boxed_void KEY(NAME) = { T_KEY | T_IMMUTABLE }; \
243 pko NAME = REF_KEY(NAME)
246 /* All operatives use this, regardless whether they are cfuncs,
248 #define REF_OPER(C_NAME) REF_OBJ(OPER(C_NAME))
251 #define DEF_CFUNC_RAW(NAME,SUFFIX,C_NAME,DESTR,XTRA_FLAGS) \
252 RGSTR(all-builtins,"C-" #C_NAME, REF_OBJ (NAME)) \
253 kt_boxed_cfunc NAME = \
254 { T_CFUNC | T_IMMUTABLE | XTRA_FLAGS, \
255 {{C_NAME}, klink_ftype_##SUFFIX, DESTR, 0}};
257 #define DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME, DESTR,XTRA_FLAGS) \
258 DEF_CFUNC_RAW(OPER(C_NAME),SUFFIX,C_NAME, DESTR,XTRA_FLAGS)
260 #define DEF_CFUNC(SUFFIX,C_NAME,DESTR,XTRA_FLAGS) \
261 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
262 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS); \
263 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
265 #define DEF_SIMPLE_CFUNC(SUFFIX,C_NAME,XTRA_FLAGS) \
266 DEF_SIMPLE_DESTR(C_NAME); \
267 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
268 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS); \
269 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
271 /*_ . Applicatives */
272 #define REF_APPL(C_NAME) REF_OBJ(APPLICATIVE(C_NAME))
274 #define DEF_BOXED_APPLICATIVE(C_NAME,FF) \
275 kt_boxed_encap APPLICATIVE (C_NAME) = \
276 { T_ENCAP | T_IMMUTABLE, \
277 {REF_KEY(K_APPLICATIVE), FF}};
279 #define DEF_APPLICATIVE_W_DESTR(SUFFIX,C_NAME,DESTR,XTRA_FLAGS,RG,K_NAME) \
280 RGSTR(RG,K_NAME, REF_APPL(C_NAME)) \
281 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
282 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS); \
283 DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME)); \
284 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
286 #define DEF_SIMPLE_APPLICATIVE(SUFFIX,C_NAME,XTRA_FLAGS,RG,K_NAME) \
287 RGSTR(RG,K_NAME, REF_APPL(C_NAME)) \
288 DEF_SIMPLE_DESTR(C_NAME); \
289 KERNEL_FUN_SIG_##SUFFIX(C_NAME); \
290 DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS); \
291 DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME)); \
292 KERNEL_FUN_SIG_##SUFFIX(C_NAME)
294 /*_ . Abbreviations for predicates */
295 /* The underlying C function takes the whole value as its sole arg.
296 Above that, in init.krn an applicative wrapper applies it over a
297 list, using `every?'.
299 #define DEF_SIMPLE_PRED(C_NAME,XTRA_FLAGS,RG,K_NAME) \
300 RGSTR(RG,K_NAME, REF_OPER(C_NAME)) \
301 DEF_CFUNC(b00a1,C_NAME,K_ANY_SINGLETON,XTRA_FLAGS)
303 /* The cfunc is there just to be exported for C use. */
304 #define DEF_T_PRED(C_NAME,T_ENUM,RG,K_NAME) \
305 RGSTR(RG,K_NAME, REF_OPER(C_NAME)) \
306 kt_boxed_T OPER(C_NAME) = \
307 { T_TYPEP | T_IMMUTABLE | T_NO_K, {T_ENUM}}; \
308 int C_NAME(pko p) { return is_type(p,T_ENUM); }
311 /*_ . Curried Functions */
313 #define DEF_BOXED_CURRIED(CURRY_NAME,DECURRIER,ARGS,NEXT) \
314 RGSTR(all-builtins,"C-" #CURRY_NAME, REF_OBJ (CURRY_NAME)) \
315 kt_boxed_curried CURRY_NAME = \
316 { T_CURRIED | T_IMMUTABLE, \
317 {DECURRIER, ARGS, NEXT, 0}};
319 #define DEF_BOXED_PAIR(C_NAME,CAR,CDR) \
320 boxed_vec2 C_NAME = \
321 { T_PAIR | T_IMMUTABLE, {CAR, CDR, }}
324 #define DEF_LISTSTAR2 DEF_BOXED_PAIR
326 #define DEF_LISTSTAR3(C_NAME,A1,A2,A3) \
327 DEF_BOXED_PAIR(C_NAME##__1,A2,A3); \
328 DEF_BOXED_PAIR(C_NAME,A1,REF_OBJ(C_NAME##__1))
330 #define DEF_LIST1(C_NAME,A1) DEF_LISTSTAR2(C_NAME,A1, REF_KEY(K_NIL))
331 #define DEF_LIST2(C_NAME,A1,A2) DEF_LISTSTAR3(C_NAME,A1,A2,REF_KEY(K_NIL))
333 /*_ , Building objects in C */
334 #define ANON_OBJ( TYPE, X ) \
335 (((BOX_OF( TYPE )[]) { X })[0])
337 /* Middle is the same as ANON_OBJ but we can't just use that because
338 of expansion issues */
339 #define ANON_REF( TYPE, X ) \
340 REF_OBJ((((BOX_OF( TYPE )[]) { X })[0]))
342 #define PAIR_DEF( CAR, CDR ) \
343 { T_PAIR | T_IMMUTABLE, { CAR, CDR, }, }
345 #define ANON_PAIR( CAR, CDR ) \
346 ANON_REF(kt_vec2, PAIR_DEF( CAR, CDR ))
348 #define INT_DEF( N ) \
349 { T_NUMBER | T_IMMUTABLE, { 1, { N }, }, }
352 /*_ , Building lists in C */
353 /*_ . Anonymous lists */
355 #define ANON_LISTSTAR2(A1, A2) \
358 #define ANON_LISTSTAR3(A1, A2, A3) \
359 ANON_PAIR(A1, ANON_LISTSTAR2(A2, A3))
361 #define ANON_LISTSTAR4(A1, A2, A3, A4) \
362 ANON_PAIR(A1, ANON_LISTSTAR3(A2, A3, A4))
365 #define ANON_LIST1(A1) \
366 ANON_LISTSTAR2(A1, REF_KEY(K_NIL))
368 #define ANON_LIST2(A1, A2) \
369 ANON_PAIR(A1, ANON_LIST1(A2))
371 #define ANON_LIST3(A1, A2, A3) \
372 ANON_PAIR(A1, ANON_LIST2(A2, A3))
374 #define ANON_LIST4(A1, A2, A3, A4) \
375 ANON_PAIR(A1, ANON_LIST3(A2, A3, A4))
377 #define ANON_LIST5(A1, A2, A3, A4, A5) \
378 ANON_PAIR(A1, ANON_LIST4(A2, A3, A4, A5))
380 #define ANON_LIST6(A1, A2, A3, A4, A5, A6) \
381 ANON_PAIR(A1, ANON_LIST5(A2, A3, A4, A5, A6))
384 /*_ . Dynamic lists */
386 #define LISTSTAR2(A1, A2) \
388 #define LISTSTAR3(A1, A2, A3) \
389 cons (A1, LISTSTAR2(A2, A3))
390 #define LISTSTAR4(A1, A2, A3, A4) \
391 cons (A1, LISTSTAR3(A2, A3, A4))
397 #define LIST2(A1, A2) \
398 cons (A1, LIST1 (A2))
399 #define LIST3(A1, A2, A3) \
400 cons (A1, LIST2 (A2, A3))
401 #define LIST4(A1, A2, A3, A4) \
402 cons (A1, LIST3 (A2, A3, A4))
403 #define LIST5(A1, A2, A3, A4, A5) \
404 cons (A1, LIST4 (A2, A3, A4, A5))
405 #define LIST6(A1, A2, A3, A4, A5, A6) \
406 cons (A1, LIST5 (A2, A3, A4, A5, A6))
408 /*_ , Kernel continuation macros */
409 /*_ . W/o decurrying */
410 #define CONTIN_0_RAW(C_NAME,SC) \
411 klink_push_cont((SC), (C_NAME))
412 #define CONTIN_0(OPER_NAME,SC) \
413 klink_push_cont((SC), REF_OPER (OPER_NAME))
416 /* The use of REF_OPER requires these to be macros. */
418 #define CONTIN_1R(DECURRIER,C_NAME,SC,ARGS) \
419 klink_push_cont((SC), \
420 mk_curried(DECURRIER, ARGS, REF_OPER (C_NAME)))
422 #define CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,ARG2) \
423 CONTIN_1R(DECURRIER,C_NAME,SC,cons(ARG1,ARG2))
425 #define CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3) \
426 CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,cons(ARG2,ARG3))
428 #define CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4) \
429 CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,cons(ARG3,ARG4))
431 #define CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5) \
432 CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,cons(ARG4,ARG5))
434 #define CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,ARG6) \
435 CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,cons(ARG5,ARG6))
439 #define CONTIN_1(DECURRIER,C_NAME,SC,ARG1) \
440 CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,K_NIL)
442 #define CONTIN_2(DECURRIER,C_NAME,SC,ARG1,ARG2) \
443 CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,K_NIL)
445 #define CONTIN_3(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3) \
446 CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,K_NIL)
448 #define CONTIN_4(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4) \
449 CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,K_NIL)
451 #define CONTIN_5(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5) \
452 CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,K_NIL)
455 #define kernel_bool(tf) ((tf) ? K_T : K_F)
457 /*_ , Control macros */
459 /* These never return because _klink_error_1 longjmps. */
460 /* $$IMPROVE ME If GCC is used or C99 is available, use __func__ as the function name. */
461 #define KERNEL_ERROR_1(sc,s, a) { _klink_error_1(sc,s,a); return 0; }
462 #define KERNEL_ERROR_0(sc,s) { _klink_error_1(sc,s,0); return 0; }
464 /*_ . Enumerations */
465 /*_ , The port types & flags */
480 typedef enum klink_token
498 /*_ , List metrics */
507 typedef int int4
[lm_max
];
509 /*_ . Struct definitions */
512 typedef BOX_OF (kt_cfunc
)
519 /* Object identity lets us compare instances. */
524 typedef BOX_OF (kt_encap
)
527 /*_ , Curried calls */
529 typedef pko (* decurrier_f
) (klink
* sc
, pko args
, pko value
);
534 decurrier_f decurrier
;
540 typedef BOX_OF (kt_curried
)
543 /*_ , T_typep calls */
550 typedef BOX_OF(typep_t
)
584 typedef BOX_OF(kt_vector
)
586 /*_ , Destructurer */
587 /*_ , kt_destr_list */
594 typedef BOX_OF(kt_destr_list
)
598 /*_ , Initialization */
599 static void klink_setup_error_cont (klink
* sc
);
600 static void klink_cycle_restarting (klink
* sc
, pko combiner
);
601 static int klink_cycle_no_restart (klink
* sc
, pko combiner
);
602 static void _klink_cycle (klink
* sc
);
605 /*_ , Error handling */
606 static void _klink_error_1 (klink
* sc
, const char *s
, pko a
);
607 /*_ . Stack control */
608 static int klink_pop_cont (klink
* sc
);
611 static pko
klink_call_cfunc (klink
* sc
, pko functor
, pko env
, pko args
);
612 FORWARD_DECL_CFUNC (static, ps0a2
, k_resume_to_cfunc
);
616 mk_load_ix (int x
, int y
);
621 mk_store (pko data
, int depth
);
625 call_curried(klink
* sc
, pko curried
, pko value
);
627 /*_ , Top level operatives */
628 FORWARD_DECL_APPLICATIVE(static,ps0a0
,kernel_repl
);
629 FORWARD_DECL_APPLICATIVE(static,ps0a0
,kernel_rel
);
630 FORWARD_DECL_APPLICATIVE(static,ps0a1
,kernel_internal_eval
);
633 static INLINE pko
oblist_find_by_name (const char *name
);
634 static pko
oblist_add_by_name (const char *name
);
637 static pko
mk_number (num n
);
639 static num
num_add (num a
, num b
);
640 static num
num_mul (num a
, num b
);
641 static num
num_div (num a
, num b
);
642 static num
num_intdiv (num a
, num b
);
643 static num
num_sub (num a
, num b
);
644 static num
num_rem (num a
, num b
);
645 static num
num_mod (num a
, num b
);
646 static int num_eq (num a
, num b
);
647 static int num_gt (num a
, num b
);
648 static int num_ge (num a
, num b
);
649 static int num_lt (num a
, num b
);
650 static int num_le (num a
, num b
);
653 static double round_per_R5RS (double x
);
656 /*_ , Lists and vectors */
657 FORWARD_DECL_PRED (extern, is_finite_list
);
658 FORWARD_DECL_PRED (extern, is_countable_list
);
659 extern int list_length (pko a
);
660 static pko
reverse (klink
* sc
, pko a
);
661 static pko
unsafe_v2reverse_in_place (pko term
, pko list
);
662 static pko
append (klink
* sc
, pko a
, pko b
);
664 static pko
alloc_basvector (int len
, _kt_tag t_enum
);
665 static void unsafe_basvector_fill (pko vec
, pko obj
);
667 static pko
mk_vector (int len
, pko fill
);
668 INTERFACE
static void fill_vector (pko vec
, pko obj
);
669 INTERFACE
static pko
vector_elem (pko vec
, int ielem
);
670 INTERFACE
static void set_vector_elem (pko vec
, int ielem
, pko a
);
671 INTERFACE
static int vector_len (pko vec
);
673 get_list_metrics_aux (pko a
, int4 presults
);
676 k_counted_map_car(klink
* sc
, int count
, pko list
, _kt_tag t_enum
);
678 k_counted_map_cdr(klink
* sc
, int count
, pko list
, _kt_tag t_enum
);
681 static pko
port_from_filename (const char *fn
, int prop
);
682 static pko
port_from_file (FILE *, int prop
);
683 static pko
port_from_string (char *start
, char *past_the_end
, int prop
);
684 static void port_close (pko p
, int flag
);
685 static void port_finalize_file(GC_PTR obj
, GC_PTR client_data
);
686 static port
*port_rep_from_filename (const char *fn
, int prop
);
687 static port
*port_rep_from_file (FILE *, int prop
);
688 static port
*port_rep_from_string (char *start
, char *past_the_end
, int prop
);
689 static void port_close_port (port
* pt
, int flag
);
690 INLINE port
* portvalue (pko p
);
691 static int basic_inchar (port
* pt
);
692 static int inchar (port
*pt
);
693 static void backchar (port
* pt
, int c
);
695 FORWARD_DECL_APPLICATIVE (extern,ps0a1
, mk_typecheck
);
696 FORWARD_DECL_APPLICATIVE (extern,ps0a1
, mk_destructurer
);
697 FORWARD_DECL_CFUNC (extern, ps0a5
, destructure_resume
);
698 FORWARD_DECL_PRED (extern, is_any
);
699 FORWARD_DECL_T_PRED (extern, is_environment
);
700 FORWARD_DECL_PRED (extern, is_integer
);
702 FORWARD_DECL_CFUNC (extern,ps0a2
,handle_promise_result
);
703 FORWARD_DECL_CFUNC (extern, ps0a1
, mk_promise_lazy
);
704 FORWARD_DECL_APPLICATIVE (extern, ps0a1
, force
);
705 /*_ , About encapsulation */
706 FORWARD_DECL_CFUNC (static,b00a2
, is_encap
);
707 FORWARD_DECL_CFUNC (static,p00a2
, mk_encap
);
708 FORWARD_DECL_CFUNC (static,ps0a2
, unencap
);
709 FORWARD_DECL_APPLICATIVE (extern,p00a0
, mk_encapsulation_type
);
711 /*_ , About combiners per se */
712 FORWARD_DECL_PRED(extern,is_combiner
);
713 /*_ , About operatives */
714 FORWARD_DECL_PRED(extern,is_operative
);
716 schedule_rv_list(klink
* sc
, pko list
);
718 /*_ , About applicatives */
720 FORWARD_DECL_PRED(extern,is_applicative
);
721 FORWARD_DECL_APPLICATIVE(extern,p00a1
,wrap
);
722 FORWARD_DECL_APPLICATIVE(extern,ps0a1
,unwrap
);
723 FORWARD_DECL_APPLICATIVE(extern,p00a1
,unwrap_all
);
725 /*_ , About currying */
730 static pko
dcrry_2A01VLL (klink
* sc
, pko args
, pko value
);
731 static pko
dcrry_3A01dotVLL (klink
* sc
, pko args
, pko value
);
732 static pko
dcrry_2CA01VLLA02 (klink
* sc
, pko args
, pko value
);
733 /* May not be needed */
734 static pko
dcrry_3A01A02VLL (klink
* sc
, pko args
, pko value
);
735 static pko
dcrry_2ALLVLL (klink
* sc
, pko args
, pko value
);
736 static pko
dcrry_2ALLV01 (klink
* sc
, pko args
, pko value
);
738 static pko
dcrry_NdotALL (klink
* sc
, pko args
, pko value
);
739 #define dcrry_1A01 dcrry_NdotALL
740 #define dcrry_1dotALL dcrry_NdotALL
741 #define dcrry_2dotALL dcrry_NdotALL
742 #define dcrry_3dotALL dcrry_NdotALL
743 #define dcrry_4dotALL dcrry_NdotALL
745 static pko
dcrry_1ALL (klink
* sc
, pko args
, pko value
);
747 static pko
dcrry_5ALLdotVLL (klink
* sc
, pko args
, pko value
);
748 #define dcrry_3ALLdotVLL dcrry_5ALLdotVLL
750 static pko
dcrry_NVLLdotALL (klink
* sc
, pko args
, pko value
);
751 #define dcrry_2VLLdotALL dcrry_NVLLdotALL
752 #define dcrry_3VLLdotALL dcrry_NVLLdotALL
753 #define dcrry_4VLLdotALL dcrry_NVLLdotALL
754 #define dcrry_5VLLdotALL dcrry_NVLLdotALL
756 static pko
dcrry_1VLL (klink
* sc
, pko args
, pko value
);
757 static pko
dcrry_NCVLLA01dotAX1 (klink
* sc
, pko args
, pko value
);
758 #define dcrry_2CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
759 #define dcrry_3CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
760 #define dcrry_4CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
761 #define dcrry_5CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
763 FORWARD_DECL_CFUNC(static,ps0a4
,values_pair
);
766 /*_ , Of Kernel evaluation */
767 /*_ . Public functions */
768 FORWARD_DECL_APPLICATIVE(extern,ps0a2
,kernel_eval
);
769 FORWARD_DECL_CFUNC (extern,ps0a3
, vau_1
);
770 /*_ . Other signatures */
771 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_eval_aux
);
772 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_mapeval
);
773 FORWARD_DECL_APPLICATIVE(static,ps0a3
, kernel_mapand_aux
);
774 FORWARD_DECL_APPLICATIVE(extern,ps0a2
, kernel_mapand
);
775 FORWARD_DECL_APPLICATIVE(static,ps0a5
,eval_vau
);
779 FORWARD_DECL_APPLICATIVE(static,ps0a0
,kernel_read_internal
);
780 FORWARD_DECL_CFUNC(extern,ps0a0
,kernel_read_sexp
);
781 FORWARD_DECL_CFUNC(static,ps0a2
,kernel_read_list
);
782 FORWARD_DECL_CFUNC(static,ps0a2
,kernel_treat_dotted_list
);
783 FORWARD_DECL_CFUNC(static,ps0a1
,kernel_treat_qquoted_vec
);
785 static INLINE
int is_one_of (char *s
, int c
);
786 static long binary_decode (const char *s
);
787 static char *readstr_upto (klink
* sc
, char *delim
);
788 static pko
readstrexp (klink
* sc
);
789 static INLINE
int skipspace (klink
* sc
);
790 static int token (klink
* sc
);
791 static pko
mk_atom (klink
* sc
, char *q
);
792 static pko
mk_sharp_const (char *name
);
795 /* $$IMPROVE ME These should mostly be just operatives. */
796 FORWARD_DECL_APPLICATIVE(static,ps0a2
,kernel_print_sexp
);
797 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_print_sexp_aux
);
798 FORWARD_DECL_APPLICATIVE(static,ps0a3
,kernel_print_list
);
799 FORWARD_DECL_APPLICATIVE(static,ps0a4
,kernel_print_vec_from
);
800 static kt_boxed_curried k_print_terminate_list
;
802 static void printslashstring (klink
* sc
, char *s
, int len
);
803 static void atom2str (klink
* sc
, pko l
, char **pp
, int *plen
);
804 static void printatom (klink
* sc
, pko l
);
806 /*_ , Stack & continuations */
807 /*_ . Continuations */
808 static pko
mk_continuation (_kt_spagstack d
);
809 static void klink_push_cont (klink
* sc
, pko combiner
);
811 klink_push_cont_aux (_kt_spagstack old_frame
, pko ff
, pko env
);
812 FORWARD_DECL_APPLICATIVE(extern,p00a1
,continuation_to_applicative
);
813 FORWARD_DECL_CFUNC(static,vs0a2
,invoke_continuation
);
814 FORWARD_DECL_CFUNC(static,ps0a2
,continue_abnormally
);
815 static _kt_spagstack special_dynxtnt
816 (_kt_spagstack outer
, _kt_spagstack prox_dest
, pko envir
);
820 /*_ . Dynamic bindings */
821 static void klink_push_dyn_binding (klink
* sc
, pko id
, pko value
);
822 static pko
klink_find_dyn_binding(klink
* sc
, pko id
);
824 struct stack_profiling
;
826 k_profiling_done_frame(klink
* sc
, struct stack_profiling
* profile
);
829 get_nth_arg( _kt_spagstack frame
, int n
);
831 push_arg (klink
* sc
, pko value
);
833 /*_ , Environment and defining */
834 FORWARD_DECL_CFUNC(static,vs0a3
,kernel_define_tree
);
835 FORWARD_DECL_CFUNC(extern,p00a3
,kernel_define
);
836 FORWARD_DECL_CFUNC(extern,ps0a2
,eval_define
);
837 FORWARD_DECL_CFUNC(extern,ps0a3
,set
);
838 FORWARD_DECL_CFUNC(static,ps0a4
,set_aux
);
840 static pko
find_slot_in_env (pko env
, pko sym
, int all
);
841 static INLINE pko
slot_value_in_env (pko slot
);
842 static INLINE
void set_slot_in_env (pko slot
, pko value
);
844 reverse_find_slot_in_env_aux (pko env
, pko value
);
845 /*_ . Standard environment */
846 FORWARD_DECL_CFUNC(extern,p00a0
, mk_std_environment
);
847 FORWARD_DECL_APPLICATIVE (extern,ps0a0
, get_current_environment
);
848 /*_ , Misc kernel functions */
850 FORWARD_DECL_CFUNC(extern,ps0a1
,arg1
);
851 FORWARD_DECL_APPLICATIVE(extern,ps0a1
,val2val
)
853 /*_ , Error functions */
854 FORWARD_DECL_CFUNC(static,ps0a1
,kernel_err
);
855 FORWARD_DECL_CFUNC(static,ps0a1
,kernel_err_x
);
857 /*_ , For DL if present */
859 FORWARD_DECL_APPLICATIVE(extern,ps0a1
,klink_load_ext
);
863 static pko
mk_symbol_obj (const char *name
);
866 static char *store_string (int len
, const char *str
, char fill
);
868 /*_ . Object declarations */
870 /* These objects are declared here because some macros use them, but
871 should not be directly used. */
872 /* $$IMPROVE ME Somehow hide these better without hiding it from the
873 applicative & destructure macros. */
874 kt_boxed_void
KEY(K_APPLICATIVE
);
875 kt_boxed_void
KEY(K_NIL
);
877 kt_boxed_destr_list _K_any_singleton
;
878 /*_ , Pointers to base environments */
879 static pko print_lookup_env
;
880 static pko all_builtins_env
;
881 static pko ground_env
;
882 static pko typecheck_env_syms
;
884 static pko print_lookup_unwraps
;
885 static pko print_lookup_to_xary
;
888 /*_ . Low-level treating T-types */
894 WITH_BOX_TYPE(ptype
,p
);
895 return *ptype
& T_MASKTYPE
;
900 is_type (pko p
, int T_index
)
902 return _get_type (p
) == T_index
;
904 /*_ . type_err_string */
906 type_err_string(_kt_tag t_enum
)
911 return "Must be a string";
913 return "Must be a number";
915 return "Must be a symbol";
917 return "Must be a pair";
919 return "Must be a character";
921 return "Must be a port";
923 return "Must be an encapsulation";
925 return "Must be a continuation";
927 return "Must be an environment";
929 return "Must be a recurrence table";
930 case T_RECUR_TRACKER
:
931 return "Must be a recurrence tracker";
933 return "Must be a destructure result";
935 /* Left out types that shouldn't be distinguished in Kernel. */
936 return "Error message for this type needs to be coded";
940 /* If sc is given, it's a assertion making a Kernel error, otherwise
941 it's a C assertion. */
943 assert_type (sc_or_null sc
, pko p
, _kt_tag t_enum
)
945 if(sc
&& (_get_type(p
) != (t_enum
)))
947 const char * err_msg
= type_err_string(t_enum
);
948 _klink_error_1(sc
,err_msg
,p
);
949 return; /* NOTREACHED */
952 { assert (_get_type(p
) == (t_enum
)); }
960 WITH_BOX_TYPE(ptype
,p
);
961 return *ptype
& T_IMMUTABLE
;
964 INTERFACE INLINE
void
967 WITH_BOX_TYPE(ptype
,p
);
968 *ptype
|= T_IMMUTABLE
;
971 /* If sc is given, it's a assertion making a Kernel error, otherwise
972 it's a C assertion. */
974 assert_mutable (sc_or_null sc
, pko p
)
976 WITH_BOX_TYPE(ptype
,p
);
977 if(sc
&& (*ptype
& T_IMMUTABLE
))
979 _klink_error_1(sc
,"Attempt to mutate immutable object",p
);
983 { assert(!(*ptype
& T_IMMUTABLE
)); }
986 #define DEBUG_assert_mutable assert_mutable
988 /*_ , No-call-Kernel */
992 WITH_BOX_TYPE(ptype
,p
);
993 return *ptype
& T_NO_K
;
996 SIG_CHKARRAY(eqp
) = { K_ANY
, K_ANY
, };
997 DEF_SIMPLE_APPLICATIVE(p00a2
,eqp
,T_NO_K
,ground
,"eq?")
1000 return kernel_bool(a
== b
);
1002 /*_ . Low-level object types */
1003 /*_ , vec2 (Low lists) */
1010 typedef BOX_OF(kt_vec2
) boxed_vec2
;
1012 /*_ . Type assert */
1013 /* $$IMPROVE ME Disable this if DEBUG_LEVEL is low */
1014 void assert_T_is_v2(_kt_tag t_enum
)
1016 t_enum
&= T_MASKTYPE
;
1019 || t_enum
== T_ENV_PAIR
1020 || t_enum
== T_ENV_FRAME
1021 || t_enum
== T_PROMISE
1022 || t_enum
== T_DESTR_RESULT
1028 v2cons (_kt_tag t_enum
, pko a
, pko b
)
1030 ALLOC_BOX_PRESUME (kt_vec2
, t_enum
);
1031 pbox
->data
._car
= a
;
1032 pbox
->data
._cdr
= b
;
1033 return PTR2PKO(pbox
);
1036 /*_ . Unsafe operations (Typechecks can be disabled) */
1038 unsafe_v2car (pko p
)
1040 assert_T_is_v2(_get_type(p
));
1041 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1046 unsafe_v2cdr (pko p
)
1048 assert_T_is_v2(_get_type(p
));
1049 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1054 unsafe_v2set_car (pko p
, pko q
)
1056 assert_T_is_v2(_get_type(p
));
1057 DEBUG_assert_mutable(0,p
);
1058 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1064 unsafe_v2set_cdr (pko p
, pko q
)
1066 assert_T_is_v2(_get_type(p
));
1067 DEBUG_assert_mutable(0,p
);
1068 WITH_UNBOXED_UNSAFE(pdata
,kt_vec2
,p
);
1073 /*_ . Checked operations */
1075 v2car (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
)
1077 assert_type(err_reporter
,p
,t_enum
);
1078 return unsafe_v2car(p
);
1082 v2cdr (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
)
1084 assert_type(err_reporter
,p
,t_enum
);
1085 return unsafe_v2cdr(p
);
1089 v2set_car (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
, pko q
)
1091 assert_type(err_reporter
,p
,t_enum
);
1092 assert_mutable(err_reporter
,p
);
1093 unsafe_v2set_car(p
,q
);
1098 v2set_cdr (sc_or_null err_reporter
, _kt_tag t_enum
, pko p
, pko q
)
1100 assert_type(err_reporter
,p
,t_enum
);
1101 assert_mutable(err_reporter
,p
);
1102 unsafe_v2set_cdr(p
,q
);
1106 /*_ . "Psychic" macros */
1107 #define WITH_V2(T_ENUM) \
1108 _kt_tag _t_enum = T_ENUM; \
1109 assert_T_is_v2(_t_enum)
1111 /* These expect WITH_REPORTER and WITH_V2 to be used in scope. */
1112 #define PSYC_v2cons(A,B) v2cons (_t_enum, (A), (B))
1113 #define PSYC_v2car(X) v2car (_err_reporter, _t_enum, (X))
1114 #define PSYC_v2cdr(X) v2cdr (_err_reporter, _t_enum, (X))
1115 #define PSYC_v2set_car(A,B) v2set_car (_err_reporter, _t_enum, (A), (B))
1116 #define PSYC_v2set_cdr(A,B) v2set_cdr (_err_reporter, _t_enum, (A), (B))
1118 /*_ . Container macros */
1120 /* This expects _EXPLORE_FUNC to be defined as a macro taking OBJ,
1121 inspecting it but not mutating it. */
1122 #define EXPLORE_v2(OBJ) \
1124 WITH_UNBOXED_UNSAFE(pdata,kt_vec2,OBJ); \
1125 _EXPLORE_FUNC(pdata->_car); \
1126 _EXPLORE_FUNC(pdata->_cdr); \
1129 /* #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data) */
1131 /*_ . Low list operations */
1132 /*_ , v2list_star */
1133 pko
v2list_star(sc_or_null sc
, pko d
, _kt_tag t_enum
)
1138 pko cdr_d
= PSYC_v2cdr (d
);
1141 return PSYC_v2car (d
);
1143 p
= PSYC_v2cons (PSYC_v2car (d
), cdr_d
);
1146 while (PSYC_v2cdr (PSYC_v2cdr (p
)) != K_NIL
)
1148 pko cdr_p
= PSYC_v2cdr (p
);
1149 d
= PSYC_v2cons (PSYC_v2car (p
), cdr_p
);
1150 if (PSYC_v2cdr (cdr_p
) != K_NIL
)
1155 PSYC_v2set_cdr (p
, PSYC_v2car (PSYC_v2cdr (p
)));
1159 /*_ , reverse list -- produce new list */
1160 pko
v2reverse(pko a
, _kt_tag t_enum
)
1164 for (; is_type (a
, t_enum
); a
= unsafe_v2cdr (a
))
1166 p
= v2cons (t_enum
, unsafe_v2car (a
), p
);
1171 /*_ , reverse list -- in-place (Not typechecked) */
1172 /* last_cdr will be the tail of the resulting list. It is usually
1175 list is the list to be reversed. Caller guarantees that list is a
1176 proper list, each link being either some type of vec2 or K_NIL.
1179 unsafe_v2reverse_in_place (pko last_cdr
, pko list
)
1181 pko p
= list
, result
= last_cdr
;
1184 pko scratch
= unsafe_v2cdr (p
);
1185 unsafe_v2set_cdr (p
, result
);
1191 /*_ , append list -- produce new list */
1192 pko
v2append(sc_or_null err_reporter
, pko a
, pko b
, _kt_tag t_enum
)
1199 a
= v2reverse (a
, t_enum
);
1200 /* Correct even if b is nil or a non-list. */
1201 return unsafe_v2reverse_in_place(b
, a
);
1206 /*_ , basvectors (Low vectors) */
1208 /* Above so it can be visible to early typecheck declarations. */
1209 /*_ . Type assert */
1210 void assert_T_is_basvector(_kt_tag t_enum
)
1212 t_enum
&= T_MASKTYPE
;
1214 t_enum
== T_VECTOR
||
1215 t_enum
== T_TYPECHECK
||
1216 t_enum
== T_DESTRUCTURE
1221 /*_ , rough_basvec_init */
1222 /* Create the elements but don't assign to them. */
1224 basvec_init_rough (kt_vector
* pvec
, int len
)
1227 pvec
->els
= (pko
*)GC_MALLOC ((sizeof (pko
) * len
));
1229 /*_ , basvec_init_by_list */
1230 /* Initialize the elements of PVEC with the first LEN elements of
1231 ARGS. ARGS must be a list with at least LEN elements. */
1233 basvec_init_by_list (kt_vector
* pvec
, pko args
)
1237 const int num
= pvec
->len
;
1239 for (x
= args
, i
= 0; i
< num
; x
= cdr (x
), i
++)
1241 assert (is_pair (x
));
1242 pvec
->els
[i
] = car (x
);
1245 /*_ , basvec_init_by_array */
1246 /* Initialize the elements of PVEC with the first LEN elements of
1247 ARRAY. ARRAY must be an array with at least LEN elements. */
1249 basvec_init_by_array (kt_vector
* pvec
, pko
* array
)
1252 const int num
= pvec
->len
;
1253 for (i
= 0; i
< num
; i
++)
1255 pvec
->els
[i
] = array
[i
];
1258 /*_ , basvec_init_by_single */
1260 basvec_init_by_single (kt_vector
* pvec
, pko obj
)
1263 const int num
= pvec
->len
;
1265 for (i
= 0; i
< num
; i
++)
1266 { pvec
->els
[i
] = obj
; }
1269 /*_ , Get element */
1271 basvec_get_element (kt_vector
* pvec
, int index
)
1274 assert(index
< pvec
->len
);
1275 return pvec
->els
[index
];
1279 basvec_fill_array(kt_vector
* pvec
, int max_len
, pko
* array
)
1282 const int num
= pvec
->len
;
1284 assert (num
<= max_len
);
1285 for (i
= 0; i
< num
; i
++)
1287 array
[i
] = pvec
->els
[i
];
1293 basvec_set_element (kt_vector
* pvec
, int index
, pko obj
)
1296 assert(index
< pvec
->len
);
1297 pvec
->els
[index
] = obj
;
1300 /*_ . Treat as boxed */
1301 /* Functions following here assume that kt_vector is in a box by itself. */
1302 /*_ , alloc_basvector */
1304 alloc_basvector (int len
, _kt_tag t_enum
)
1306 assert_T_is_basvector(t_enum
);
1307 ALLOC_BOX_PRESUME(kt_vector
, t_enum
);
1308 basvec_init_rough(&pbox
->data
, len
);
1309 return PTR2PKO(pbox
);
1311 /*_ , mk_basvector_w_args */
1313 mk_basvector_w_args(klink
* sc
, pko args
, _kt_tag t_enum
)
1315 assert_T_is_basvector(t_enum
);
1317 get_list_metrics_aux(args
, metrics
);
1318 if (metrics
[lm_num_nils
] != 1)
1320 KERNEL_ERROR_1 (sc
, "mk_basvector_w_args: not a proper list:", args
);
1322 int len
= metrics
[lm_acyc_len
];
1323 pko vec
= alloc_basvector(len
, t_enum
);
1324 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1325 basvec_init_by_list (pdata
, args
);
1328 /*_ , mk_filled_basvector */
1330 mk_filled_basvector(int len
, pko fill
, _kt_tag t_enum
)
1332 assert_T_is_basvector(t_enum
);
1333 pko vec
= alloc_basvector(len
, t_enum
);
1334 unsafe_basvector_fill (vec
, fill
);
1337 /*_ , mk_basvector_from_array */
1339 mk_basvector_from_array(int len
, pko
* array
, _kt_tag t_enum
)
1341 assert_T_is_basvector(t_enum
);
1342 pko vec
= alloc_basvector(len
, t_enum
);
1343 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1344 basvec_init_by_array (pdata
, array
);
1347 /*_ , mk_foresliced_basvector */
1349 mk_foresliced_basvector (pko vec
, int excess
, _kt_tag t_enum
)
1351 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1352 const int len
= pdata
->len
;
1353 assert (len
>= excess
);
1354 const int remnant_len
= len
- excess
;
1355 return mk_basvector_from_array (remnant_len
,
1356 pdata
->els
+ excess
,
1359 /*_ . Unsafe operations (Typechecks can be disabled) */
1360 /*_ , unsafe_basvector_fill */
1362 unsafe_basvector_fill (pko vec
, pko obj
)
1364 assert_T_is_basvector(_get_type(vec
));
1365 assert_mutable(0,vec
);
1366 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1367 basvec_init_by_single (pdata
, obj
);
1369 /*_ , basvector_len */
1371 basvector_len (pko vec
)
1373 assert_T_is_basvector(_get_type(vec
));
1374 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1378 /*_ , basvector_elem */
1380 basvector_elem (pko vec
, int ielem
)
1382 assert_T_is_basvector(_get_type(vec
));
1383 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1384 return basvec_get_element (pdata
, ielem
);
1387 /*_ , basvector_set_elem */
1389 basvector_set_elem (pko vec
, int ielem
, pko a
)
1391 assert_T_is_basvector(_get_type(vec
));
1392 assert_mutable(0,vec
);
1393 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,vec
);
1394 basvec_set_element (pdata
, ielem
, a
);
1397 /*_ , basvector_fill_array */
1399 basvector_fill_array(pko vec
, int max_len
, pko
* array
)
1401 assert_T_is_basvector(_get_type(vec
));
1402 WITH_UNBOXED_UNSAFE (p_vec
, kt_vector
, vec
);
1403 basvec_fill_array (p_vec
, max_len
, array
);
1406 /*_ . Checked operations */
1407 /*_ , Basic strings (Low strings) */
1408 /*_ . Struct kt_string */
1418 bastring_value (sc_or_null sc
, _kt_tag t_enum
, pko p
)
1420 WITH_PSYC_UNBOXED(kt_string
,p
, t_enum
, sc
);
1421 return pdata
->_svalue
;
1425 bastring_len (sc_or_null sc
, _kt_tag t_enum
, pko p
)
1427 WITH_PSYC_UNBOXED(kt_string
,p
, t_enum
, sc
);
1428 return pdata
->_length
;
1434 store_string (int len_str
, const char *str
, char fill
)
1438 q
= (char *) GC_MALLOC_ATOMIC (len_str
+ 1);
1441 snprintf (q
, len_str
+ 1, "%s", str
);
1445 memset (q
, fill
, len_str
);
1452 mk_bastring (_kt_tag t_enum
, const char *str
, int len
, char fill
)
1454 ALLOC_BOX_PRESUME (kt_string
, t_enum
);
1455 pbox
->data
._svalue
= store_string(len
, str
, fill
);
1456 pbox
->data
._length
= len
;
1457 return PTR2PKO(pbox
);
1460 /*_ . Type assert */
1461 void assert_T_is_bastring(_kt_tag t_enum
)
1463 t_enum
&= T_MASKTYPE
;
1465 t_enum
== T_STRING
||
1466 t_enum
== T_SYMBOL
);
1469 /*_ . Individual object types */
1475 DEF_SIMPLE_PRED(is_bool
,T_NO_K
,ground
, "boolean?/o1")
1478 return (p
== K_T
) || (p
== K_F
);
1481 SIG_CHKARRAY(not) = { REF_OPER(is_bool
), };
1482 DEF_SIMPLE_APPLICATIVE(p00a1
,not,T_NO_K
,ground
, "not?")
1485 if(p
== K_T
) { return K_F
; }
1486 if(p
== K_F
) { return K_T
; }
1487 errx(6, "not: Argument must be boolean");
1491 /*_ . Number constants */
1493 /* We would use these for "folding" operations like cumulative addition. */
1494 static num num_zero
= { 1, {0}, };
1495 static num num_one
= { 1, {1}, };
1498 #define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
1499 #define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
1501 /*_ . Making them */
1504 mk_integer (long num
)
1506 ALLOC_BOX_PRESUME (struct num
, T_NUMBER
);
1507 pbox
->data
.value
.ivalue
= num
;
1508 pbox
->data
.is_fixnum
= 1;
1509 return PTR2PKO(pbox
);
1515 ALLOC_BOX_PRESUME (num
, T_NUMBER
);
1516 pbox
->data
.value
.rvalue
= n
;
1517 pbox
->data
.is_fixnum
= 0;
1518 return PTR2PKO(pbox
);
1526 return mk_integer (n
.value
.ivalue
);
1530 return mk_real (n
.value
.rvalue
);
1534 /*_ . Checking them */
1535 static int is_zero_double (double x
);
1538 num_is_integer (pko p
)
1540 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1541 return (pdata
->is_fixnum
);
1544 DEF_T_PRED (is_number
,T_NUMBER
,ground
,"number?/o1");
1546 DEF_SIMPLE_PRED (is_posint
,T_NO_K
,ground
,"posint?/o1")
1549 return is_integer (p
) && ivalue (p
) >= 0;
1552 /* $$IMPROVE ME later Integer and real should be separate T_ types. */
1553 DEF_SIMPLE_PRED (is_integer
,T_NO_K
,ground
, "integer?/o1")
1556 if(!is_number (p
)) { return 0; }
1557 WITH_UNBOXED_UNSAFE(pdata
,num
,p
);
1558 return (pdata
->is_fixnum
);
1561 DEF_SIMPLE_PRED (is_real
,T_NO_K
,ground
, "real?/o1")
1564 if(!is_number (p
)) { return 0; }
1565 WITH_UNBOXED_UNSAFE(pdata
,num
,p
);
1566 return (!pdata
->is_fixnum
);
1568 DEF_SIMPLE_PRED (is_zero
,T_NO_K
,ground
, "zero?/o1")
1571 /* Behavior on non-numbers wasn't specified so I'm assuming the
1572 predicate just fails. */
1573 if(!is_number (p
)) { return 0; }
1574 WITH_UNBOXED_UNSAFE(pdata
,num
,p
);
1575 if(pdata
->is_fixnum
)
1577 return (ivalue (p
) == 0);
1581 return is_zero_double(rvalue(p
));
1584 /* $$WRITE ME positive? negative? odd? even? */
1585 /*_ . Getting their values */
1589 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1596 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1597 return (num_is_integer (p
) ? pdata
->value
.ivalue
: (long) pdata
->
1604 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1605 return (!num_is_integer (p
)
1606 ? pdata
->value
.rvalue
: (double) pdata
->value
.ivalue
);
1610 set_ivalue (pko p
, long i
)
1612 assert_mutable(0,p
);
1613 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1614 assert (num_is_integer (p
));
1615 pdata
->value
.ivalue
= i
;
1620 add_to_ivalue (pko p
, long i
)
1622 assert_mutable(0,p
);
1623 WITH_PSYC_UNBOXED(num
,p
,T_NUMBER
,0);
1624 assert (num_is_integer (p
));
1625 pdata
->value
.ivalue
+= i
;
1629 /*_ . Operating on numbers */
1631 num_add (num a
, num b
)
1634 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1637 ret
.value
.ivalue
= a
.value
.ivalue
+ b
.value
.ivalue
;
1641 ret
.value
.rvalue
= num_rvalue (a
) + num_rvalue (b
);
1647 num_mul (num a
, num b
)
1650 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1653 ret
.value
.ivalue
= a
.value
.ivalue
* b
.value
.ivalue
;
1657 ret
.value
.rvalue
= num_rvalue (a
) * num_rvalue (b
);
1663 num_div (num a
, num b
)
1666 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
1667 && a
.value
.ivalue
% b
.value
.ivalue
== 0;
1670 ret
.value
.ivalue
= a
.value
.ivalue
/ b
.value
.ivalue
;
1674 ret
.value
.rvalue
= num_rvalue (a
) / num_rvalue (b
);
1680 num_intdiv (num a
, num b
)
1683 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1686 ret
.value
.ivalue
= a
.value
.ivalue
/ b
.value
.ivalue
;
1690 ret
.value
.rvalue
= num_rvalue (a
) / num_rvalue (b
);
1696 num_sub (num a
, num b
)
1699 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1702 ret
.value
.ivalue
= a
.value
.ivalue
- b
.value
.ivalue
;
1706 ret
.value
.rvalue
= num_rvalue (a
) - num_rvalue (b
);
1712 num_rem (num a
, num b
)
1716 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1717 e1
= num_ivalue (a
);
1718 e2
= num_ivalue (b
);
1720 /* modulo should have same sign as second operand */
1735 ret
.value
.ivalue
= res
;
1740 num_mod (num a
, num b
)
1744 ret
.is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1745 e1
= num_ivalue (a
);
1746 e2
= num_ivalue (b
);
1749 { /* modulo should have same sign as second operand */
1760 ret
.value
.ivalue
= res
;
1765 num_eq (num a
, num b
)
1768 int is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1771 ret
= a
.value
.ivalue
== b
.value
.ivalue
;
1775 ret
= num_rvalue (a
) == num_rvalue (b
);
1782 num_gt (num a
, num b
)
1785 int is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1788 ret
= a
.value
.ivalue
> b
.value
.ivalue
;
1792 ret
= num_rvalue (a
) > num_rvalue (b
);
1798 num_ge (num a
, num b
)
1800 return !num_lt (a
, b
);
1804 num_lt (num a
, num b
)
1807 int is_fixnum
= a
.is_fixnum
&& b
.is_fixnum
;
1810 ret
= a
.value
.ivalue
< b
.value
.ivalue
;
1814 ret
= num_rvalue (a
) < num_rvalue (b
);
1820 num_le (num a
, num b
)
1822 return !num_gt (a
, b
);
1826 /* Round to nearest. Round to even if midway */
1828 round_per_R5RS (double x
)
1830 double fl
= floor (x
);
1831 double ce
= ceil (x
);
1832 double dfl
= x
- fl
;
1833 double dce
= ce
- x
;
1844 if (fmod (fl
, 2.0) == 0.0)
1845 { /* I imagine this holds */
1857 is_zero_double (double x
)
1859 return x
< DBL_MIN
&& x
> -DBL_MIN
;
1863 binary_decode (const char *s
)
1867 while (*s
!= 0 && (*s
== '1' || *s
== '0'))
1877 /* "Psychically" defines a and b. */
1878 #define WITH_PSYC_AB_ARGS(A_TYPE,B_TYPE) \
1879 WITH_UNBOXED_UNSAFE(a,A_TYPE,arg1); \
1880 WITH_UNBOXED_UNSAFE(b,B_TYPE,arg2)
1884 /*_ . Binary operations */
1885 SIG_CHKARRAY(num_binop
) = { REF_OPER(is_number
), REF_OPER(is_number
), };
1886 DEF_SIMPLE_DESTR(num_binop
);
1888 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_add
,REF_DESTR(num_binop
),0,ground
, "add")
1890 WITH_PSYC_AB_ARGS(num
,num
);
1891 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1892 *pdata
= num_add (*a
, *b
);
1893 return PTR2PKO(pbox
);
1896 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_sub
,REF_DESTR(num_binop
),0,ground
, "sub")
1898 WITH_PSYC_AB_ARGS(num
,num
);
1899 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1900 *pdata
= num_sub (*a
, *b
);
1901 return PTR2PKO(pbox
);
1904 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_mul
,REF_DESTR(num_binop
),0,ground
, "mul")
1906 WITH_PSYC_AB_ARGS(num
,num
);
1907 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1908 *pdata
= num_mul (*a
, *b
);
1909 return PTR2PKO(pbox
);
1912 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_div
,REF_DESTR(num_binop
),0,ground
, "div")
1914 WITH_PSYC_AB_ARGS(num
,num
);
1915 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1916 *pdata
= num_div (*a
, *b
);
1917 return PTR2PKO(pbox
);
1920 DEF_APPLICATIVE_W_DESTR(ps0a2
,k_mod
,REF_DESTR(num_binop
),0,ground
, "mod")
1922 WITH_PSYC_AB_ARGS(num
,num
);
1923 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1924 *pdata
= num_mod (*a
, *b
);
1925 return PTR2PKO(pbox
);
1927 /*_ . Binary predicates */
1928 DEF_APPLICATIVE_W_DESTR(bs0a2
,k_gt
,REF_DESTR(num_binop
),0,ground
, ">?/2")
1930 WITH_PSYC_AB_ARGS(num
,num
);
1931 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1932 return num_gt (*a
, *b
);
1935 DEF_APPLICATIVE_W_DESTR(bs0a2
,k_eq
,REF_DESTR(num_binop
),0,simple
, "equal?/2-num-num")
1937 WITH_PSYC_AB_ARGS(num
,num
);
1938 ALLOC_BOX_PRESUME(num
,T_NUMBER
);
1939 return num_eq (*a
, *b
);
1944 DEF_T_PRED (is_character
,T_CHARACTER
,ground
, "character?/o1");
1949 WITH_PSYC_UNBOXED(long,p
,T_CHARACTER
,0);
1954 mk_character (int c
)
1956 ALLOC_BOX_PRESUME (long, T_CHARACTER
);
1958 return PTR2PKO(pbox
);
1961 /*_ . Classifying characters */
1962 #if USE_CHAR_CLASSIFIERS
1966 return isascii (c
) && isalpha (c
);
1972 return isascii (c
) && isdigit (c
);
1978 return isascii (c
) && isspace (c
);
1984 return isascii (c
) && isupper (c
);
1990 return isascii (c
) && islower (c
);
1993 /*_ . Character names */
1995 static const char *charnames
[32] = {
2031 is_ascii_name (const char *name
, int *pc
)
2034 for (i
= 0; i
< 32; i
++)
2036 if (stricmp (name
, charnames
[i
]) == 0)
2042 if (stricmp (name
, "del") == 0)
2052 /*_ , Void objects */
2054 DEF_T_PRED (is_key
, T_KEY
,no
,"");
2058 BOX_OF_VOID (K_NIL
);
2059 BOX_OF_VOID (K_EOF
);
2060 BOX_OF_VOID (K_INERT
);
2061 BOX_OF_VOID (K_IGNORE
);
2062 /*_ . "Secret" objects for built-in keyed dynamic bindings */
2063 BOX_OF_VOID (K_PRINT_FLAG
);
2064 BOX_OF_VOID (K_TRACING
);
2065 BOX_OF_VOID (K_INPORT
);
2066 BOX_OF_VOID (K_OUTPORT
);
2067 BOX_OF_VOID (K_NEST_DEPTH
);
2068 /*_ . Keys for typecheck */
2069 BOX_OF_VOID (K_TYCH_DOT
);
2070 BOX_OF_VOID (K_TYCH_REPEAT
);
2071 BOX_OF_VOID (K_TYCH_OPTIONAL
);
2072 BOX_OF_VOID (K_TYCH_IMP_REPEAT
);
2073 BOX_OF_VOID (K_TYCH_NO_TYPE
);
2075 /*_ . Making them dynamically */
2076 DEF_CFUNC(p00a0
, mk_void
, K_NO_TYPE
,T_NO_K
)
2078 ALLOC_BOX(pbox
,T_KEY
,kt_boxed_void
);
2079 return PTR2PKO(pbox
);
2082 DEF_SIMPLE_PRED(is_null
,T_NO_K
,ground
, "null?/o1")
2087 DEF_SIMPLE_PRED(is_inert
,T_NO_K
,ground
, "inert?/o1")
2090 return p
== K_INERT
;
2092 DEF_SIMPLE_PRED(is_ignore
,T_NO_K
,ground
, "ignore?/o1")
2095 return p
== K_IGNORE
;
2099 /*_ , Typecheck & destructure objects */
2101 /* _car is vector component, _cdr is list component. */
2102 typedef kt_vec2 kt_destr_result
;
2103 /*_ . Enumeration */
2111 DEF_T_PRED (is_destr_result
, T_DESTR_RESULT
, no
, "");
2112 /*_ . Building them */
2113 /*_ , can_be_trivpred */
2114 /* Return true if the object can be used as a trivial predicate: An
2115 xary operative that does not call Kernel and returns a boolean as
2117 DEF_SIMPLE_PRED(can_be_trivpred
,T_NO_K
,unsafe
,"trivpred?/o1")
2120 if(!no_call_k(p
)) { return 0; }
2121 switch(_get_type(p
))
2125 WITH_UNBOXED_UNSAFE(pdata
,kt_cfunc
,p
);
2128 case klink_ftype_b00a1
:
2150 /*_ , k_to_trivpred */
2151 /* Convert a unary or nary function to xary. If not possible, return
2153 /* $$OBSOLESCENT Only used in print lookup, which will change */
2155 k_to_trivpred(pko p
)
2157 if(is_applicative(p
))
2158 { p
= unwrap_all(p
); }
2160 if(can_be_trivpred(p
))
2165 /*_ , type-keys environment */
2166 RGSTR(type
-keys
, "cyclic-repeat", REF_KEY(K_TYCH_IMP_REPEAT
) )
2167 RGSTR(type
-keys
, "optional", REF_KEY(K_TYCH_OPTIONAL
) )
2168 RGSTR(type
-keys
, "repeat", REF_KEY(K_TYCH_REPEAT
) )
2169 RGSTR(type
-keys
, "dot", REF_KEY(K_TYCH_DOT
) )
2171 int any_k (kt_vector
* p_vec_guts
)
2174 for (i
= 0; i
< p_vec_guts
->len
; i
++)
2176 pko obj
= p_vec_guts
->els
[i
];
2177 WITH_BOX_TYPE(tag
,obj
);
2178 if (*tag
| ~(T_NO_K
)) { return 1; }
2184 DEF_APPLICATIVE_W_DESTR (ps0a1
, mk_typecheck
, REF_OPER(is_finite_list
),T_NO_K
,unsafe
, "listtype/N-trivpred")
2186 pko vec
= mk_basvector_w_args(sc
, arg1
, T_TYPECHECK
| T_IMMUTABLE
| T_NO_K
);
2187 #if 0 /* $$ENABLE ME later */
2188 /* If everything is T_NO_K, then give flag T_NO_K. */
2189 WITH_UNBOXED_UNSAFE (pdata
, kt_vector
, vec
);
2192 WITH_BOX_TYPE(tag
,vec
);
2198 /*_ , Destructurer */
2199 DEF_APPLICATIVE_W_DESTR (ps0a1
, mk_destructurer
, REF_OPER(is_finite_list
),T_NO_K
,unsafe
, "destructure-list/N-trivpred")
2201 /* $$IMPROVE MY SUPPORT A destructurer should fill up this */
2203 get_list_metrics_aux(arg1
, metrics
);
2204 if (metrics
[lm_num_nils
] != 1)
2206 KERNEL_ERROR_1 (sc
, "mk_destructurer: not a proper list:", arg1
);
2208 int len
= metrics
[lm_acyc_len
];
2209 ALLOC_BOX_PRESUME(kt_destr_list
, T_DESTRUCTURE
| T_IMMUTABLE
| T_NO_K
);
2210 basvec_init_rough (&pdata
->cvec
, len
);
2211 basvec_init_by_list (&pdata
->cvec
, arg1
);
2212 pdata
->num_targets
= -1;
2214 #if 0 /* $$ENABLE ME later when typemiss check is OK for this */
2215 /* If everything is T_NO_K, then give flag T_NO_K. */
2216 if (!any_k (&pdata
->cvec
))
2218 WITH_BOX_TYPE(tag
,vec
);
2222 return PTR2PKO(pbox
);
2224 /*_ , Destructurer Result state */
2225 /* Really a mixed vector/list */
2226 /*_ . mk_destr_result */
2229 (int len
, pko
* array
, pko more_vals
)
2231 pko vec
= mk_basvector_from_array(len
, array
, T_VECTOR
);
2232 return v2cons (T_DESTR_RESULT
, vec
, more_vals
);
2234 /*_ . mk_destr_result_add */
2237 (pko old
, int len
, pko
* array
)
2239 pko val_list
= unsafe_v2cdr (old
);
2241 for (i
= 0; i
< len
; i
++)
2243 val_list
= cons ( array
[i
], val_list
);
2245 return v2cons (T_DESTR_RESULT
,
2249 /*_ . destr_result_fill_array */
2251 destr_result_fill_array (pko dr
, int max_len
, pko
* array
)
2253 /* Assume errors are due to C code. */
2255 WITH_PSYC_UNBOXED (kt_destr_result
, dr
, T_DESTR_RESULT
, 0)
2257 basvector_len (pdata
->_car
);
2258 basvector_fill_array(pdata
->_car
, vec_len
, array
);
2259 /* We get args earliest lowest, so insert them in reverse order. */
2260 int list_len
= list_length (pdata
->_cdr
);
2261 int i
= vec_len
+ list_len
- 1;
2262 assert (i
< max_len
);
2264 for (args
= pdata
->_cdr
; args
!= K_NIL
; args
= cdr (args
), i
--)
2266 array
[i
] = car (args
);
2270 /*_ , destr_result_to_vec */
2271 SIG_CHKARRAY (destr_result_to_vec
) =
2273 REF_OPER (is_destr_result
),
2276 DEF_SIMPLE_CFUNC (p00a1
, destr_result_to_vec
, T_NO_K
)
2278 WITH_1_ARGS (destr_result
);
2279 WITH_UNBOXED_UNSAFE (p_destr_result
, kt_destr_result
, destr_result
);
2281 basvector_len (p_destr_result
->_car
) +
2282 list_length (p_destr_result
->_cdr
);
2283 pko vec
= mk_vector (len
, K_NIL
);
2284 WITH_UNBOXED_UNSAFE (p_vec
, kt_destr_list
, vec
);
2285 destr_result_fill_array (destr_result
, len
, p_vec
->cvec
.els
);
2289 /*_ . Particular typechecks */
2290 /*_ , Any singleton */
2291 pko _K_ARRAY_any_singleton
[] = { K_ANY
, };
2292 DEF_DESTR(_K_any_singleton
,_K_ARRAY_any_singleton
);
2293 /*_ , Typespec itself */
2294 #define K_TY_TYPESPEC K_ANY
2295 /*_ , Destructure spec itself */
2296 #define K_TY_DESTRSPEC K_ANY
2297 /*_ , Top type (Always succeeds) */
2298 RGSTR(ground
, "true/o1", REF_OPER(is_any
))
2299 DEF_CFUNC(b00a1
,is_any
,K_ANY_SINGLETON
,T_NO_K
)
2302 /* Not entirely redundant; Used internally to check scheduled returns. */
2303 DEF_CFUNC(b00a1
,is_true
,K_ANY_SINGLETON
,T_NO_K
)
2309 /*_ . Internal signatures */
2312 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
);
2314 where_typemiss_repeat
2315 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
);
2317 static where_typemiss_do_spec
2318 (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
);
2320 typecheck_by_vec (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
);
2322 /*_ . Typecheck operations */
2324 call_T_typecheck(pko T
, pko obj
)
2326 WITH_PSYC_UNBOXED(typep_t
,T
,T_TYPEP
,0);
2327 return is_type(obj
,pdata
->T_tag
);
2330 /* This is an optimization under-the-hood for running
2331 possibly-compound predicates. Ultimately it will not be exposed.
2332 Later it may have a Kernel "safe counterpart" that is optimized to
2335 It should not call anything that calls Kernel. All its
2336 "components" should be trivpreds (xary operatives that don't use
2337 eval loop), satisfying can_be_trivpred, generally specified
2339 /* We don't have a typecheck typecheck predicate yet, so accept
2340 anything for arg2. */
2341 SIG_CHKARRAY(typecheck
) = { K_ANY
, K_ANY
, };
2342 DEF_SIMPLE_APPLICATIVE (bs0a2
, typecheck
,T_NO_K
,unsafe
,"type?")
2344 WITH_2_ARGS(argobject
,typespec
);
2345 assert(no_call_k(typespec
));
2346 switch(_get_type(typespec
))
2350 WITH_UNBOXED_UNSAFE(pdata
,kt_cfunc
,typespec
);
2353 case klink_ftype_b00a1
:
2355 return pdata
->func
.f_b00a1(argobject
);
2358 errx(7, "typecheck: Object is not a typespec");
2361 break; /* NOTREACHED */
2363 return call_T_typecheck(typespec
, argobject
);
2364 case T_DESTRUCTURE
: /* Fallthru */
2366 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2367 pko
* ar_typespec
= pdata
->cvec
.els
;
2368 int left
= pdata
->cvec
.len
;
2369 return typecheck_by_vec (sc
, argobject
, ar_typespec
, left
);
2373 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,typespec
);
2374 pko
* ar_typespec
= pdata
->els
;
2375 int left
= pdata
->len
;
2376 return typecheck_by_vec (sc
, argobject
, ar_typespec
, left
);
2380 errx(7, "typecheck: Object is not a typespec");
2382 return 0; /* NOTREACHED */
2384 /*_ , typecheck_by_vec */
2386 typecheck_by_vec (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
)
2388 int saw_optional
= 0;
2389 for( ; left
; ar_typespec
++, left
--)
2391 pko tych
= *ar_typespec
;
2392 /**** Check for special keys ****/
2393 if(tych
== REF_KEY(K_TYCH_DOT
))
2397 KERNEL_ERROR_0 (sc
, "typecheck: After dot there must "
2398 "be exactly one typespec");
2401 { return typecheck(sc
, argobject
, ar_typespec
[1]); }
2403 if(tych
== REF_KEY(K_TYCH_OPTIONAL
))
2407 KERNEL_ERROR_0 (sc
, "typecheck: Can't have two optionals");
2415 if(tych
== REF_KEY(K_TYCH_REPEAT
))
2418 typecheck_repeat(sc
,argobject
,
2423 if(tych
== REF_KEY(K_TYCH_IMP_REPEAT
))
2426 typecheck_repeat(sc
,argobject
,
2432 /*** Manage stepping ***/
2433 if(!is_pair(argobject
))
2443 pko c
= pair_car(0,argobject
);
2444 argobject
= pair_cdr(0,argobject
);
2446 /*** Do the check ***/
2447 if (!typecheck(sc
, c
, tych
)) { return 0; }
2450 if(argobject
!= K_NIL
)
2455 /*_ , typecheck_repeat */
2458 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
)
2461 get_list_metrics_aux(argobject
, metrics
);
2462 /* Dotted lists don't satisfy repeat */
2463 if(!metrics
[lm_num_nils
]) { return 0; }
2464 if(metrics
[lm_cyc_len
])
2466 /* STYLE may not allow cycles. */
2469 /* If there's a cycle and count doesn't fit into it exactly,
2470 call that a mismatch. */
2471 if(count
% metrics
[lm_cyc_len
])
2474 /* Check the car of each pair. */
2477 for(step
= 0, i
= 0;
2478 step
< metrics
[lm_num_pairs
];
2479 ++step
, ++i
, argobject
= pair_cdr(0,argobject
))
2481 if(i
== count
) { i
= 0; }
2482 assert(is_pair(argobject
));
2483 pko tych
= ar_typespec
[i
];
2484 pko c
= pair_car(0,argobject
);
2485 if (!typecheck(sc
, c
, tych
)) { return 0; }
2489 /*_ , where_typemiss */
2490 /* This parallels typecheck, but where typecheck returned a boolean,
2491 this returns an object indicating where the type failed to match. */
2492 SIG_CHKARRAY(where_typemiss
) = { K_ANY
, K_ANY
, };
2493 DEF_SIMPLE_APPLICATIVE (ps0a2
, where_typemiss
,T_NO_K
,unsafe
, "where-typemiss")
2495 /* Return a list indicating how TYPESPEC failed to match
2497 WITH_2_ARGS(argobject
,typespec
);
2498 assert(no_call_k(typespec
));
2499 switch(_get_type(typespec
))
2503 WITH_UNBOXED_UNSAFE(pdata
,kt_cfunc
,typespec
);
2506 case klink_ftype_b00a1
:
2508 if (pdata
->func
.f_b00a1(argobject
))
2513 { return LIST1(typespec
); }
2516 errx(7, "where_typemiss: Object is not a typespec");
2520 break; /* NOTREACHED */
2523 WITH_PSYC_UNBOXED(typep_t
,typespec
,T_TYPEP
,0);
2524 if (call_T_typecheck(typespec
, argobject
))
2527 { return LIST1(mk_string(type_err_string(pdata
->T_tag
))); }
2532 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2533 return where_typemiss_do_spec(sc
, argobject
, pdata
->cvec
.els
, pdata
->cvec
.len
);
2537 WITH_UNBOXED_UNSAFE(pdata
,kt_vector
,typespec
);
2538 return where_typemiss_do_spec(sc
, argobject
, pdata
->els
, pdata
->len
);
2542 errx(7,"where_typemiss: Object is not a typespec");
2545 return 0; /* NOTREACHED */
2547 /*_ , where_typemiss_do_spec */
2549 where_typemiss_do_spec
2550 (klink
* sc
, pko argobject
, pko
* ar_typespec
, int left
)
2552 int saw_optional
= 0;
2554 for( ; left
; ar_typespec
++, left
--)
2556 pko tych
= *ar_typespec
;
2557 /**** Check for special keys ****/
2558 if(tych
== REF_KEY(K_TYCH_DOT
))
2562 KERNEL_ERROR_0 (sc
, "where_typemiss: After dot there must "
2563 "be exactly one typespec");
2568 where_typemiss(sc
, argobject
, ar_typespec
[1]);
2572 LISTSTAR3(mk_integer(el_num
),
2580 if(tych
== REF_KEY(K_TYCH_OPTIONAL
))
2584 KERNEL_ERROR_0 (sc
, "where_typemiss: Can't have two optionals");
2592 if(tych
== REF_KEY(K_TYCH_REPEAT
))
2595 where_typemiss_repeat(sc
,argobject
,
2600 { return LISTSTAR3(mk_integer(el_num
),mk_symbol("repeat"), result
); }
2604 if(tych
== REF_KEY(K_TYCH_IMP_REPEAT
))
2607 where_typemiss_repeat(sc
,argobject
,
2612 { return LISTSTAR3(mk_integer(el_num
),mk_symbol("improper-repeat"),result
); }
2617 /*** Manage stepping ***/
2618 if(!is_pair(argobject
))
2622 return LIST2(mk_integer(el_num
), mk_symbol("too-few"));
2630 pko c
= pair_car(0,argobject
);
2631 argobject
= pair_cdr(0,argobject
);
2634 /*** Do the check ***/
2635 pko result
= where_typemiss(sc
, c
, tych
);
2637 { return LISTSTAR2(mk_integer(el_num
),result
); }
2640 if(argobject
!= K_NIL
)
2641 { return LIST2(mk_integer(el_num
), mk_symbol("too-many")); }
2645 /*_ , where_typemiss_repeat */
2647 where_typemiss_repeat
2648 (klink
*sc
, pko argobject
, pko
* ar_typespec
, int count
, int style
)
2651 get_list_metrics_aux(argobject
, metrics
);
2652 /* Dotted lists don't satisfy repeat */
2653 if(!metrics
[lm_num_nils
]) { return LIST1(mk_symbol("dotted")); }
2654 if(metrics
[lm_cyc_len
])
2656 /* STYLE may not allow cycles. */
2658 { return LIST1(mk_symbol("circular")); }
2659 /* If there's a cycle and count doesn't fit into it exactly,
2660 call that a mismatch. */
2661 if(count
% metrics
[lm_cyc_len
])
2662 { return LIST1(mk_symbol("misaligned-end")); }
2664 /* Check the car of each pair. */
2667 for(step
= 0, i
= 0;
2668 step
< metrics
[lm_num_pairs
];
2669 ++step
, ++i
, argobject
= pair_cdr(0,argobject
))
2671 if(i
== count
) { i
= 0; }
2672 assert(is_pair(argobject
));
2673 pko tych
= ar_typespec
[i
];
2674 pko c
= pair_car(0,argobject
);
2675 pko result
= where_typemiss(sc
, c
, tych
);
2677 { return LISTSTAR2(mk_integer(step
),result
); }
2682 /*_ . Destructuring operations */
2683 /*_ , destructure_by_bool */
2684 /* Just for calling back after a freeform predicate */
2685 SIG_CHKARRAY (destructure_by_bool
) =
2687 REF_OPER (is_destr_result
),
2691 DEF_SIMPLE_CFUNC (ps0a3
, destructure_by_bool
, 0)
2693 WITH_3_ARGS (destr_result
, argobject
, satisfied
);
2694 if (satisfied
== K_T
)
2697 mk_destr_result_add (destr_result
, 1, &argobject
);
2699 else if (satisfied
!= K_F
)
2701 KERNEL_ERROR_0 (sc
, "Predicate should return a boolean");
2705 KERNEL_ERROR_0 (sc
, "type mismatch on non-C predicate");
2709 /*_ , destructure_how_many */
2711 destructure_how_many (pko typespec
)
2713 switch (_get_type(typespec
))
2717 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2718 if (pdata
->num_targets
>= 0)
2719 { return pdata
->num_targets
;}
2723 pko
* ar_typespec
= pdata
->cvec
.els
;
2724 int left
= pdata
->cvec
.len
;
2725 for( ; left
; ar_typespec
++, left
--)
2727 pko tych
= *ar_typespec
;
2728 count
+= destructure_how_many (tych
);
2730 pdata
->num_targets
= count
;
2740 /*_ , destructure_make_ops */
2742 destructure_make_ops
2743 (pko argobject
, pko typespec
, int saw_optional
, pko provoker
)
2746 /* Operations to run, in reverse order. */
2748 /* ^V= result-so-far */
2749 REF_OPER (destructure_resume
),
2750 /* V= (result-so-far argobject spec optional?) */
2751 mk_load (LIST5 (mk_load_ix (1, 0),
2754 kernel_bool (saw_optional
),
2756 mk_store (K_ANY
, 1),
2757 /* V= forced-argobject */
2759 /* ^V= (argobject) */
2760 mk_load (LIST1 (argobject
)),
2762 /* ^V= result-so-far */
2765 /*_ , destructure_make_ops_to_bool */
2767 destructure_make_ops_to_bool
2768 (pko argobject
, pko op_on_argobject
)
2770 assert (is_combiner (op_on_argobject
));
2772 /* Operations to run, in reverse order. */
2774 /* ^V= result-so-far */
2775 REF_OPER (destructure_by_bool
),
2776 /* V= (result-so-far bool spec) */
2777 mk_load (LIST3 (mk_load_ix (1, 0),
2779 mk_load_ix (0, 0))),
2780 mk_store (K_ANY
, 1),
2783 /* ^V= (argobject) */
2784 mk_load (LIST1 (argobject
)),
2786 /* ^V= result-so-far */
2789 /*_ , destructure */
2790 /* Callers: past_end should point into the same array as *outarray.
2791 It will indicate the maximum number number of elements we may
2792 write. The return value is the remainder of the outarray if
2793 successful, otherwise NULL.
2794 The meaning of extra_result depends on the return value:
2795 * On success, it's unused.
2796 * On destr_err, it will hold an error object.
2797 * On destr_must_call_k, it will hold a list of operations.
2801 (klink
* sc
, pko argobject
, pko typespec
, pko
** outarray
,
2802 pko
* past_end
, pko
* extra_result
, int saw_optional
, pko provoker
)
2804 if(*outarray
== past_end
)
2806 /* $$IMPROVE ME Treat this error like other mismatches */
2807 KERNEL_ERROR_0 (sc
, "destructure: past end of output array");
2809 if(_get_type(typespec
) == T_DESTRUCTURE
)
2811 WITH_UNBOXED_UNSAFE(pdata
,kt_destr_list
,typespec
);
2812 pko
* ar_typespec
= pdata
->cvec
.els
;
2813 int left
= pdata
->cvec
.len
;
2815 for( ; left
; ar_typespec
++, left
--)
2817 pko tych
= *ar_typespec
;
2819 /**** Check for special keys ****/
2820 if(tych
== REF_KEY(K_TYCH_DOT
))
2824 KERNEL_ERROR_0 (sc
, "destructure: After dot there must "
2825 "be exactly one typespec");
2829 kt_destr_outcome outcome
=
2830 destructure (sc
, argobject
,
2837 /* If there's error, contribute to describing its
2839 if (outcome
== destr_err
)
2842 LISTSTAR3(mk_integer(el_num
),
2849 if(tych
== REF_KEY(K_TYCH_OPTIONAL
))
2853 KERNEL_ERROR_0 (sc
, "destructure: Can't have two optionals");
2861 /*** Manage stepping ***/
2862 if(!is_pair(argobject
))
2866 *outarray
[0] = K_INERT
;
2870 if (is_promise (argobject
))
2872 WITH_BOX_TYPE(tag
,typespec
);
2874 mk_foresliced_basvector (typespec
,
2875 pdata
->cvec
.len
- left
,
2878 destructure_make_ops (argobject
,
2882 return destr_must_call_k
;
2886 /* $$IMPROVE ME These symbols should be made
2888 /* $$IMPROVE ME These location operations should be
2891 LIST2(mk_integer(el_num
), mk_symbol("too-few"));
2897 pko c
= pair_car(0,argobject
);
2898 argobject
= pair_cdr(0,argobject
);
2912 /* Success keeps exploring */
2915 /* Simple error ends exploration */
2916 /* Contribute to describing its location. */
2918 LISTSTAR2(mk_integer(el_num
),*extra_result
);
2920 case destr_must_call_k
:
2921 /* must-call-K schedules to resume in this state,
2924 WITH_BOX_TYPE(tag
,typespec
);
2925 /* $$IMPROVE ME If length = 0, this is just
2926 REF_OPER (is_null) */
2928 mk_foresliced_basvector (typespec
,
2929 pdata
->cvec
.len
- left
+ 1,
2931 pko raw_oplist
= *extra_result
;
2934 REF_OPER (destructure_resume
),
2935 /* ^V= (result-so-far argobject spec
2937 mk_load (LIST5 (mk_load_ix (0, 0),
2940 kernel_bool (saw_optional
),
2942 mk_store (K_ANY
, 1),
2943 /* ^V= result-so-far */
2945 return destr_must_call_k
;
2948 errx (7, "Unrecognized enumeration");
2952 if(argobject
== K_NIL
)
2953 { return destr_success
; }
2954 else if (is_promise (argobject
))
2956 pko new_typespec
= REF_OPER (is_null
);
2958 destructure_make_ops (argobject
,
2962 return destr_must_call_k
;
2967 LIST2(mk_integer(el_num
), mk_symbol("too-many"));
2972 else if (!no_call_k(typespec
))
2974 if (!is_combiner (typespec
))
2976 KERNEL_ERROR_0 (sc
, "spec must be a combiner");
2981 destructure_make_ops_to_bool (argobject
, typespec
);
2982 return destr_must_call_k
;
2984 else if(typecheck(sc
, argobject
, typespec
))
2986 *outarray
[0] = argobject
;
2988 return destr_success
;
2990 else if (is_promise (argobject
))
2993 destructure_make_ops (argobject
,
2997 return destr_must_call_k
;
3001 pko result
= where_typemiss(sc
, argobject
, typespec
);
3002 result
= result
? result
: mk_string("Couldn't find the typemiss");
3003 *extra_result
= result
;
3007 /*_ , destructure_to_array */
3009 destructure_to_array
3011 pko obj
, /* Object to extract values from */
3012 pko type
, /* Type spec */
3013 pko
* array
, /* Array to be filled */
3014 size_t length
, /* Maximum length of that array */
3015 pko resume_op
, /* Combiner to schedule if we resume */
3016 pko resume_data
, /* Extra data to the resume op */
3017 pko provoker
/* Provoker, in case of error */
3020 if (type
== K_NO_TYPE
)
3022 pko
* orig_array
= array
;
3023 pko extra_result
= 0;
3024 kt_destr_outcome outcome
=
3040 assert (extra_result
);
3041 _klink_error_1 (sc
, "type mismatch:",
3042 LIST2 (provoker
, extra_result
));
3047 case destr_must_call_k
:
3049 /* Arrange for a resume. */
3050 int read_len
= array
- orig_array
;
3051 pko result_so_far
= mk_destr_result (read_len
, orig_array
, K_NIL
);
3052 assert (is_combiner (resume_op
));
3053 CONTIN_0_RAW (resume_op
, sc
);
3054 /* ^^^V= (final-destr_result . resume_data) */
3055 CONTIN_0_RAW (mk_load (LISTSTAR2 (mk_load_ix (0, 0),
3058 CONTIN_0_RAW (mk_store (K_ANY
, 1), sc
);
3059 /* ^^^V= final-destr_result */
3060 schedule_rv_list (sc
, extra_result
);
3061 /* ^^^V= current-destr_result */
3062 /* $$ENCAPSULATE ME */
3063 sc
->value
= result_so_far
;
3064 longjmp (sc
->pseudocontinuation
, 1);
3071 errx (7, "Unrecognized enumeration");
3075 /*_ , destructure_resume */
3076 SIG_CHKARRAY (destructure_resume
) =
3078 REF_OPER (is_destr_result
),
3084 DEF_SIMPLE_CFUNC (ps0a5
, destructure_resume
, 0)
3086 WITH_5_ARGS (destr_result
, argobject
, typespec
, opt_p
, provoker
);
3087 const int max_args
= 5;
3088 pko arg_array
[max_args
];
3089 pko
* outarray
= arg_array
;
3090 pko extra_result
= 0;
3091 kt_destr_outcome outcome
=
3096 arg_array
+ max_args
,
3104 int new_len
= outarray
- arg_array
;
3106 mk_destr_result_add (destr_result
, new_len
, arg_array
);
3110 KERNEL_ERROR_1 (sc
, "type mismatch:",
3111 LIST2 (provoker
, extra_result
));
3114 case destr_must_call_k
:
3116 /* Arrange for another force+resume. This will feed whatever
3117 was there before. */
3118 int read_len
= outarray
- arg_array
;
3120 mk_destr_result_add (destr_result
,
3123 schedule_rv_list (sc
, extra_result
);
3124 return result_so_far
;
3129 errx (7, "Unrecognized enumeration");
3133 /*_ , do-destructure */
3134 /* We don't have a typecheck typecheck predicate yet, so accept
3135 anything for arg2. Really it can be what typecheck accepts or
3136 T_DESTRUCTURE, checked recursively. */
3137 SIG_CHKARRAY (do_destructure
) = { K_ANY
, K_ANY
, };
3138 DEF_SIMPLE_APPLICATIVE (ps0a2
, do_destructure
,T_NO_K
,unsafe
,"do-destructure")
3140 WITH_2_ARGS (argobject
,typespec
);
3141 int len
= destructure_how_many (typespec
);
3142 pko vec
= mk_vector (len
, K_NIL
);
3143 WITH_UNBOXED_UNSAFE (pdata
,kt_destr_list
,vec
);
3144 destructure_to_array
3150 REF_OPER (destr_result_to_vec
),
3152 REF_OPER (do_destructure
));
3157 /*_ , C functions as objects */
3160 typedef struct kt_opstore
3162 pko destr
; /* Often a T_DESTRUCTURE */
3167 DEF_T_PRED (is_cfunc
, T_CFUNC
,no
,"");
3170 /* For external use, if some code ever wants to make these objects
3172 /* $$MAKE ME SAFE Set type-check fields */
3174 mk_cfunc (const kt_cfunc
* f
)
3176 typedef kt_boxed_cfunc TT
;
3177 errx(4, "Don't use mk_cfunc yet")
3178 TT
*pbox
= GC_MALLOC (sizeof (TT
));
3179 pbox
->type
= T_CFUNC
;
3181 return PTR2PKO(pbox
);
3185 INLINE
const kt_cfunc
*
3186 get_cfunc_func (pko p
)
3188 WITH_PSYC_UNBOXED(kt_cfunc
,p
,T_CFUNC
,0)
3191 /*_ . cfunc_resume */
3193 /*_ . mk_cfunc_resume */
3195 mk_cfunc_resume (pko cfunc
)
3197 ALLOC_BOX_PRESUME (kt_cfunc
, T_CFUNC_RESUME
);
3198 pbox
->data
= *get_cfunc_func (cfunc
);
3199 return PTR2PKO(pbox
);
3202 /*_ . Curried functions */
3203 /*_ , About objects */
3206 { return is_type (p
, T_CURRIED
); }
3209 mk_curried (decurrier_f decurrier
, pko args
, pko next
)
3211 ALLOC_BOX(pbox
,T_CURRIED
,kt_boxed_curried
);
3212 pbox
->data
.decurrier
= decurrier
;
3213 pbox
->data
.args
= args
;
3214 pbox
->data
.next
= next
;
3215 pbox
->data
.argcheck
= 0;
3216 return PTR2PKO(pbox
);
3219 /*_ . call_curried */
3221 call_curried(klink
* sc
, pko curried
, pko value
)
3223 WITH_PSYC_UNBOXED(kt_curried
,curried
,T_CURRIED
,sc
);
3225 /* First schedule the next one if there is any */
3228 klink_push_cont(sc
, pdata
->next
);
3231 /* Then call the decurrier with the data field and the value,
3232 returning its result. */
3233 return pdata
->decurrier (sc
, pdata
->args
, value
);
3238 typedef kt_vector kt_chain
;
3242 #define SIG_CHAIN(C_NAME) pko CHAIN_NAME(C_NAME)[]
3243 #define DEF_CHAIN(NAME, ARRAY_NAME) \
3244 DEF_VEC(T_CHAIN | T_IMMUTABLE, NAME, ARRAY_NAME)
3246 #define DEF_SIMPLE_CHAIN(C_NAME) \
3247 RGSTR(all-builtins,"C-" #C_NAME, REF_OPER (C_NAME)) \
3248 DEF_CHAIN(OPER(C_NAME), CHAIN_NAME(C_NAME))
3253 schedule_chain(klink
* sc
, const kt_vector
* chain
)
3255 _kt_spagstack dump
= sc
->dump
;
3257 for(i
= chain
->len
- 1; i
>= 0; i
--)
3259 pko comb
= chain
->els
[i
];
3260 /* If frame_depth is unassigned, assign it. */
3261 if(_get_type(comb
) == T_STORE
)
3263 WITH_UNBOXED_UNSAFE( pdata
, kt_opstore
, comb
);
3264 if(pdata
->frame_depth
< 0)
3265 { pdata
->frame_depth
= chain
->len
- 1 - i
; }
3267 /* Push it as a combiner */
3268 dump
= klink_push_cont_aux(dump
, comb
, sc
->envir
);
3275 eval_chain( klink
* sc
, pko functor
, pko value
)
3277 WITH_PSYC_UNBOXED( kt_vector
, functor
, T_CHAIN
, 0 );
3278 schedule_chain( sc
, pdata
);
3281 /*_ . schedule_rv_list */
3283 schedule_rv_list (klink
* sc
, pko list
)
3286 _kt_spagstack dump
= sc
->dump
;
3287 for(; list
!= K_NIL
; list
= cdr (list
))
3289 pko comb
= car (list
);
3290 /* $$PUNT If frame_depth is unassigned, assign it. */
3292 /* Push it as a combiner */
3293 dump
= klink_push_cont_aux(dump
, comb
, sc
->envir
);
3300 mk_notrace( pko combiner
)
3302 ALLOC_BOX_PRESUME( pko
, T_NOTRACE
);
3304 return PTR2PKO(pbox
);
3309 notrace_comb( pko p
)
3311 WITH_PSYC_UNBOXED( pko
, p
, T_NOTRACE
, 0 );
3317 #define STORE_DEF(DATA) \
3318 { T_STORE | T_IMMUTABLE, { DATA, -1, }, }
3320 #define ANON_STORE(DATA) \
3321 ANON_REF (kt_opstore, STORE_DEF(DATA))
3323 /*_ . dynamically */
3325 mk_store (pko data
, int depth
)
3327 ALLOC_BOX_PRESUME(kt_opstore
, T_STORE
| T_IMMUTABLE
);
3328 pdata
->destr
= data
;
3329 pdata
->frame_depth
= depth
;
3330 return PTR2PKO(pbox
);
3335 typedef pko kt_opload
;
3339 #define LOAD_DEF( DATA ) \
3340 { T_LOAD | T_IMMUTABLE, DATA, }
3342 #define ANON_LOAD( DATA ) \
3343 ANON_REF( pko, LOAD_DEF( DATA ))
3345 #define ANON_LOAD_IX( X, Y ) \
3346 ANON_PAIR(ANON_REF(num, INT_DEF( X )), \
3347 ANON_REF(num, INT_DEF( Y )))
3348 /*_ . dynamically */
3351 mk_load_ix (int x
, int y
)
3353 return cons (mk_integer (x
), mk_integer (y
));
3359 ALLOC_BOX_PRESUME(kt_opload
, T_LOAD
| T_IMMUTABLE
);
3361 return PTR2PKO(pbox
);
3364 /*_ , pairs proper */
3366 DEF_T_PRED (is_pair
, T_PAIR
,ground
, "pair?/o1");
3369 SIG_CHKARRAY(Xcons
) = { K_ANY
, K_ANY
, };
3370 DEF_SIMPLE_DESTR(Xcons
);
3371 DEF_APPLICATIVE_W_DESTR(p00a2
,mk_pair
, REF_DESTR(Xcons
),T_NO_K
,ground
, "cons")
3377 DEF_APPLICATIVE_W_DESTR(p00a2
,mk_mutable_pair
, REF_DESTR(Xcons
),T_NO_K
,ground
, "mcons")
3380 return mcons (a
, b
);
3383 /*_ . Parts and operations */
3385 SIG_CHKARRAY(pair_cxr
) = { REF_OPER(is_pair
), };
3386 DEF_SIMPLE_DESTR(pair_cxr
);
3387 DEF_APPLICATIVE_W_DESTR(ps0a1
,pair_car
, REF_DESTR(pair_cxr
),T_NO_K
,ground
, "car")
3390 return v2car(sc
,T_PAIR
,p
);
3393 DEF_APPLICATIVE_W_DESTR(ps0a1
,pair_cdr
, REF_DESTR(pair_cxr
),T_NO_K
,ground
, "cdr")
3396 return v2cdr(sc
,T_PAIR
,p
);
3399 SIG_CHKARRAY(pair_set_cxr
) = { REF_OPER(is_pair
), K_ANY
, };
3400 DEF_SIMPLE_DESTR(pair_set_cxr
);
3401 DEF_APPLICATIVE_W_DESTR(ps0a2
,set_car
, REF_DESTR(pair_set_cxr
),T_NO_K
,ground
, "set-car!")
3404 v2set_car(sc
,T_PAIR
,p
,q
);
3408 DEF_APPLICATIVE_W_DESTR(ps0a2
,set_cdr
, REF_DESTR(pair_set_cxr
),T_NO_K
,ground
, "set-cdr!")
3411 v2set_cdr(sc
,T_PAIR
,p
,q
);
3414 /*_ , Normal (one arg) */
3415 /*_ , Values as pairs */
3416 DEF_CFUNC_RAW(OPER (valcar
), ps0a1
, pair_car
, REF_OPER (is_pair
), T_NO_K
);
3417 DEF_CFUNC_RAW(OPER (valcdr
), ps0a1
, pair_cdr
, REF_OPER (is_pair
), T_NO_K
);
3421 DEF_T_PRED (is_string
, T_STRING
,ground
,"string?/o1");
3424 INTERFACE INLINE pko
3425 mk_string (const char *str
)
3427 return mk_bastring (T_STRING
, str
, strlen (str
), 0);
3430 INTERFACE INLINE pko
3431 mk_counted_string (const char *str
, int len
)
3433 return mk_bastring (T_STRING
, str
, len
, 0);
3436 INTERFACE INLINE pko
3437 mk_empty_string (int len
, char fill
)
3439 return mk_bastring (T_STRING
, 0, len
, fill
);
3441 /*_ . Create static */
3442 /* $$WRITE ME As for k_print_terminate_list macros */
3445 INTERFACE INLINE
char *
3446 string_value (pko p
)
3448 return bastring_value(0,T_STRING
,p
);
3451 INTERFACE INLINE
int
3454 return bastring_len(0,T_STRING
,p
);
3459 DEF_T_PRED(is_symbol
, T_SYMBOL
,ground
,"symbol?/o1");
3462 mk_symbol_obj (const char *name
)
3464 return mk_bastring (T_SYMBOL
| T_IMMUTABLE
, name
, strlen (name
), 0);
3467 /* We want symbol objects to be unique per name, so check an oblist of
3470 mk_symbol (const char *name
)
3472 /* first check oblist */
3473 pko x
= oblist_find_by_name (name
);
3480 x
= oblist_add_by_name (name
);
3484 /*_ . oblist implementation */
3485 /*_ , Global object */
3486 static pko oblist
= 0;
3487 /*_ , Oblist as hash table */
3488 #ifndef USE_OBJECT_LIST
3490 static int hash_fn (const char *key
, int table_size
);
3493 oblist_initial_value ()
3495 return mk_vector (461, K_NIL
);
3498 /* returns the new symbol */
3500 oblist_add_by_name (const char *name
)
3502 pko x
= mk_symbol_obj (name
);
3503 int location
= hash_fn (name
, vector_len (oblist
));
3504 set_vector_elem (oblist
, location
,
3505 cons (x
, vector_elem (oblist
, location
)));
3510 oblist_find_by_name (const char *name
)
3517 location
= hash_fn (name
, vector_len (oblist
));
3518 for (x
= vector_elem (oblist
, location
); x
!= K_NIL
; x
= cdr (x
))
3520 s
= symname (0,car (x
));
3521 /* case-insensitive, per R5RS section 2. */
3522 if (stricmp (name
, s
) == 0)
3531 oblist_all_symbols (void)
3535 pko ob_list
= K_NIL
;
3537 for (i
= 0; i
< vector_len (oblist
); i
++)
3539 for (x
= vector_elem (oblist
, i
); x
!= K_NIL
; x
= cdr (x
))
3541 ob_list
= mcons (x
, ob_list
);
3547 /*_ , Oblist as list */
3551 oblist_initial_value ()
3557 oblist_find_by_name (const char *name
)
3562 for (x
= oblist
; x
!= K_NIL
; x
= cdr (x
))
3564 s
= symname (0,car (x
));
3565 /* case-insensitive, per R5RS section 2. */
3566 if (stricmp (name
, s
) == 0)
3574 /* returns the new symbol */
3576 oblist_add_by_name (const char *name
)
3578 pko x
= mk_symbol_obj (name
);
3579 oblist
= cons (x
, oblist
);
3584 oblist_all_symbols (void)
3592 /*_ . Parts and operations */
3593 SIG_CHKARRAY(string_to_symbol
) = { REF_OPER(is_string
), };
3594 DEF_SIMPLE_APPLICATIVE(ps0a1
,string_to_symbol
,T_NO_K
,ground
, "string->symbol")
3596 return mk_symbol(string_value(arg1
));
3599 INTERFACE INLINE
char *
3600 symname (sc_or_null sc
, pko p
)
3602 return bastring_value (sc
,T_SYMBOL
, p
);
3609 DEF_T_PRED (is_vector
, T_VECTOR
,unsafe
,"vector?/o1");
3612 /*_ , mk_vector (T_ level) */
3613 INTERFACE
static pko
3614 mk_vector (int len
, pko fill
)
3615 { return mk_filled_basvector(len
, fill
, T_VECTOR
); }
3617 /*_ , k_mk_vector (K level) */
3618 /* $$RETHINK ME This may not be wanted. */
3619 SIG_CHKARRAY(k_mk_vector
) = { REF_OPER(is_integer
), REF_KEY(K_TYCH_OPTIONAL
), K_ANY
, };
3620 DEF_SIMPLE_APPLICATIVE (ps0a2
, k_mk_vector
,T_NO_K
,unsafe
,"make-vector")
3622 WITH_2_ARGS(k_len
, fill
);
3624 int len
= ivalue (k_len
);
3625 if (fill
== K_INERT
)
3627 return mk_vector (len
, fill
);
3631 /* K_ANY instead of REF_OPER(is_finite_list) because
3632 mk_basvector_w_args checks list-ness internally */
3633 DEF_APPLICATIVE_W_DESTR(ps0a1
, vector
, K_ANY
,T_NO_K
,unsafe
,"vector")
3636 return mk_basvector_w_args(sc
,p
,T_VECTOR
);
3639 /*_ . Operations (T_ level) */
3640 /*_ , fill_vector */
3642 INTERFACE
static void
3643 fill_vector (pko vec
, pko obj
)
3645 assert(_get_type(vec
) == T_VECTOR
);
3646 unsafe_basvector_fill(vec
,obj
);
3649 /*_ . Parts of vectors (T_ level) */
3651 INTERFACE
static int
3652 vector_len (pko vec
)
3654 assert(_get_type(vec
) == T_VECTOR
);
3655 return basvector_len(vec
);
3658 INTERFACE
static pko
3659 vector_elem (pko vec
, int ielem
)
3661 assert(_get_type(vec
) == T_VECTOR
);
3662 return basvector_elem(vec
, ielem
);
3665 INTERFACE
static void
3666 set_vector_elem (pko vec
, int ielem
, pko a
)
3668 assert(_get_type(vec
) == T_VECTOR
);
3669 basvector_set_elem(vec
, ielem
, a
);
3674 /* T_PROMISE is essentially a handle, pointing to a pair of either
3675 (expression env) or (value #f). We use #f, not nil, because nil is
3676 a possible environment. */
3680 RGSTR(ground
,"$lazy", REF_OPER(mk_promise_lazy
))
3681 DEF_CFUNC(ps0a1
, mk_promise_lazy
, K_ANY_SINGLETON
, T_NO_K
)
3684 pko guts
= mcons(p
, mcons(sc
->envir
, mk_continuation(sc
->dump
)));
3685 return v2cons (T_PROMISE
, guts
, K_NIL
);
3688 /* $$CHECK ME Is K_ANY correct? Or K_ANY_SINGLETON? */
3689 DEF_APPLICATIVE_W_DESTR(p00a1
,mk_promise_memo
,K_ANY
,T_NO_K
,ground
,"memoize")
3692 pko guts
= mcons(p
, K_F
);
3693 return v2cons (T_PROMISE
, guts
, K_NIL
);
3697 DEF_T_PRED (is_promise
,T_PROMISE
,ground
,"promise?/o1");
3699 /*_ , promise_schedule_eval */
3701 promise_schedule_eval(klink
* sc
, pko p
)
3704 pko guts
= unsafe_v2car(p
);
3705 pko env
= car(cdr(guts
));
3706 pko dynxtnt
= cdr(cdr(guts
));
3707 /* Arrange to eval the expression and pass the result to
3708 handle_promise_result */
3709 CONTIN_1R(dcrry_2ALLVLL
,handle_promise_result
,sc
,p
);
3710 /* $$ENCAP ME This deals with continuation guts, so should be
3711 encapped. As a special continuation-maker? */
3712 _kt_spagstack new_dump
=
3713 special_dynxtnt (cont_dump(dynxtnt
), sc
->dump
, env
);
3714 sc
->dump
= new_dump
;
3715 CONTIN_2(dcrry_2dotALL
, kernel_eval
, sc
, car(guts
), env
);
3718 /*_ , handle_promise_result */
3719 SIG_CHKARRAY(handle_promise_result
) = { REF_OPER(is_promise
), K_ANY
};
3720 DEF_SIMPLE_CFUNC(ps0a2
,handle_promise_result
,0)
3722 /* guts are only made by C code so if they're wrong it's a C
3725 WITH_2_ARGS(p
,value
);
3726 pko guts
= unsafe_v2car(p
);
3728 /* if p already has a result, return it */
3729 if(cdr(guts
) == K_F
)
3730 { return car(guts
); }
3731 /* If value is again a promise, set this promise's guts to that
3732 promise's guts and force it again, which will force both (This is
3733 why we need promises to be 2-layer) */
3734 else if(is_promise(value
))
3736 unsafe_v2set_car (p
, unsafe_v2car(value
));
3737 return promise_schedule_eval(sc
, p
);
3739 /* Otherwise set the value and return it. */
3742 unsafe_v2set_car (guts
, value
);
3743 unsafe_v2set_cdr (guts
, K_F
);
3749 DEF_APPLICATIVE_W_DESTR (ps0a1
, force
, K_ANY_SINGLETON
,T_NO_K
,ground
,"force")
3751 /* guts are only made by this C code here, so if they're wrong it's
3758 pko guts
= unsafe_v2car(p
);
3759 if(cdr(guts
) == K_F
)
3760 { return car(guts
); }
3762 { return promise_schedule_eval(sc
,p
); }
3768 /* $$IMPROVE ME Just directly contain the port structure. Possibly
3769 split port into several T_ types. */
3773 ALLOC_BOX_PRESUME (port
*, T_PORT
);
3775 return PTR2PKO(pbox
);
3779 port_rep_from_filename (const char *fn
, int prop
)
3784 if (prop
== (port_input
| port_output
))
3788 else if (prop
== port_output
)
3801 pt
= port_rep_from_file (f
, prop
);
3802 pt
->rep
.stdio
.closeit
= 1;
3806 { pt
->rep
.stdio
.filename
= store_string (strlen (fn
), fn
, 0); }
3808 pt
->rep
.stdio
.curr_line
= 0;
3814 port_from_filename (const char *fn
, int prop
)
3817 pt
= port_rep_from_filename (fn
, prop
);
3822 return mk_port (pt
);
3826 port_rep_from_file (FILE * f
, int prop
)
3829 pt
= (port
*) GC_MALLOC_ATOMIC (sizeof *pt
);
3834 /* Don't care what goes in these but GC really wants to provide it
3835 so here are dummy objects to put it in. */
3836 GC_finalization_proc ofn
;
3838 GC_register_finalizer(pt
, port_finalize_file
, 0, &ofn
, &ocd
);
3839 pt
->kind
= port_file
| prop
;
3840 pt
->rep
.stdio
.file
= f
;
3841 pt
->rep
.stdio
.closeit
= 0;
3846 port_from_file (FILE * f
, int prop
)
3849 pt
= port_rep_from_file (f
, prop
);
3854 return mk_port (pt
);
3858 port_rep_from_string (char *start
, char *past_the_end
, int prop
)
3861 pt
= (port
*) GC_MALLOC_ATOMIC (sizeof (port
));
3866 pt
->kind
= port_string
| prop
;
3867 pt
->rep
.string
.start
= start
;
3868 pt
->rep
.string
.curr
= start
;
3869 pt
->rep
.string
.past_the_end
= past_the_end
;
3874 port_from_string (char *start
, char *past_the_end
, int prop
)
3877 pt
= port_rep_from_string (start
, past_the_end
, prop
);
3882 return mk_port (pt
);
3885 #define BLOCK_SIZE 256
3888 realloc_port_string (port
* p
)
3890 /* $$IMPROVE ME Just use REALLOC. */
3891 char *start
= p
->rep
.string
.start
;
3892 size_t new_size
= p
->rep
.string
.past_the_end
- start
+ 1 + BLOCK_SIZE
;
3893 char *str
= GC_MALLOC_ATOMIC (new_size
);
3896 memset (str
, ' ', new_size
- 1);
3897 str
[new_size
- 1] = '\0';
3898 strcpy (str
, start
);
3899 p
->rep
.string
.start
= str
;
3900 p
->rep
.string
.past_the_end
= str
+ new_size
- 1;
3901 p
->rep
.string
.curr
-= start
- str
;
3912 port_rep_from_scratch (void)
3916 pt
= (port
*) GC_MALLOC_ATOMIC (sizeof (port
));
3921 start
= GC_MALLOC_ATOMIC (BLOCK_SIZE
);
3926 memset (start
, ' ', BLOCK_SIZE
- 1);
3927 start
[BLOCK_SIZE
- 1] = '\0';
3928 pt
->kind
= port_string
| port_output
| port_srfi6
;
3929 pt
->rep
.string
.start
= start
;
3930 pt
->rep
.string
.curr
= start
;
3931 pt
->rep
.string
.past_the_end
= start
+ BLOCK_SIZE
- 1;
3936 port_from_scratch (void)
3939 pt
= port_rep_from_scratch ();
3944 return mk_port (pt
);
3947 /*_ . open-input-file */
3948 SIG_CHKARRAY(k_open_input_file
) =
3949 { REF_OPER(is_string
), };
3950 DEF_SIMPLE_APPLICATIVE(ps0a1
,k_open_input_file
,0,ground
, "open-input-file")
3952 WITH_1_ARGS(filename
);
3953 return port_from_filename (string_value(filename
), port_file
| port_input
);
3959 DEF_T_PRED (is_port
, T_PORT
,ground
,"port?/o1");
3961 DEF_SIMPLE_PRED (is_inport
,T_NO_K
,ground
,"input-port?/o1")
3964 return is_port (p
) && portvalue (p
)->kind
& port_input
;
3967 DEF_SIMPLE_PRED (is_outport
,T_NO_K
,ground
,"output-port?/o1")
3970 return is_port (p
) && portvalue (p
)->kind
& port_output
;
3977 WITH_PSYC_UNBOXED(port
*,p
,T_PORT
,0);
3982 set_portvalue (pko p
, port
* newport
)
3984 assert_mutable(0,p
);
3985 WITH_PSYC_UNBOXED(port
*,p
,T_PORT
,0);
3990 /*_ . reading from ports */
3996 if (pt
->kind
& port_saw_EOF
)
3998 c
= basic_inchar (pt
);
4000 { pt
->kind
|= port_saw_EOF
; }
4004 if (pt
->kind
& port_file
)
4005 { pt
->rep
.stdio
.curr_line
++; }
4013 basic_inchar (port
* pt
)
4015 if (pt
->kind
& port_file
)
4017 return fgetc (pt
->rep
.stdio
.file
);
4021 if (*pt
->rep
.string
.curr
== 0 ||
4022 pt
->rep
.string
.curr
== pt
->rep
.string
.past_the_end
)
4028 return *pt
->rep
.string
.curr
++;
4033 /* back character to input buffer */
4035 backchar (port
* pt
, int c
)
4040 if (pt
->kind
& port_file
)
4042 ungetc (c
, pt
->rep
.stdio
.file
);
4046 pt
->rep
.stdio
.curr_line
--;
4052 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.start
)
4054 --pt
->rep
.string
.curr
;
4061 /*_ . (get-char textual-input-port) */
4062 SIG_CHKARRAY(get_char
) = { REF_OPER(is_inport
), };
4063 DEF_SIMPLE_APPLICATIVE(p00a1
,get_char
,T_NO_K
,ground
, "get-char")
4066 assert(is_inport(port
));
4067 int c
= inchar(portvalue(port
));
4071 { return mk_character(c
); }
4074 /*_ . Finalization */
4076 port_finalize_file(GC_PTR obj
, GC_PTR client_data
)
4079 if ((pt
->kind
& port_file
) && pt
->rep
.stdio
.closeit
)
4080 { port_close_port (pt
, port_input
| port_output
); }
4084 port_close (pko p
, int flag
)
4087 port_close_port(portvalue (p
), flag
);
4091 port_close_port (port
* pt
, int flag
)
4094 if ((pt
->kind
& (port_input
| port_output
)) == 0)
4096 if (pt
->kind
& port_file
)
4099 /* Cleanup is here so (close-*-port) functions could work too */
4100 pt
->rep
.stdio
.curr_line
= 0;
4104 fclose (pt
->rep
.stdio
.file
);
4106 pt
->kind
= port_free
;
4111 /*_ , Encapsulation type */
4113 SIG_CHKARRAY(is_encap
) = { REF_OPER(is_key
), K_ANY
};
4114 DEF_SIMPLE_CFUNC(b00a2
, is_encap
,T_NO_K
)
4116 WITH_2_ARGS(type
, p
);
4117 if (is_type (p
, T_ENCAP
))
4119 WITH_UNBOXED_UNSAFE(pdata
,kt_encap
,p
);
4120 return (pdata
->type
== type
);
4128 /* NOT directly part of the interface. */
4129 SIG_CHKARRAY(unencap
) = { REF_OPER(is_key
), K_ANY
};
4130 DEF_SIMPLE_CFUNC(ps0a2
, unencap
,T_NO_K
)
4132 WITH_2_ARGS(type
, p
);
4133 if (is_encap (type
, p
))
4135 WITH_UNBOXED_UNSAFE(pdata
,kt_encap
,p
);
4136 return pdata
->value
;
4140 /* We have no type-name to give to the error message. */
4141 KERNEL_ERROR_0 (sc
, "unencap: wrong type");
4145 /* NOT directly part of the interface. */
4146 SIG_CHKARRAY(mk_encap
) = { REF_OPER(is_key
), K_ANY
};
4147 DEF_SIMPLE_CFUNC(p00a2
, mk_encap
,T_NO_K
)
4149 WITH_2_ARGS(type
, value
);
4150 ALLOC_BOX_PRESUME (kt_encap
, T_ENCAP
);
4151 pbox
->data
.type
= type
;
4152 pbox
->data
.value
= value
;
4153 return PTR2PKO(pbox
);
4156 DEF_APPLICATIVE_W_DESTR (p00a0
, mk_encapsulation_type
, K_NO_TYPE
,T_NO_K
,ground
, "make-encapsulation-type/raw")
4158 /* A unique cell representing a type */
4159 pko type
= mk_void();
4160 /* $$IMPROVE ME make typespecs for the curried objs. trivpred is
4161 effectively that spec object. */
4162 pko e
= wrap (mk_curried (dcrry_2ALLV01
, type
, REF_OPER (mk_encap
)));
4163 pko trivpred
= mk_curried (dcrry_2ALLV01
, type
, REF_OPER (is_encap
));
4164 pko d
= wrap (mk_curried (dcrry_2ALLV01
, type
, REF_OPER (unencap
)));
4165 return LIST3 (e
, trivpred
, d
);
4167 /*_ , Listloop types */
4168 /*_ . Forward declarations */
4170 /*_ . Enumerations */
4172 /* How to turn the current list into current value and next list. */
4179 } kt_loopstyle_step
;
4187 } kt_loopstyle_argix
;
4189 /*_ . Function signatures. */
4190 typedef pko (* kt_listloop_mk_val
)(pko value
, struct kt_listloop
* pll
);
4192 typedef struct kt_listloop_style
4194 pko combiner
; /* Default combiner or NULL. */
4195 int collect_p
; /* Whether to collect a (reversed)
4196 list of the returns. */
4197 kt_loopstyle_step step
;
4198 kt_listloop_mk_val mk_val
; /* From returned value+state -> passed value. */
4199 pko destructurer
; /* A destructurer contents */
4200 /* Selection of args. Each entry correspond to one arg in "full
4201 args", and indexes something in the array of actual args that the
4202 destructurer retrieves. */
4203 int arg_select
[lls_num_args
];
4204 } kt_listloop_style
;
4205 typedef struct kt_listloop
4207 pko combiner
; /* The combiner to use repeatedly. */
4208 pko list
; /* The list to loop over */
4209 int top_length
; /* Length of top element, for lls_many. */
4210 int countdown
; /* Num elements left, or negative if unused. */
4211 int countup
; /* Upwards count from 0. */
4212 pko stop_on
; /* Stop if return value is this. Can
4214 kt_listloop_style
* style
; /* Non-NULL pointer to style. */
4216 /*_ , Internal signatures */
4218 listloop_aux (klink
* sc
,
4219 kt_listloop_style
* style_v
,
4221 pko style_args
[lls_num_args
]);
4222 FORWARD_DECL_CFUNC (static, ps0a3
, listloop_resume
);
4225 /*_ , Listloop styles */
4231 kt_loopstyle_step step
,
4232 kt_listloop_mk_val mk_val
)
4234 ALLOC_BOX_PRESUME(kt_listloop_style
,T_LISTLOOP_STYLE
);
4235 pdata
->combiner
= combiner
;
4236 pdata
->collect_p
= collect_p
;
4238 pdata
->mk_val
= mk_val
;
4239 return PTR2PKO(pbox
);
4249 kt_listloop_style
* style
)
4251 ALLOC_BOX_PRESUME(kt_listloop
,T_LISTLOOP
);
4252 pdata
->combiner
= combiner
;
4254 pdata
->top_length
= top_length
;
4255 pdata
->countdown
= count
;
4256 pdata
->countup
= -1;
4257 pdata
->stop_on
= stop_on
;
4258 pdata
->style
= style
;
4259 return PTR2PKO(pbox
);
4263 copy_listloop(const kt_listloop
* orig
)
4265 ALLOC_BOX_PRESUME(kt_listloop
,T_LISTLOOP
);
4266 memcpy (pdata
, orig
, sizeof(kt_listloop
));
4267 return PTR2PKO(pbox
);
4271 DEF_T_PRED(is_listloop
, T_LISTLOOP
, no
, "");
4272 DEF_T_PRED(is_listloop_style
, T_LISTLOOP_STYLE
, no
, "");
4274 /*_ . Pre-existing style objects */
4275 /*_ , listloop-style-sequence */
4276 RGSTR(simple
,"listloop-style-sequence",REF_OBJ(sequence_style
))
4277 static BOX_OF(kt_listloop_style
) sequence_style
=
4281 REF_OPER(kernel_eval
),
4285 K_NO_TYPE
, /* No args contemplated */
4286 { [0 ... lls_num_args
- 1] = -1, }
4289 /*_ , listloop-style-neighbors */
4290 RGSTR(simple
,"listloop-style-neighbors",REF_OBJ(neighbor_style
))
4291 SIG_CHKARRAY(neighbor_style
) =
4293 REF_OPER(is_integer
),
4295 DEF_SIMPLE_DESTR(neighbor_style
);
4296 static BOX_OF(kt_listloop_style
) neighbor_style
=
4304 REF_DESTR(neighbor_style
),
4305 /* See http://gcc.gnu.org/onlinedocs/gcc/Designated-Inits.html. */
4306 { [0 ... lls_num_args
- 1] = -1, [lls_count
] = 0, },
4311 /* Create a listloop object. */
4312 /* $$IMPROVE ME This may become what style operative T_ type calls.
4313 Rename it eval_listloop_style. */
4314 SIG_CHKARRAY(listloop
) =
4316 REF_OPER(is_listloop_style
),
4317 REF_OPER(is_countable_list
),
4318 REF_KEY(K_TYCH_DOT
),
4322 DEF_SIMPLE_APPLICATIVE(ps0a3
, listloop
,0,ground
, "listloop")
4324 WITH_3_ARGS(style
, list
, args
);
4326 WITH_UNBOXED_UNSAFE(style_v
,kt_listloop_style
, style
);
4327 pko style_args
[lls_num_args
];
4328 /* Destructure the args by style */
4329 destructure_to_array(sc
,
4331 style_v
->destructurer
,
4334 REF_OPER (listloop_resume
),
4335 LIST2 (style
, list
),
4337 return listloop_aux (sc
, style_v
, list
, style_args
);
4339 /*_ , listloop_resume */
4340 SIG_CHKARRAY (listloop_resume
) =
4342 REF_OPER (is_destr_result
),
4343 REF_OPER(is_listloop_style
),
4344 REF_OPER(is_countable_list
),
4346 DEF_SIMPLE_CFUNC(ps0a3
, listloop_resume
, 0)
4348 WITH_3_ARGS (destr_result
, style
, list
);
4349 pko style_args
[lls_num_args
];
4350 destr_result_fill_array (destr_result
, lls_num_args
, style_args
);
4351 WITH_UNBOXED_UNSAFE(style_v
,kt_listloop_style
, style
);
4352 return listloop_aux (sc
, style_v
, list
, style_args
);
4354 /*_ , listloop_aux */
4357 (klink
* sc
, kt_listloop_style
* style_v
, pko list
, pko style_args
[lls_num_args
])
4359 /*** Get the actual arg objects ***/
4360 #define GET_OBJ(_INDEX) \
4361 ((style_v->arg_select[_INDEX] < 0) ? K_INERT : style_args[style_v->arg_select[_INDEX]])
4363 pko count
= GET_OBJ(lls_count
);
4364 pko combiner
= GET_OBJ(lls_combiner
);
4365 pko top_length
= GET_OBJ(lls_top_count
);
4368 /*** Extract values from the objects, using defaults as needed ***/
4369 int countv
= (count
== K_INERT
) ? -1L : ivalue(count
);
4370 int top_lengthv
= (top_length
== K_INERT
) ? 1 : ivalue(top_length
);
4371 if(combiner
== K_INERT
)
4373 combiner
= style_v
->combiner
;
4376 /*** Make the loop object itself ***/
4377 pko ll
= mk_listloop( combiner
, list
, top_lengthv
, countv
, 0, style_v
);
4380 /*_ , Evaluating one iteration */
4382 eval_listloop(klink
* sc
, pko functor
, pko value
)
4385 WITH_PSYC_UNBOXED(kt_listloop
, functor
, T_LISTLOOP
, sc
);
4387 /*** Test whether done, maybe return current value. ***/
4388 /* If we're not checking, value will be NULL so this won't
4389 trigger. pdata->countup is 0 for the first element. */
4390 if((pdata
->countup
>= 0) && (value
== pdata
->stop_on
))
4392 /* $$IMPROVE ME This will ct an "abnormal return" value from
4393 this and the other data. */
4396 /* If we're not counting down, value will be negative so this won't
4398 if(pdata
->countdown
== 0)
4402 /* And if we run out of elements, we have to stop regardless. */
4403 if(pdata
->list
== K_NIL
)
4405 /* $$IMPROVE ME Error if we're counting down (ie, if count
4410 /*** Step list, getting new value ***/
4411 pko new_list
, new_value
;
4413 switch(pdata
->style
->step
)
4416 new_list
= cdr( pdata
->list
);
4417 /* We assume the common case of val as list. */
4418 new_value
= LIST1(car( pdata
->list
));
4422 /* $$IMPROVE ME Also test that next item (new_list) is non-empty */
4423 new_list
= cdr( pdata
->list
);
4424 new_value
= LIST2(car( pdata
->list
), car(new_list
));
4427 new_list
= k_counted_map_cdr(sc
, pdata
->top_length
, pdata
->list
, T_PAIR
);
4428 new_value
= k_counted_map_car(sc
, pdata
->top_length
, pdata
->list
, T_PAIR
);
4431 KERNEL_ERROR_0(sc
,"I know nut-ting about that case");
4434 /* Convert it if applicable. */
4435 if(pdata
->style
->mk_val
)
4437 new_value
= pdata
->style
->mk_val(new_value
, pdata
);
4440 /*** Arrange a new iteration. ***/
4441 /* We don't have to re-setup the final chain, if any, because it's
4442 still there from the earlier call. Just the combiner (if any)
4443 and a fresh listloop operative. */
4444 pko new_listloop
= copy_listloop(pdata
);
4446 WITH_UNBOXED_UNSAFE(new_pdata
,kt_listloop
,new_listloop
);
4447 new_pdata
->list
= new_list
;
4448 if(new_pdata
->countdown
> 0)
4449 { new_pdata
->countdown
--; }
4450 new_pdata
->countup
++;
4453 if(pdata
->style
->collect_p
)
4455 CONTIN_0_RAW (mk_curried(dcrry_NVLLdotALL
, value
, new_listloop
), sc
);
4459 CONTIN_0_RAW(new_listloop
, sc
);
4462 CONTIN_0_RAW(pdata
->combiner
, sc
);
4466 /*_ . Handling lists */
4468 DEF_APPLICATIVE_W_DESTR (ps0a1
, list_star
, REF_OPER(is_finite_list
),T_NO_K
,ground
, "list*")
4470 return v2list_star(sc
, arg1
, T_PAIR
);
4473 SIG_CHKARRAY(reverse
) = { REF_OPER(is_finite_list
), };
4474 DEF_SIMPLE_APPLICATIVE (ps0a1
, reverse
,T_NO_K
,ground
, "reverse")
4477 return v2reverse(a
,T_PAIR
);
4479 /*_ . reverse list -- in-place */
4480 /* Don't just use unsafe_v2reverse_in_place, it checks nothing. This
4481 may be reserved for optimization only. */
4483 /*_ . append list -- produce new list */
4484 /* $$IMPROVE ME This defines append/2 but we'll want append/N. Do
4486 SIG_CHKARRAY(append
) = { REF_OPER(is_finite_list
), K_ANY
, };
4487 DEF_SIMPLE_APPLICATIVE (ps0a2
, append
,T_NO_K
,simple
, "append")
4490 return v2append(sc
,a
,b
,T_PAIR
);
4492 /*_ , is_finite_list */
4493 DEF_SIMPLE_PRED (is_finite_list
,T_NO_K
,ground
, "finite-list?/o1")
4497 get_list_metrics_aux(p
, metrics
);
4498 return (metrics
[lm_num_nils
] == 1);
4500 /*_ , is_countable_list */
4501 DEF_SIMPLE_PRED (is_countable_list
,T_NO_K
,ground
, "countable-list?/o1")
4505 get_list_metrics_aux(p
, metrics
);
4506 return (metrics
[lm_num_nils
] || metrics
[lm_cyc_len
]);
4508 /*_ , list_length */
4513 dotted list: -2 minus length before dot
4515 The extra meanings will change since callers can use
4516 get_list_metrics_aux now. Return lm_acyc_len even for dotted
4517 lists, return positive infinity for circular lists.
4524 get_list_metrics_aux(p
, metrics
);
4526 if(metrics
[lm_num_nils
] == 1)
4527 { return metrics
[lm_acyc_len
]; }
4528 /* A circular list */
4529 /* $$IMPROVE ME Return +oo. First make a type and object for +oo */
4530 if(metrics
[lm_cyc_len
] != 0)
4532 /* $$IMPROVE ME Return lm_acyc_len again, merge with the other
4534 /* Otherwise it's dotted */
4535 return 2 - metrics
[lm_acyc_len
];
4537 /*_ , list_length_k */
4538 DEF_APPLICATIVE_W_DESTR(p00a1
, list_length_k
, K_ANY_SINGLETON
,T_NO_K
,ground
, "length")
4541 return mk_integer(list_length(p
));
4544 /*_ , get_list_metrics */
4545 DEF_APPLICATIVE_W_DESTR(p00a1
, get_list_metrics
, K_ANY_SINGLETON
,T_NO_K
,ground
, "get-list-metrics")
4549 get_list_metrics_aux(p
, metrics
);
4550 return LIST4(mk_integer(metrics
[0]),
4551 mk_integer(metrics
[1]),
4552 mk_integer(metrics
[2]),
4553 mk_integer(metrics
[3]));
4555 /*_ , get_list_metrics_aux */
4556 /* RESULTS must be an int4 (an array of 4 integers). get_list_metrics_aux
4557 will fill it with (See enum lm_index):
4559 * the number of pairs in a
4560 * the number of nil objects in a
4561 * the acyclic prefix length of a
4562 * the cycle length of a
4565 /* $$IMPROVE ME Take a flag so we can skip work such as finding
4566 prefix-length when we don't need to do it. This will cause some
4567 result positions to be interpreted differently: when it's cycling,
4568 lm_acyc_len and lm_num_pairs may both overshoot (but never
4573 get_list_metrics_aux (pko a
, int4 presults
)
4575 int * results
= presults
; /* Make it easier to index. */
4582 /* Use Brent's Algorithm, but we have to check for nil and non-pair
4583 too, so I rearranged the loop. We also count steps, because in
4584 some cases we use number of steps directly. */
4590 results
[lm_num_pairs
] = steps
;
4591 results
[lm_num_nils
] = 1;
4592 results
[lm_acyc_len
] = steps
;
4593 results
[lm_cyc_len
] = 0;
4596 if (!is_pair (fast
))
4598 results
[lm_num_pairs
] = steps
;
4599 results
[lm_num_nils
] = 0;
4600 results
[lm_acyc_len
] = steps
;
4601 results
[lm_cyc_len
] = 0;
4607 /* The fast cursor has caught up with the slow cursor so the
4608 structure is circular and loop_len is the cycle length.
4609 We still need to find prefix length.
4613 /* Restart the turtle from the beginning */
4615 /* Restart the hare from position LOOP_LEN */
4616 for(i
= 0, fast
= a
; i
< loop_len
; i
++)
4617 { fast
= cdr (fast
); }
4618 /* Since hare has exactly a loop_len head start, when it
4619 goes around the loop exactly once it will be in the same
4620 position as turtle, so turtle will have only walked the
4629 results
[lm_num_pairs
] = prefix_len
+ loop_len
;
4630 results
[lm_num_nils
] = 0;
4631 results
[lm_acyc_len
] = prefix_len
;
4632 results
[lm_cyc_len
] = loop_len
;
4635 if(power
== loop_len
)
4637 /* Re-plant the slow cursor */
4646 /*_ . Handling trees */
4647 /*_ , copy_es_immutable */
4648 DEF_APPLICATIVE_W_DESTR (ps0a1
, copy_es_immutable
, K_ANY_SINGLETON
,T_NO_K
,ground
, "copy-es-immutable")
4650 WITH_1_ARGS(object
);
4652 if (is_pair (object
))
4654 /* If it's already immutable, can we assume it's immutable
4655 * all the way down and just return it? */
4657 (copy_es_immutable (sc
, car (object
)),
4658 copy_es_immutable (sc
, cdr (object
)));
4665 /*_ , Get tree cycles */
4667 /*_ , kt_recurrence_table */
4668 /* Really just a specialized resizeable lookup table from object to
4669 count. Internals may change. */
4670 /* $$IMPROVE ME Look up more efficiently. Current GC is not
4671 compacting, so we can hash or sort addresses meaningfully. */
4679 kt_recurrence_table
;
4680 /*_ , recur_entry */
4683 /* $$IMPROVE ME These two fields may become one enumerated field */
4688 /*_ , kt_recur_tracker */
4692 recur_entry
* entries
;
4696 /*_ . is_recurrence_table */
4697 DEF_T_PRED(is_recurrence_table
,T_RECURRENCES
,ground
, "recurrence-table?/o1");
4699 /*_ . is_recur_tracker */
4700 DEF_SIMPLE_PRED(is_recur_tracker
,T_NO_K
,ground
, "recur-tracker?/o1")
4703 return (p
== K_NIL
) || is_type (p
, T_RECUR_TRACKER
);
4705 /*_ . recurrences_to_recur_tracker */
4706 SIG_CHKARRAY(recurrences_to_recur_tracker
) =
4707 { REF_OPER(is_recurrence_table
), };
4708 DEF_SIMPLE_APPLICATIVE(p00a1
,recurrences_to_recur_tracker
,T_NO_K
,ground
, "recurrences->tracker")
4710 WITH_1_ARGS(recurrences
);
4711 assert_type(0,recurrences
,T_RECURRENCES
);
4713 WITH_UNBOXED_UNSAFE(ptable
, kt_recurrence_table
,recurrences
);
4714 /* $$IMPROVE ME Scan for counts > 1, and if there are none,
4716 if(ptable
->table_size
== 0)
4719 ALLOC_BOX_PRESUME(kt_recur_tracker
,T_RECUR_TRACKER
);
4720 /* $$MAKE ME SAFE This assumes that sharing is OK, recurrences
4721 won't mutate the LUT. When we have COW or similar, make it
4722 safe. At least check for immutability. */
4723 pdata
->objs
= ptable
->objs
;
4724 pdata
->table_size
= ptable
->table_size
;
4725 pdata
->current_index
= 0;
4727 GC_MALLOC_ATOMIC(sizeof(recur_entry
) * ptable
->table_size
);
4729 for(i
= 0; i
< ptable
->table_size
; i
++)
4731 recur_entry
* p_entry
= &pdata
->entries
[i
];
4732 p_entry
->count
= ptable
->counts
[i
];
4733 p_entry
->index_in_walk
= 0;
4734 p_entry
->seen_in_walk
= 0;
4736 return PTR2PKO(pbox
);
4739 /*_ . recurrences_list_objects */
4740 /* $$WRITE ME Get a list of all objects and their recurrence counts */
4741 /*_ . objtable_get_index */
4744 (pko
* objs
, int table_size
, pko obj
)
4747 for(i
= 0; i
< table_size
; i
++)
4754 /*_ . recurrences_get_seen_count */
4755 /* Return the number of times OBJ has been seen before. If "add" is
4756 non-zero, increment the count too (but return its previous
4759 recurrences_get_seen_count
4760 (kt_recurrence_table
* p_cycles_data
, pko obj
, int add
)
4762 int index
= objtable_get_index(p_cycles_data
->objs
,
4763 p_cycles_data
->table_size
,
4767 int count
= p_cycles_data
->counts
[index
];
4768 /* Maybe record another sighting of this object. */
4770 { p_cycles_data
->counts
[index
]++; }
4771 /* We've found our return value. */
4775 /* We only get here if search didn't find anything. */
4776 /* Make sure we have enough space for this object. */
4779 if(p_cycles_data
->table_size
== p_cycles_data
->alloced_size
)
4781 p_cycles_data
->alloced_size
*= 2;
4782 p_cycles_data
->counts
= GC_REALLOC(p_cycles_data
->counts
, sizeof(int) * p_cycles_data
->alloced_size
);
4783 p_cycles_data
->objs
= GC_REALLOC(p_cycles_data
->objs
, sizeof(pko
) * p_cycles_data
->alloced_size
);
4785 int index
= p_cycles_data
->table_size
;
4786 /* Record what it was */
4787 p_cycles_data
->objs
[index
] = obj
;
4788 /* We have now seen it once. */
4789 p_cycles_data
->counts
[index
] = 1;
4790 p_cycles_data
->table_size
++;
4794 /*_ . recurrences_get_object_count */
4795 /* Given an object, list its count */
4796 SIG_CHKARRAY(recurrences_get_object_count
) =
4797 { REF_OPER(is_recurrence_table
), K_ANY
, };
4798 DEF_SIMPLE_APPLICATIVE(p00a2
, recurrences_get_object_count
,T_NO_K
,ground
, "recurrences-get-object-count")
4800 WITH_2_ARGS(table
, obj
);
4801 WITH_PSYC_UNBOXED(kt_recurrence_table
,table
, T_RECURRENCES
, 0);
4802 int seen_count
= recurrences_get_seen_count(pdata
, obj
, 0);
4803 return mk_integer(seen_count
);
4805 /*_ . init_recurrence_table */
4807 init_recurrence_table(kt_recurrence_table
* p_cycles_data
, int initial_size
)
4809 p_cycles_data
->objs
= initial_size
?
4810 GC_MALLOC(sizeof(pko
) * initial_size
) : 0;
4811 p_cycles_data
->counts
= initial_size
?
4812 GC_MALLOC(sizeof(int) * initial_size
) : 0;
4813 p_cycles_data
->alloced_size
= initial_size
;
4814 p_cycles_data
->table_size
= 0;
4816 /*_ . trace_tree_cycles */
4819 (pko tree
, kt_recurrence_table
* p_cycles_data
)
4821 /* Special case for the "empty container", not because it's just a
4822 key but because "exploring" it does nothing. */
4825 /* Maybe skip this object entirely */
4826 /* $$IMPROVE ME Parameterize this */
4827 switch(_get_type(tree
))
4835 if(recurrences_get_seen_count(p_cycles_data
,tree
, 1) != 0)
4838 /* Switch on tree type */
4839 switch(_get_type(tree
))
4843 #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data)
4845 #undef _EXPLORE_FUNC
4850 /* Done this exploration */
4855 /*_ . get_recurrences */
4856 SIG_CHKARRAY(get_recurrences
) = { K_ANY
, };
4857 DEF_SIMPLE_APPLICATIVE (ps0a1
, get_recurrences
,T_NO_K
,ground
, "get-recurrences")
4860 /* No reason to even start exploring non-containers */
4861 /* $$IMPROVE ME Allow containers other than pairs */
4862 int explore_p
= (_get_type(tree
) == T_PAIR
);
4863 ALLOC_BOX_PRESUME(kt_recurrence_table
, T_RECURRENCES
);
4864 init_recurrence_table(pdata
, explore_p
? 8 : 0);
4866 { trace_tree_cycles(tree
,pdata
); }
4867 return PTR2PKO(pbox
);
4872 /*_ , Making result objects */
4874 /* make symbol or number atom from string */
4876 mk_atom (klink
* sc
, char *q
)
4879 int has_dec_point
= 0;
4883 if ((p
= strstr (q
, "::")) != 0)
4886 return mcons (sc
->COLON_HOOK
,
4887 mcons (mcons (sc
->QUOTE
,
4888 mcons (mk_atom (sc
, p
+ 2), K_NIL
)),
4889 mcons (mk_symbol (strlwr (q
)), K_NIL
)));
4895 if ((c
== '+') || (c
== '-'))
4905 return (mk_symbol (strlwr (q
)));
4914 return (mk_symbol (strlwr (q
)));
4917 else if (!isdigit (c
))
4919 return (mk_symbol (strlwr (q
)));
4922 for (; (c
= *p
) != 0; ++p
)
4934 else if ((c
== 'e') || (c
== 'E'))
4938 has_dec_point
= 1; /* decimal point illegal
4941 if ((*p
== '-') || (*p
== '+') || isdigit (*p
))
4947 return (mk_symbol (strlwr (q
)));
4952 return mk_real (atof (q
));
4954 return (mk_integer (atol (q
)));
4959 mk_sharp_const (char *name
)
4962 char tmp
[STRBUFFSIZE
];
4964 if (!strcmp (name
, "t"))
4966 else if (!strcmp (name
, "f"))
4968 else if (!strcmp (name
, "ignore"))
4970 else if (!strcmp (name
, "inert"))
4972 else if (*name
== 'o')
4974 snprintf (tmp
, STRBUFFSIZE
, "0%s", name
+ 1);
4975 sscanf (tmp
, "%lo", &x
);
4976 return (mk_integer (x
));
4978 else if (*name
== 'd')
4979 { /* #d (decimal) */
4980 sscanf (name
+ 1, "%ld", &x
);
4981 return (mk_integer (x
));
4983 else if (*name
== 'x')
4985 snprintf (tmp
, STRBUFFSIZE
, "0x%s", name
+ 1);
4986 sscanf (tmp
, "%lx", &x
);
4987 return (mk_integer (x
));
4989 else if (*name
== 'b')
4991 x
= binary_decode (name
+ 1);
4992 return (mk_integer (x
));
4994 else if (*name
== '\\')
4995 { /* #\w (character) */
4997 if (stricmp (name
+ 1, "space") == 0)
5001 else if (stricmp (name
+ 1, "newline") == 0)
5005 else if (stricmp (name
+ 1, "return") == 0)
5009 else if (stricmp (name
+ 1, "tab") == 0)
5013 else if (name
[1] == 'x' && name
[2] != 0)
5016 if (sscanf (name
+ 2, "%x", &c1
) == 1 && c1
< UCHAR_MAX
)
5026 else if (is_ascii_name (name
+ 1, &c
))
5031 else if (name
[2] == 0)
5039 return mk_character (c
);
5045 /*_ , Reading strings */
5046 /* read characters up to delimiter, but cater to character constants */
5048 readstr_upto (klink
* sc
, char *delim
)
5050 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5052 char *p
= sc
->strbuff
;
5054 while ((p
- sc
->strbuff
< sizeof (sc
->strbuff
)) &&
5055 !is_one_of (delim
, (*p
++ = inchar (pt
))));
5057 if (p
== sc
->strbuff
+ 2 && p
[-2] == '\\')
5063 backchar (pt
, p
[-1]);
5069 /* skip white characters */
5071 skipspace (klink
* sc
)
5073 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5077 { c
= inchar (pt
); }
5078 while (isspace (c
));
5089 /* check c is in chars */
5091 is_one_of (char *s
, int c
)
5101 /*_ , Reading expressions */
5102 /* read string expression "xxx...xxx" */
5104 readstrexp (klink
* sc
)
5106 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5107 char *p
= sc
->strbuff
;
5111 { st_ok
, st_bsl
, st_x1
, st_x2
, st_oct1
, st_oct2
} state
= st_ok
;
5116 if (c
== EOF
|| p
- sc
->strbuff
> sizeof (sc
->strbuff
) - 1)
5130 return mk_counted_string (sc
->strbuff
, p
- sc
->strbuff
);
5180 if (c
>= '0' && c
<= 'F')
5184 c1
= (c1
<< 4) + c
- '0';
5188 c1
= (c1
<< 4) + c
- 'A' + 10;
5207 if (c
< '0' || c
> '7')
5215 if (state
== st_oct2
&& c1
>= 32)
5218 c1
= (c1
<< 3) + (c
- '0');
5220 if (state
== st_oct1
)
5239 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5246 switch (c
= inchar (pt
))
5251 return (TOK_LPAREN
);
5253 return (TOK_RPAREN
);
5256 if (is_one_of (" \n\t", c
))
5269 while ((c
= inchar (pt
)) != '\n' && c
!= EOF
)
5278 return (token (sc
));
5281 return (TOK_DQUOTE
);
5283 return (TOK_BQUOTE
);
5285 if ((c
= inchar (pt
)) == '@')
5287 return (TOK_ATMARK
);
5302 while ((c
= inchar (pt
)) != '\n' && c
!= EOF
)
5311 return (token (sc
));
5317 /* $$UNHACKIFY ME! This is a horrible hack. */
5318 if (is_one_of (" itfodxb\\", c
))
5320 return TOK_SHARP_CONST
;
5332 /*_ , Nesting check */
5333 /*_ . create_nesting_check */
5334 void create_nesting_check(klink
* sc
)
5335 { klink_push_dyn_binding(sc
,K_NEST_DEPTH
,mk_integer(0)); }
5336 /*_ . nest_depth_ok_p */
5337 int nest_depth_ok_p(klink
* sc
)
5340 klink_find_dyn_binding(sc
,K_NEST_DEPTH
);
5343 return ivalue(nesting
) == 0;
5345 /*_ . change_nesting_depth */
5346 void change_nesting_depth(klink
* sc
, signed int change
)
5349 klink_find_dyn_binding(sc
,K_NEST_DEPTH
);
5350 add_to_ivalue(nesting
,change
);
5352 /*_ , C-style entry points */
5354 /*_ . kernel_read_internal */
5355 /* The only reason that this is separate from kernel_read_sexp is that
5356 it gets a token, which kernel_read_sexp does almost always, except
5357 once when a caller tricks it with TOK_LPAREN, and once when
5358 kernel_read_list effectively puts back a token it didn't decode. */
5360 DEF_APPLICATIVE_W_DESTR (ps0a0
, kernel_read_internal
, K_NO_TYPE
,0,ground
, "read")
5362 token_t tok
= token (sc
);
5368 create_nesting_check(sc
);
5369 return kernel_read_sexp (sc
);
5372 /*_ . kernel_read_sexp */
5373 DEF_CFUNC (ps0a0
, kernel_read_sexp
, K_NO_TYPE
,0)
5381 CONTIN_0 (vector
, sc
);
5385 sc
->tok
= token (sc
);
5386 if (sc
->tok
== TOK_RPAREN
)
5390 else if (sc
->tok
== TOK_DOT
)
5392 KERNEL_ERROR_0 (sc
, "syntax error: illegal dot expression");
5396 change_nesting_depth(sc
, 1);
5397 CONTIN_1 (dcrry_2A01VLL
, kernel_read_list
, sc
, K_NIL
);
5398 CONTIN_0 (kernel_read_sexp
, sc
);
5403 pko pquote
= REF_OPER(arg1
);
5404 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, pquote
);
5406 sc
->tok
= token (sc
);
5407 CONTIN_0 (kernel_read_sexp
, sc
);
5411 sc
->tok
= token (sc
);
5412 if (sc
->tok
== TOK_VEC
)
5414 /* $$CLEAN ME Do this more cleanly than by changing tokens
5415 to trick it. Maybe factor the TOK_LPAREN treatment so we
5417 klink_push_cont (sc
, REF_OPER (kernel_treat_qquoted_vec
));
5418 sc
->tok
= TOK_LPAREN
;
5419 /* $$CLEANUP Seems like this could be combined with the part
5421 CONTIN_0 (kernel_read_sexp
, sc
);
5426 /* Punt for now: Give quoted symbols rather than actual
5427 operators. ,Similarly sc->UNQUOTE, sc->UNQUOTESP */
5428 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, sc
->QQUOTE
);
5431 CONTIN_0 (kernel_read_sexp
, sc
);
5435 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, sc
->UNQUOTE
);
5436 sc
->tok
= token (sc
);
5437 CONTIN_0 (kernel_read_sexp
, sc
);
5440 CONTIN_1 (dcrry_2A01VLL
, val2val
, sc
, sc
->UNQUOTESP
);
5441 sc
->tok
= token (sc
);
5442 CONTIN_0 (kernel_read_sexp
, sc
);
5445 return mk_atom (sc
, readstr_upto (sc
, "();\t\n\r "));
5448 pko x
= readstrexp (sc
);
5451 KERNEL_ERROR_0 (sc
, "Error reading string");
5458 pko sharp_hook
= sc
->SHARP_HOOK
;
5460 is_symbol(sharp_hook
)
5461 ? find_slot_in_env (sc
->envir
, sharp_hook
, 1)
5465 KERNEL_ERROR_0 (sc
, "undefined sharp expression");
5469 pko form
= mcons (slot_value_in_env (f
), K_NIL
);
5470 return kernel_eval (sc
, form
, sc
->envir
);
5473 case TOK_SHARP_CONST
:
5475 pko x
= mk_sharp_const (readstr_upto (sc
, "();\t\n\r "));
5478 KERNEL_ERROR_0 (sc
, "undefined sharp expression");
5486 KERNEL_ERROR_0 (sc
, "syntax error: illegal token");
5491 /* $$IMPROVE ME Use currying ops instead of accumulating by hand */
5492 SIG_CHKARRAY(kernel_read_list
) = { REF_OPER(is_finite_list
), K_ANY
, };
5493 DEF_SIMPLE_CFUNC (ps0a2
, kernel_read_list
,0)
5495 WITH_2_ARGS (old_accum
,value
);
5496 pko accum
= mcons (value
, old_accum
);
5497 port
* pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
5498 sc
->tok
= token (sc
);
5499 if (sc
->tok
== TOK_EOF
)
5503 else if (sc
->tok
== TOK_RPAREN
)
5505 /* $$RECONSIDER ME Why is this done? To accept CR from user? */
5506 int c
= inchar (pt
);
5511 change_nesting_depth(sc
, -1);
5512 return (unsafe_v2reverse_in_place (K_NIL
, accum
));
5514 else if (sc
->tok
== TOK_DOT
)
5516 CONTIN_1 (dcrry_2A01VLL
, kernel_treat_dotted_list
, sc
, accum
);
5517 sc
->tok
= token (sc
);
5518 CONTIN_0 (kernel_read_sexp
, sc
);
5523 CONTIN_1 (dcrry_2A01VLL
, kernel_read_list
, sc
, accum
);
5524 CONTIN_0 (kernel_read_sexp
, sc
);
5529 /*_ . Treat end of dotted list */
5531 DEF_CFUNC (ps0a2
, kernel_treat_dotted_list
, REF_DESTR(kernel_read_list
),T_NO_K
)
5533 WITH_2_ARGS(args
,value
);
5535 if (token (sc
) != TOK_RPAREN
)
5537 KERNEL_ERROR_0 (sc
, "syntax error: illegal dot expression");
5541 change_nesting_depth(sc
, -1);
5542 return (unsafe_v2reverse_in_place (value
, args
));
5546 /*_ . Treat quasiquoted vector */
5548 DEF_CFUNC (ps0a1
, kernel_treat_qquoted_vec
, K_ANY
,T_NO_K
)
5551 /* $$IMPROVE ME Include vector applicative directly, not by applying
5552 symbol. This does need to apply, though, so that backquote (now
5553 seeing a list) can be run on "value" first*/
5554 return (mcons (mk_symbol ("apply"),
5555 mcons (mk_symbol ("vector"),
5556 mcons (mcons (sc
->QQUOTE
, mcons (value
, K_NIL
)),
5559 /*_ , Loading files */
5560 /*_ . load_from_port */
5561 /* $$RETHINK ME This soon need no longer be a cfunc */
5562 SIG_CHKARRAY(load_from_port
) = { REF_OPER(is_inport
), REF_OPER(is_environment
)};
5563 DEF_SIMPLE_CFUNC(ps0a2
,load_from_port
,0)
5565 WITH_2_ARGS(inport
,env
);
5566 assert (is_port(inport
));
5567 assert (is_environment(env
));
5568 /* Print that we're loading (If there's an outport, and we may want
5569 to add a verbosity condition based on a dynamic variable) */
5570 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5571 if(the_outport
&& (the_outport
!= K_NIL
))
5573 port
* pt
= portvalue(inport
);
5574 if(pt
->kind
& port_file
)
5576 const char *fname
= pt
->rep
.stdio
.filename
;
5578 { fname
= "<unknown>"; }
5579 putstr(sc
,"Loading ");
5585 /* We will do the evals in ENV */
5587 klink_push_dyn_binding(sc
,K_INPORT
,inport
);
5588 return kernel_rel(sc
);
5592 SIG_CHKARRAY(k_load_file
) = { REF_OPER(is_string
), };
5593 DEF_SIMPLE_APPLICATIVE(ps0a1
,k_load_file
,0,ground
, "load")
5595 WITH_1_ARGS(filename_ob
);
5596 const char * filename
= string_value(filename_ob
);
5597 pko p
= port_from_filename (filename
, port_file
| port_input
);
5600 KERNEL_ERROR_1(sc
,"unable to open", filename_ob
);
5603 return load_from_port(sc
,p
,sc
->envir
);
5605 /*_ . get-module-from-port */
5606 SIG_CHKARRAY(k_get_mod_fm_port
) =
5607 { REF_OPER(is_port
), REF_KEY(K_TYCH_OPTIONAL
), REF_OPER(is_environment
), };
5608 DEF_SIMPLE_APPLICATIVE(ps0a2
,k_get_mod_fm_port
,0,ground
, "get-module-from-port")
5610 WITH_2_ARGS(port
, params
);
5611 pko env
= mk_std_environment();
5612 if(params
!= K_INERT
)
5614 assert(is_environment(params
));
5615 kernel_define (env
, mk_symbol ("module-parameters"), params
);
5617 /* Ultimately return that environment. */
5618 CONTIN_1R(dcrry_NdotALL
,val2val
,sc
,env
);
5619 return load_from_port(sc
, port
,env
);
5623 /*_ , Writing chars */
5625 putstr (klink
* sc
, const char *s
)
5627 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5628 port
*pt
= portvalue (the_outport
); /* $$MAKE ME SAFER - check for K_NIL */
5630 if (pt
->kind
& port_file
)
5632 fputs (s
, pt
->rep
.stdio
.file
);
5638 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.past_the_end
)
5640 *pt
->rep
.string
.curr
++ = *s
;
5642 else if (pt
->kind
& port_srfi6
&& realloc_port_string (pt
))
5644 *pt
->rep
.string
.curr
++ = *s
;
5651 putchars (klink
* sc
, const char *s
, int len
)
5653 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5654 port
*pt
= portvalue (the_outport
); /* $$MAKE ME SAFER - check for K_NIL */
5656 if (pt
->kind
& port_file
)
5658 fwrite (s
, 1, len
, pt
->rep
.stdio
.file
);
5664 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.past_the_end
)
5666 *pt
->rep
.string
.curr
++ = *s
++;
5668 else if (pt
->kind
& port_srfi6
&& realloc_port_string (pt
))
5670 *pt
->rep
.string
.curr
++ = *s
++;
5677 putcharacter (klink
* sc
, int c
)
5679 pko the_outport
= klink_find_dyn_binding(sc
,K_OUTPORT
);
5680 port
*pt
= portvalue (the_outport
); /* $$MAKE ME SAFER - check for K_NIL */
5682 if (pt
->kind
& port_file
)
5684 fputc (c
, pt
->rep
.stdio
.file
);
5688 if (pt
->rep
.string
.curr
!= pt
->rep
.string
.past_the_end
)
5690 *pt
->rep
.string
.curr
++ = c
;
5692 else if (pt
->kind
& port_srfi6
&& realloc_port_string (pt
))
5694 *pt
->rep
.string
.curr
++ = c
;
5699 #define ok_abbrev(x) (is_pair(x) && cdr(x) == K_NIL)
5702 printslashstring (klink
* sc
, char *p
, int len
)
5705 unsigned char *s
= (unsigned char *) p
;
5706 putcharacter (sc
, '"');
5707 for (i
= 0; i
< len
; i
++)
5709 if (*s
== 0xff || *s
== '"' || *s
< ' ' || *s
== '\\')
5711 putcharacter (sc
, '\\');
5715 putcharacter (sc
, '"');
5718 putcharacter (sc
, 'n');
5721 putcharacter (sc
, 't');
5724 putcharacter (sc
, 'r');
5727 putcharacter (sc
, '\\');
5732 putcharacter (sc
, 'x');
5735 putcharacter (sc
, d
+ '0');
5739 putcharacter (sc
, d
- 10 + 'A');
5744 putcharacter (sc
, d
+ '0');
5748 putcharacter (sc
, d
- 10 + 'A');
5755 putcharacter (sc
, *s
);
5759 putcharacter (sc
, '"');
5762 /*_ , Printing atoms */
5764 printatom (klink
* sc
, pko l
)
5768 atom2str (sc
, l
, &p
, &len
);
5769 putchars (sc
, p
, len
);
5773 /* Uses internal buffer unless string pointer is already available */
5775 atom2str (klink
* sc
, pko l
, char **pp
, int *plen
)
5779 pko p_escapes
= klink_find_dyn_binding(sc
,K_PRINT_FLAG
);
5780 int escapes
= (p_escapes
== K_T
) ? 1 : 0;
5794 else if (l
== K_INERT
)
5798 else if (l
== K_IGNORE
)
5802 else if (l
== K_EOF
)
5806 else if (is_port (l
))
5809 snprintf (p
, STRBUFFSIZE
, "#<PORT>");
5811 else if (is_number (l
))
5814 if (num_is_integer (l
))
5816 snprintf (p
, STRBUFFSIZE
, "%ld", ivalue (l
));
5820 snprintf (p
, STRBUFFSIZE
, "%.10g", rvalue (l
));
5823 else if (is_string (l
))
5827 p
= string_value (l
);
5830 { /* Hack, uses the fact that printing is needed */
5833 printslashstring (sc
, string_value (l
), string_len (l
));
5837 else if (is_character (l
))
5839 int c
= charvalue (l
);
5851 snprintf (p
, STRBUFFSIZE
, "#\\space");
5854 snprintf (p
, STRBUFFSIZE
, "#\\newline");
5857 snprintf (p
, STRBUFFSIZE
, "#\\return");
5860 snprintf (p
, STRBUFFSIZE
, "#\\tab");
5866 snprintf (p
, STRBUFFSIZE
, "#\\del");
5871 snprintf (p
, STRBUFFSIZE
, "#\\%s", charnames
[c
]);
5877 snprintf (p
, STRBUFFSIZE
, "#\\x%x", c
);
5882 snprintf (p
, STRBUFFSIZE
, "#\\%c", c
);
5888 else if (is_symbol (l
))
5894 else if (is_environment (l
))
5896 p
= "#<ENVIRONMENT>";
5898 else if (is_continuation (l
))
5900 p
= "#<CONTINUATION>";
5902 else if (is_operative (l
)
5903 /* $$TRANSITIONAL When these can be launched by
5904 themselves, this check will be folded into is_operative */
5905 || is_type (l
, T_DESTRUCTURE
)
5906 || is_type (l
, T_TYPECHECK
)
5907 || is_type (l
, T_TYPEP
))
5909 /* $$TRANSITIONAL This logic will move, probably into
5910 k_print_special_and_balk_p, and become more general. */
5912 print_lookup_unwraps
?
5913 reverse_find_slot_in_env_aux(print_lookup_unwraps
,l
) :
5918 snprintf (p
, STRBUFFSIZE
, ",(unwrap #,%s)", symname(0, car(slot
)));
5923 print_lookup_to_xary
?
5924 reverse_find_slot_in_env_aux(print_lookup_to_xary
,l
) :
5928 /* We don't say it's the tree-ary version, because the
5929 tree-ary conversion is not exposed. */
5930 p
= symname(0, car(slot
));
5936 reverse_find_slot_in_env_aux(all_builtins_env
, l
) :
5940 p
= symname(0, car(slot
));
5943 { p
= "#<OPERATIVE>"; }}
5946 else if (is_promise (l
))
5950 else if (is_applicative (l
))
5952 p
= "#<APPLICATIVE>";
5954 else if (is_type (l
, T_ENCAP
))
5956 p
= "#<ENCAPSULATION>";
5958 else if (is_type (l
, T_KEY
))
5962 else if (is_type (l
, T_RECUR_TRACKER
))
5964 p
= "#<RECURRENCE TRACKER>";
5966 else if (is_type (l
, T_RECURRENCES
))
5968 p
= "#<RECURRENCE TABLE>";
5973 snprintf (p
, STRBUFFSIZE
, "#<ERROR %d>", _get_type(l
));
5979 /*_ , C-style entry points */
5981 /*_ , kernel_print_sexp */
5982 SIG_CHKARRAY(kernel_print_sexp
) =
5983 { K_ANY
, REF_KEY(K_TYCH_OPTIONAL
), REF_OPER(is_environment
), };
5985 DEF_SIMPLE_CFUNC (ps0a2
, kernel_print_sexp
,0)
5987 WITH_2_ARGS(sexp
, lookup_env
);
5988 pko recurrences
= get_recurrences(sc
, sexp
);
5989 pko tracker
= recurrences_to_recur_tracker(recurrences
);
5990 /* $$IMPROVE ME Default to an environment that knows sharp
5992 return kernel_print_sexp_aux
5995 ((lookup_env
== K_INERT
) ? ground_env
: lookup_env
));
5997 /*_ , k_print_special_and_balk_p */
5998 /* Possibly print a replacement or prefix. Return 1 if we should now
5999 skip printing sexp (Because it's shared), 0 otherwise. */
6001 k_print_special_and_balk_p
6002 (klink
* sc
, pko tracker
, pko lookup_env
, pko sexp
)
6005 /* If this object is directly known to printer, print its symbol. */
6006 if(lookup_env
!= K_NIL
)
6008 pko slot
= reverse_find_slot_in_env_aux(lookup_env
,sexp
);
6011 putstr (sc
, "#,"); /* Reader is to convert the symbol */
6012 printatom (sc
, car(slot
));
6016 if(tracker
== K_NIL
)
6019 /* $$IMPROVE ME Parameterize this and share that parameterization
6020 with get_recurrences */
6021 switch(_get_type(sexp
))
6030 WITH_PSYC_UNBOXED(kt_recur_tracker
,tracker
, T_RECUR_TRACKER
, sc
);
6031 int index
= objtable_get_index(pdata
->objs
,pdata
->table_size
,sexp
);
6032 if(index
< 0) { return 0; }
6033 recur_entry
* slot
= &pdata
->entries
[index
];
6034 if(slot
->count
<= 1) { return 0; }
6036 if(slot
->seen_in_walk
)
6038 char *p
= sc
->strbuff
;
6039 snprintf (p
, STRBUFFSIZE
, "#%d", slot
->index_in_walk
);
6040 putchars (sc
, p
, strlen (p
));
6041 return 1; /* Skip printing the object */
6045 slot
->seen_in_walk
= 1;
6046 slot
->index_in_walk
= pdata
->current_index
;
6047 pdata
->current_index
++;
6048 char *p
= sc
->strbuff
;
6049 snprintf (p
, STRBUFFSIZE
, "#%d=", slot
->index_in_walk
);
6050 putchars (sc
, p
, strlen (p
));
6051 return 0; /* Still should print the object */
6054 /*_ , kernel_print_sexp_aux */
6055 SIG_CHKARRAY(kernel_print_sexp_aux
) =
6056 { K_ANY
, REF_OPER(is_recur_tracker
), REF_OPER(is_environment
), };
6058 DEF_SIMPLE_CFUNC (ps0a3
, kernel_print_sexp_aux
,0)
6060 WITH_3_ARGS(sexp
, recur_tracker
, lookup_env
);
6062 if(k_print_special_and_balk_p(sc
, recur_tracker
, lookup_env
, sexp
))
6064 if (is_vector (sexp
))
6067 CONTIN_4 (dcrry_4dotALL
, kernel_print_vec_from
, sc
, sexp
,
6068 mk_integer (0), recur_tracker
, lookup_env
);
6071 else if (!is_pair (sexp
))
6073 printatom (sc
, sexp
);
6076 /* $$FIX ME Recognize quote etc.
6078 That is hard since the quote operative is not currently defined
6079 as such and we no longer have syntax.
6081 else if (car (sexp
) == sc
->QUOTE
&& ok_abbrev (cdr (sexp
)))
6084 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6086 else if (car (sexp
) == sc
->QQUOTE
&& ok_abbrev (cdr (sexp
)))
6089 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6091 else if (car (sexp
) == sc
->UNQUOTE
&& ok_abbrev (cdr (sexp
)))
6094 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6096 else if (car (sexp
) == sc
->UNQUOTESP
&& ok_abbrev (cdr (sexp
)))
6099 return kernel_print_sexp_aux (sc
, cadr (sexp
), recur_tracker
, lookup_env
);
6104 CONTIN_0_RAW(REF_OBJ(k_print_terminate_list
), sc
);
6105 CONTIN_3 (dcrry_2dotALL
, kernel_print_list
, sc
, cdr (sexp
), recur_tracker
, lookup_env
);
6106 return kernel_print_sexp_aux (sc
, car (sexp
), recur_tracker
, lookup_env
);
6109 /*_ , print_value */
6110 DEF_BOXED_CURRIED(print_value
,
6113 REF_OPER (kernel_print_sexp
));
6114 /*_ . k_print_string */
6115 SIG_CHKARRAY(k_print_string
) = { REF_OPER(is_string
), };
6117 DEF_SIMPLE_CFUNC (ps0a1
, k_print_string
,T_NO_K
)
6120 putstr (sc
, string_value(str
));
6123 /*_ . k_print_terminate_list */
6124 /* $$RETHINK ME This may be the long way to do it. */
6126 BOX_OF(kt_string
) _k_string_rpar
=
6127 { T_STRING
| T_IMMUTABLE
,
6128 { ")", sizeof(")"), },
6131 BOX_OF(kt_vec2
) _k_list_string_rpar
=
6132 { T_PAIR
| T_IMMUTABLE
,
6133 { REF_OBJ(_k_string_rpar
), REF_KEY(K_NIL
)}
6136 DEF_BOXED_CURRIED(k_print_terminate_list
,
6138 REF_OBJ(_k_list_string_rpar
),
6139 REF_OPER(k_print_string
));
6141 RGSTR(ground
, "newline", REF_OBJ(k_newline
))
6143 BOX_OF(kt_string
) _k_string_newline
=
6144 { T_STRING
| T_IMMUTABLE
,
6145 { "\n", sizeof("\n"), }, };
6147 BOX_OF(kt_vec2
) _k_list_string_newline
=
6148 { T_PAIR
| T_IMMUTABLE
,
6149 { REF_OBJ(_k_string_newline
), REF_KEY(K_NIL
)}
6152 DEF_BOXED_CURRIED(k_newline
,
6154 REF_OBJ(_k_list_string_newline
),
6155 REF_OPER(k_print_string
));
6157 /*_ . kernel_print_list */
6159 DEF_CFUNC (ps0a3
, kernel_print_list
, REF_DESTR(kernel_print_sexp_aux
),0)
6162 WITH_3_ARGS(sexp
, recur_tracker
, lookup_env
);
6163 if(is_pair (sexp
)) { putstr (sc
, " "); }
6164 else if (sexp
!= K_NIL
) { putstr (sc
, " . "); }
6167 if(k_print_special_and_balk_p(sc
, recur_tracker
, lookup_env
, sexp
))
6171 CONTIN_3 (dcrry_3dotALL
, kernel_print_list
, sc
, cdr (sexp
), recur_tracker
, lookup_env
);
6172 return kernel_print_sexp_aux (sc
, car (sexp
), recur_tracker
, lookup_env
);
6174 if (is_vector (sexp
))
6176 /* $$RETHINK ME What does this even print? */
6177 CONTIN_3 (dcrry_3dotALL
, kernel_print_list
, sc
, K_NIL
, recur_tracker
, lookup_env
);
6178 return kernel_print_sexp_aux (sc
, sexp
, recur_tracker
, lookup_env
);
6183 printatom (sc
, sexp
);
6189 /*_ . kernel_print_vec_from */
6190 SIG_CHKARRAY(kernel_print_vec_from
) =
6192 REF_OPER(is_integer
),
6193 REF_OPER(is_recur_tracker
),
6194 REF_OPER(is_environment
), };
6195 DEF_SIMPLE_CFUNC (ps0a4
, kernel_print_vec_from
,0)
6197 WITH_4_ARGS(vec
,k_i
, recur_tracker
, lookup_env
);
6198 int i
= ivalue (k_i
);
6199 int len
= vector_len (vec
);
6207 pko elem
= vector_elem (vec
, i
);
6208 set_ivalue (k_i
, i
+ 1);
6209 CONTIN_4 (dcrry_4dotALL
, kernel_print_vec_from
, sc
, vec
, arg2
, recur_tracker
, lookup_env
);
6211 return kernel_print_sexp_aux (sc
, elem
, recur_tracker
, lookup_env
);
6214 /*_ , Kernel entry points */
6216 DEF_APPLICATIVE_W_DESTR(ps0a1
,k_write
,K_ANY_SINGLETON
,0,ground
, "write")
6219 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_T
);
6220 return kernel_print_sexp(sc
,p
,K_INERT
);
6224 DEF_APPLICATIVE_W_DESTR(ps0a1
,k_display
,K_ANY_SINGLETON
,0,ground
, "display")
6227 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_F
);
6228 return kernel_print_sexp(sc
,p
,K_INERT
);
6232 /*_ . tracing_say */
6233 /* $$TRANSITIONAL Until we have actual trace hook */
6234 SIG_CHKARRAY(tracing_say
) = { REF_OPER(is_string
), K_ANY
, };
6235 DEF_SIMPLE_CFUNC (ps0a2
, tracing_say
,T_NO_K
)
6237 WITH_2_ARGS(k_string
, value
);
6240 putstr (sc
, string_value(k_string
));
6246 /*_ . Equivalence */
6247 /*_ , Equivalence of atoms */
6248 SIG_CHKARRAY(eqv
) = { K_ANY
, K_ANY
, };
6249 DEF_SIMPLE_APPLICATIVE(b00a2
,eqv
,T_NO_K
,simple
,"equal?/2-atom-atom")
6257 const char * a_str
= string_value (a
);
6258 const char * b_str
= string_value (b
);
6259 if (a_str
== b_str
) { return 1; }
6260 return !strcmp(a_str
, b_str
);
6265 else if (is_number (a
))
6269 if (num_is_integer (a
) == num_is_integer (b
))
6270 return num_eq (nvalue (a
), nvalue (b
));
6274 else if (is_character (a
))
6276 if (is_character (b
))
6277 return charvalue (a
) == charvalue (b
);
6281 else if (is_port (a
))
6293 /*_ , Equivalence of containers */
6295 /*_ . Hash function */
6296 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
6299 hash_fn (const char *key
, int table_size
)
6301 unsigned int hashed
= 0;
6303 int bits_per_int
= sizeof (unsigned int) * 8;
6305 for (c
= key
; *c
; c
++)
6307 /* letters have about 5 bits in them */
6308 hashed
= (hashed
<< 5) | (hashed
>> (bits_per_int
- 5));
6311 return hashed
% table_size
;
6315 /* Quick and dirty hash function for pointers */
6317 ptr_hash_fn(void * ptr
, int table_size
)
6318 { return (long)ptr
% table_size
; }
6320 /*_ . binder/accessor maker */
6321 pko
make_keyed_variable(pko gen_binder
, pko gen_accessor
)
6323 /* Make a unique key object */
6324 pko key
= mk_void();
6325 pko binder
= wrap (mk_curried
6329 pko accessor
= wrap (mk_curried
6333 /* Curry and wrap the two things. */
6334 return LIST2 (binder
, accessor
);
6337 /*_ . Environment implementation */
6338 /*_ , New-style environment objects */
6342 /* T_ENV_FRAME is a vec2 used as a pair in the env tree. It
6343 indicates a frame boundary.
6345 /* T_ENV_PAIR is another vec2 used as a pair in the env tree. It
6346 indicates no frame boundary.
6349 /* Other types are (hackishly) still shared with the vanilla types:
6351 A vector is interpeted as a hash table vector that is "as if" it
6352 were a list of T_ENV_PAIR. Each element is an alist of bindings.
6353 It can only hold symbol bindings, not keyed bindings, because we
6354 can't hash keyed bindings.
6356 A pair is interpreted as a binding of something and value. That
6357 something can be either a symbol or a key (void object). It is
6358 held directly by an T_ENV_FRAME or T_ENV_PAIR (or "as if", by the
6359 alists of a hash table vector).
6363 /*_ . Object functions */
6365 DEF_T_PRED (is_environment
, T_ENV_FRAME
,ground
,"environment?/o1");
6367 /*_ , New environment implementation */
6369 #ifndef USE_ALIST_ENV
6371 find_slot_in_env_vector (pko eobj
, pko hdl
)
6373 for (; eobj
!= K_NIL
; eobj
= unsafe_v2cdr (eobj
))
6375 assert (is_pair (eobj
));
6376 pko slot
= unsafe_v2car (eobj
);
6377 assert (is_pair (slot
));
6378 if (unsafe_v2car (slot
) == hdl
)
6387 reverse_find_slot_in_env_vector (pko eobj
, pko value
)
6389 for (; eobj
!= K_NIL
; eobj
= unsafe_v2cdr (eobj
))
6391 assert (is_pair (eobj
));
6392 pko slot
= unsafe_v2car (eobj
);
6393 assert (is_pair (slot
));
6394 if (unsafe_v2cdr (slot
) == value
)
6404 * If we're using vectors, each frame of the environment may be a hash
6405 * table: a vector of alists hashed by variable name. In practice, we
6406 * use a vector only for the initial frame; subsequent frames are too
6407 * small and transient for the lookup speed to out-weigh the cost of
6408 * making a new vector.
6411 make_new_frame(pko old_env
)
6414 #ifndef USE_ALIST_ENV
6415 /* $$IMPROVE ME Make a better test for whether to make vector. */
6416 /* The interaction-environment has about 300 variables in it. */
6417 if (old_env
== K_NIL
)
6419 new_frame
= mk_vector (461, K_NIL
);
6427 return v2cons (T_ENV_FRAME
, new_frame
, old_env
);
6431 new_slot_spec_in_env (pko env
, pko variable
, pko value
)
6433 assert(is_environment(env
));
6434 assert(is_symbol(variable
));
6435 pko slot
= mcons (variable
, value
);
6436 pko car_env
= unsafe_v2car (env
);
6437 #ifndef USE_ALIST_ENV
6438 if (is_vector (car_env
))
6440 int location
= hash_fn (symname (0,variable
), vector_len (car_env
));
6442 set_vector_elem (car_env
, location
,
6444 vector_elem (car_env
, location
)));
6449 pko new_list
= v2cons (T_ENV_PAIR
, slot
, car_env
);
6450 unsafe_v2set_car (env
, new_list
);
6454 enum env_frame_search_restriction
6457 env_fsr_only_coming_frame
,
6458 env_fsr_only_this_frame
,
6461 /* This explores a tree of bindings, punctuated by frames past which
6462 we sometimes don't search. */
6464 find_slot_in_env_aux (pko eobj
, pko hdl
, int restr
)
6468 _kt_tag type
= _get_type (eobj
);
6471 /* We have a slot (Which for now is just a pair) */
6473 if(unsafe_v2car (eobj
) == hdl
)
6477 #ifndef USE_ALIST_ENV
6480 /* Only for symbols. */
6481 if(!is_symbol (hdl
)) { return 0; }
6482 int location
= hash_fn (symname (0,hdl
), vector_len (eobj
));
6483 pko el
= vector_elem (eobj
, location
);
6484 return find_slot_in_env_vector (el
, hdl
);
6487 /* We have some sort of env pair */
6489 /* Check whether we should keep looking. */
6494 case env_fsr_only_coming_frame
:
6495 restr
= env_fsr_only_this_frame
;
6497 case env_fsr_only_this_frame
:
6501 "find_slot_in_env_aux: Bad restriction enum: %d", restr
);
6506 /* Explore car before cdr */
6507 pko found
= find_slot_in_env_aux (unsafe_v2car (eobj
), hdl
, restr
);
6508 if(found
) { return found
; }
6509 return find_slot_in_env_aux (unsafe_v2cdr (eobj
),hdl
,restr
);
6512 /* No other type should be found */
6514 "find_slot_in_env_aux: Bad type: %d", type
);
6515 return 0; /* NOTREACHED */
6520 find_slot_in_env (pko env
, pko hdl
, int all
)
6522 assert(is_environment(env
));
6523 enum env_frame_search_restriction restr
=
6524 all
? env_fsr_all
: env_fsr_only_coming_frame
;
6525 return find_slot_in_env_aux(env
,hdl
,restr
);
6527 /*_ , Reverse find-slot */
6528 /*_ . env_confirm_slot */
6530 env_confirm_slot(pko env
, pko slot
)
6532 assert(is_pair(slot
));
6534 (find_slot_in_env_aux(env
,unsafe_v2car(slot
),env_fsr_all
) == slot
);
6536 /*_ . reverse_find_slot_in_env_aux2 */
6538 reverse_find_slot_in_env_aux2(pko env
, pko eobj
, pko value
)
6542 _kt_tag type
= _get_type (eobj
);
6545 /* We have a slot (Which for now is just a pair) */
6547 if((unsafe_v2cdr (eobj
) == value
)
6548 && env_confirm_slot(env
, eobj
))
6552 #ifndef USE_ALIST_ENV
6555 /* $$IMPROVE ME Create a reverse-lookup vector if we come here
6556 and there is none. */
6558 for(i
= 0; i
< vector_len (eobj
); ++i
)
6560 pko slot
= reverse_find_slot_in_env_vector(vector_elem (eobj
, i
), value
);
6562 env_confirm_slot(env
, slot
))
6568 /* We have some sort of env pair */
6573 /* Explore car before cdr */
6575 reverse_find_slot_in_env_aux2 (env
, unsafe_v2car (eobj
), value
);
6576 if(found
&& env_confirm_slot(env
, found
))
6579 reverse_find_slot_in_env_aux2 (env
, unsafe_v2cdr (eobj
), value
);
6580 if(found
&& env_confirm_slot(env
, found
))
6585 /* No other type should be found */
6587 "reverse_find_slot_in_env_aux2: Bad type: %d", type
);
6588 return 0; /* NOTREACHED */
6592 /*_ . reverse_find_slot_in_env_aux */
6594 reverse_find_slot_in_env_aux (pko env
, pko value
)
6596 assert(is_environment(env
));
6597 return reverse_find_slot_in_env_aux2(env
, env
, value
);
6600 /*_ . Entry point */
6601 /* Exposed for testing */
6602 /* NB, args are in different order than in the helpers */
6603 SIG_CHKARRAY(reverse_find_slot_in_env
) =
6604 { K_ANY
, REF_OPER(is_environment
), };
6605 DEF_SIMPLE_APPLICATIVE (ps0a2
, reverse_find_slot_in_env
,T_NO_K
,unsafe
, "reverse-lookup")
6607 WITH_2_ARGS(value
,env
);
6609 pko slot
= reverse_find_slot_in_env_aux(env
, value
);
6610 if(slot
) { return car(slot
); }
6613 KERNEL_ERROR_0(sc
, "reverse_find_slot_in_env: No match");
6617 /*_ . reverse-binds?/2 */
6618 /* $$IMPROVE ME Maybe combine these */
6619 DEF_APPLICATIVE_W_DESTR(b00a2
,reverse_binds_p
,
6620 REF_DESTR(reverse_find_slot_in_env
),
6621 T_NO_K
,simple
,"reverse-binds?/2")
6623 WITH_2_ARGS(value
,env
);
6624 return reverse_find_slot_in_env_aux(env
, value
) ? 1 : 0;
6626 /*_ , Shared functions */
6629 new_frame_in_env (klink
* sc
, pko old_env
)
6631 sc
->envir
= make_new_frame (old_env
);
6635 set_slot_in_env (pko slot
, pko value
)
6637 assert (is_pair (slot
));
6638 set_cdr (0, slot
, value
);
6642 slot_value_in_env (pko slot
)
6645 assert (is_pair (slot
));
6649 /*_ , Keyed static bindings */
6651 /*_ , Making them */
6652 /* Make a new frame containing just the one keyed static variable. */
6654 env_plus_keyed_var (pko key
, pko value
, pko old_env
)
6656 pko slot
= cons (key
, value
);
6657 return v2cons (T_ENV_FRAME
, slot
, old_env
);
6659 /*_ , Finding them */
6660 /* find_slot_in_env works for this too. */
6663 SIG_CHKARRAY(klink_ksb_binder
) =
6664 { REF_OPER(is_key
), K_ANY
, REF_OPER(is_environment
), };
6665 DEF_SIMPLE_CFUNC(ps0a3
,klink_ksb_binder
,T_NO_K
)
6667 WITH_3_ARGS(key
, value
, env
);
6668 /* Check that env is in fact a environment. */
6669 if(!is_environment(env
))
6672 "klink_ksb_binder: Arg 2 must be an environment: ",
6675 /* Return a new environment with just that binding. */
6676 return env_plus_keyed_var(key
, value
, env
);
6680 SIG_CHKARRAY(klink_ksb_accessor
) =
6681 { REF_OPER(is_key
), };
6682 DEF_SIMPLE_CFUNC(ps0a1
,klink_ksb_accessor
,T_NO_K
)
6685 pko value
= find_slot_in_env(sc
->envir
,key
,1);
6688 KERNEL_ERROR_0(sc
, "klink_ksb_accessor: No binding found");
6691 return slot_value_in_env (value
);
6694 /*_ , make_keyed_static_variable */
6695 RGSTR(ground
, "make-keyed-static-variable", REF_OPER(make_keyed_static_variable
))
6696 DEF_CFUNC(p00a0
, make_keyed_static_variable
,K_NO_TYPE
,T_NO_K
)
6698 return make_keyed_variable(
6699 REF_OPER(klink_ksb_binder
),
6700 REF_OPER (klink_ksb_accessor
));
6702 /*_ , Building environments */
6703 /* Argobject is checked internally, so K_ANY */
6704 DEF_APPLICATIVE_W_DESTR(ps0a1
,make_environment
,K_ANY
,T_NO_K
,ground
, "make-environment")
6706 WITH_1_ARGS(parents
);
6707 /* $$IMPROVE ME Factor this so we only call get_list_metrics_aux
6708 once on this object. */
6710 get_list_metrics_aux(parents
, metrics
);
6711 pko typecheck
= REF_OPER(is_environment
);
6712 /* This will reject dotted lists */
6713 if(!typecheck_repeat(sc
,parents
,&typecheck
,1,1))
6715 KERNEL_ERROR_0 (sc
, "make_environment: argobject must be a list of environments");
6718 /* Collect the parent environments. */
6720 pko rv_par_list
= K_NIL
;
6721 for(i
= 0; i
< metrics
[lm_num_pairs
]; ++i
, parents
= pair_cdr(0, parents
))
6723 pko pare
= pair_car(0, parents
);
6724 rv_par_list
= v2cons (T_ENV_PAIR
, pare
, rv_par_list
);
6727 /* Reverse the list in place. */
6730 par_list
= unsafe_v2reverse_in_place(K_NIL
, rv_par_list
);
6732 /* $$IMPROVE ME Check for redundant environments and skip them.
6733 Check only *previous* environments, because we still need to
6734 search correctly. When recurrences walks environments too, we
6735 can use that to find them. */
6736 /* $$IMPROVE ME Add to environment information to block rechecks. */
6738 /* Return a new environment with all of those as parents. */
6739 return make_new_frame(par_list
);
6742 RGSTR(simple
,"$binds?/2", REF_OPER(bindsp_1
))
6743 SIG_CHKARRAY(bindsp_1
) =
6744 { REF_OPER(is_environment
), REF_OPER(is_symbol
), };
6745 DEF_SIMPLE_CFUNC(bs0a2
,bindsp_1
,T_NO_K
)
6747 WITH_2_ARGS(env
, sym
);
6748 return find_slot_in_env(env
, sym
, 1) ? 1 : 0;
6750 /*_ , find-binding */
6751 DEF_APPLICATIVE_W_DESTR(ps0a2
,find_binding
,REF_DESTR(bindsp_1
),T_NO_K
,ground
,"find-binding")
6753 WITH_2_ARGS(env
, sym
);
6754 pko binding
= find_slot_in_env(env
, sym
, 1);
6757 return cons(K_T
,slot_value_in_env (binding
));
6761 return cons(K_F
,K_INERT
);
6766 /*_ , Enumerations */
6767 enum klink_stack_cell_types
6776 ksct_arg_barrier
, /* Barrier to propagating pseudo-env. */
6780 struct dump_stack_frame
6785 struct stack_binding
6797 struct stack_profiling
6810 typedef struct dump_stack_frame_cell
6812 enum klink_stack_cell_types type
;
6816 struct dump_stack_frame frame
;
6817 struct stack_binding binding
;
6818 struct stack_guards guards
;
6819 struct stack_profiling profiling
;
6820 struct stack_arg pseudoenv
;
6822 } dump_stack_frame_cell
;
6827 dump_stack_initialize (klink
* sc
)
6833 stack_empty (klink
* sc
)
6834 { return sc
->dump
== 0; }
6838 klink_pop_cont (klink
* sc
)
6840 _kt_spagstack rv_pseudoenvs
= 0;
6842 /* Always return frame, which sc->dump will be set to. */
6843 /* for(frame = sc->dump; frame != 0; frame = frame->next) */
6852 const _kt_spagstack frame
= sc
->dump
;
6853 if(frame
->type
== ksct_frame
)
6855 const struct dump_stack_frame
*pdata
= &frame
->data
.frame
;
6856 sc
->next_func
= pdata
->ff
;
6857 sc
->envir
= pdata
->envir
;
6859 _kt_spagstack final_frame
= frame
->next
;
6861 /* Add the collected pseudo-env elements */
6862 while(rv_pseudoenvs
)
6864 _kt_spagstack el
= rv_pseudoenvs
;
6865 _kt_spagstack new_top
= rv_pseudoenvs
->next
;
6866 el
->next
= final_frame
;
6868 rv_pseudoenvs
= new_top
;
6870 sc
->dump
= final_frame
;
6875 if(frame
->type
== ksct_profile
)
6877 struct stack_profiling
* pdata
= &frame
->data
.profiling
;
6878 k_profiling_done_frame(sc
,pdata
);
6879 sc
->dump
= frame
->next
;
6882 else if( frame
->type
== ksct_args
)
6884 struct stack_arg
* old_pe
= &frame
->data
.pseudoenv
;
6885 if(old_pe
->frame_depth
> 0)
6887 /* Make a copy, to be re-added lower down */
6888 _kt_spagstack new_pseudoenv
=
6890 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6891 struct stack_arg
* new_pe
= &new_pseudoenv
->data
.pseudoenv
;
6892 new_pe
->vec
= old_pe
->vec
;
6893 new_pe
->frame_depth
= old_pe
->frame_depth
- 1;
6895 new_pseudoenv
->type
= ksct_args
;
6896 new_pseudoenv
->next
= rv_pseudoenvs
;
6897 rv_pseudoenvs
= new_pseudoenv
;
6900 sc
->dump
= frame
->next
;
6902 else if( frame
->type
== ksct_arg_barrier
)
6904 errx( 0, "Not allowed");
6906 sc
->dump
= frame
->next
;
6910 sc
->dump
= frame
->next
;
6916 static _kt_spagstack
6918 (_kt_spagstack old_frame
, pko ff
, pko env
)
6920 _kt_spagstack frame
=
6922 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6923 struct dump_stack_frame
* pdata
= &frame
->data
.frame
;
6927 frame
->type
= ksct_frame
;
6928 frame
->next
= old_frame
;
6934 klink_push_cont (klink
* sc
, pko ff
)
6935 { sc
->dump
= klink_push_cont_aux(sc
->dump
, ff
, sc
->envir
); }
6937 /*_ , Dynamic bindings */
6939 /* We do not pop dynamic bindings, only frames. */
6940 /* We deal with dynamic bindings in the context of the interpreter so
6941 that in the future we can cache them. */
6943 klink_push_dyn_binding (klink
* sc
, pko key
, pko value
)
6945 _kt_spagstack frame
=
6947 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6948 struct stack_binding
*pdata
= &frame
->data
.binding
;
6951 pdata
->value
= value
;
6953 frame
->type
= ksct_binding
;
6954 frame
->next
= sc
->dump
;
6960 klink_find_dyn_binding(klink
* sc
, pko key
)
6962 _kt_spagstack frame
= sc
->dump
;
6971 if(frame
->type
== ksct_binding
)
6973 const struct stack_binding
*pdata
= &frame
->data
.binding
;
6974 if(pdata
->key
== key
)
6975 { return pdata
->value
; }
6977 frame
= frame
->next
;
6982 /*_ . klink_push_guards */
6983 static _kt_spagstack
6985 (_kt_spagstack old_frame
, pko guards
, pko envir
, int exit
)
6987 _kt_spagstack frame
=
6989 GC_MALLOC (sizeof (dump_stack_frame_cell
));
6990 struct stack_guards
* pdata
= &frame
->data
.guards
;
6991 pdata
->guards
= guards
;
6992 pdata
->envir
= envir
;
6994 frame
->type
= exit
? ksct_exit_guards
: ksct_entry_guards
;
6995 frame
->next
= old_frame
;
6998 /*_ . get_guards_lo1st */
6999 /* Get a list of guard entries, root-most on top. */
7001 get_guards_lo1st(_kt_spagstack frame
)
7004 for(; frame
!= 0; frame
= frame
->next
)
7006 if((frame
->type
== ksct_entry_guards
) ||
7007 (frame
->type
== ksct_exit_guards
))
7009 list
= cons(mk_continuation(frame
), list
);
7017 /*_ , set_nth_arg */
7019 /* Set the nth arg */
7020 /* Unused, probably for a while, probably will never be used in this
7023 set_nth_arg(klink
* sc
, int n
, pko value
)
7025 _kt_spagstack frame
= sc
->dump
;
7027 for(frame
= sc
->dump
; frame
!= 0; frame
= frame
->next
)
7029 if(frame
->type
== ksct_args
)
7033 frame
->data
.arg
= value
;
7040 /* If we got here we never encountered the target. */
7044 /*_ . Store from value */
7045 /*_ , push_arg_raw */
7047 push_arg_raw(_kt_spagstack old_frame
, pko value
, int frame_depth
)
7049 _kt_spagstack frame
=
7051 GC_MALLOC (sizeof (dump_stack_frame_cell
));
7053 frame
->data
.pseudoenv
.vec
= value
;
7054 frame
->data
.pseudoenv
.frame_depth
= frame_depth
;
7055 frame
->type
= ksct_args
;
7056 frame
->next
= old_frame
;
7062 k_do_store(klink
* sc
, pko functor
, pko value
)
7064 WITH_PSYC_UNBOXED( kt_opstore
, functor
, T_STORE
, sc
);
7065 /* $$MAKE ME SAFE do_destructure must be safe vs resuming. Error if
7066 not T_NO_K. Don't try to maybe resume, because so far we never
7069 pko vec
= do_destructure( sc
, value
, pdata
->destr
);
7070 /* Push that as arg */
7071 sc
->dump
= push_arg_raw (sc
->dump
, vec
, pdata
->frame_depth
);
7074 /*_ . Load to value */
7075 /*_ , get_nth_arg */
7077 get_nth_arg( _kt_spagstack frame
, int n
)
7080 for(; frame
!= 0; frame
= frame
->next
)
7082 if(frame
->type
== ksct_args
)
7085 { return frame
->data
.pseudoenv
.vec
; }
7090 /* If we got here we never encountered the target. */
7094 /*_ , k_load_recurse */
7095 /* $$IMPROVE ME Add a shortcut for accessing value without ever
7098 k_load_recurse( _kt_spagstack frame
, pko tree
)
7100 if(_get_type( tree
) == T_PAIR
)
7102 WITH_PSYC_UNBOXED( kt_vec2
, tree
, T_PAIR
, 0 );
7103 if( is_integer( pdata
->_car
) && is_integer( pdata
->_cdr
))
7105 /* Pair of integers: Look up that item, look up secondary
7107 const int n
= ivalue( pdata
->_car
);
7108 const int m
= ivalue( pdata
->_cdr
);
7109 pko vec
= get_nth_arg( frame
, n
);
7111 assert( is_vector( vec
));
7112 pko value
= basvector_elem( vec
, m
);
7118 /* Pair, not integers: Explore car and cdr, return cons of them. */
7120 k_load_recurse( frame
, pdata
->_car
),
7121 k_load_recurse( frame
, pdata
->_cdr
));
7126 /* Anything else: Return it literally. */
7132 /* T_LOAD C-destructures as a singleton. It will contain a tree */
7133 /* This may largely take over for decurriers. */
7135 k_do_load(klink
* sc
, pko functor
, pko value
)
7137 WITH_PSYC_UNBOXED( pko
, functor
, T_LOAD
, sc
);
7138 return k_load_recurse( sc
->dump
, *pdata
);
7141 /*_ , Stack ancestry */
7142 /*_ . frame_is_ancestor_of */
7143 int frame_is_ancestor_of(_kt_spagstack frame
, _kt_spagstack other
)
7145 /* Walk from other towards root. Return 1 if we ever encounter
7146 frame, otherwise 0. */
7147 for(; other
!= 0; other
= other
->next
)
7154 /*_ . special_dynxtnt */
7155 /* Make a child of dynamic extent OUTER that evals with dynamic
7156 environment ENVIR continues normally to PROX_DEST. */
7157 _kt_spagstack special_dynxtnt
7158 (_kt_spagstack outer
, _kt_spagstack prox_dest
, pko envir
)
7161 klink_push_cont_aux(outer
,
7162 mk_curried(dcrry_2A01VLL
,
7163 LIST1(mk_continuation(prox_dest
)),
7164 REF_OPER(invoke_continuation
)),
7167 /*_ . curr_frame_depth */
7168 int curr_frame_depth(_kt_spagstack frame
)
7170 /* Walk towards root, counting. */
7172 for(; frame
!= 0; frame
= frame
->next
, count
++)
7176 /*_ , Continuations */
7180 _kt_spagstack frame
;
7185 DEF_T_PRED (is_continuation
, T_CONTINUATION
,ground
, "continuation?/o1");
7188 mk_continuation (_kt_spagstack frame
)
7190 ALLOC_BOX_PRESUME (continuation_t
, T_CONTINUATION
);
7191 pdata
->frame
= frame
;
7192 return PTR2PKO(pbox
);
7195 static _kt_spagstack
7198 WITH_PSYC_UNBOXED(continuation_t
,p
,T_CONTINUATION
,0);
7199 return pdata
->frame
;
7202 /*_ . Continuations WRT interpreter */
7203 /*_ , current_continuation */
7205 current_continuation (klink
* sc
)
7207 return mk_continuation (sc
->dump
);
7210 /*_ , invoke_continuation */
7211 /* DOES NOT RETURN */
7212 /* Control is resumed at _klink_cycle */
7214 /* Static and not directly available to Kernel, it's the eventual
7215 target of continuation_to_applicative. */
7216 SIG_CHKARRAY(invoke_continuation
) =
7217 { REF_OPER(is_continuation
), K_ANY
, };
7218 DEF_SIMPLE_CFUNC(vs0a2
,invoke_continuation
,T_NO_K
)
7220 WITH_2_ARGS (p
, value
);
7221 assert(is_continuation(p
));
7223 { sc
->dump
= cont_dump (p
); }
7225 longjmp (sc
->pseudocontinuation
, 1);
7228 /* Add the appropriate guard, if any, and return the new proximate
7232 (_kt_spagstack prox_dest
, _kt_spagstack to_contain
,
7233 pko guard_list
, pko envir
, _kt_spagstack outer
)
7237 for(x
= guard_list
; x
!= K_NIL
; x
= cdr(x
))
7239 pko selector
= car(car(x
));
7240 assert(is_continuation(selector
));
7241 if(frame_is_ancestor_of(cont_dump(selector
), to_contain
))
7243 /* Call has to take place in the dynamic extent of the
7244 next frame around this set of guards, so that the
7245 interceptor has access to dynamic bindings, but then
7246 control has to continue normally to the next guard or
7247 finally to the destination.
7249 So we extend the next frame with a call to
7250 invoke_continuation, currying the next destination in the
7251 chain. That does not check guards, so in effect it
7252 continues normally. Then we extend that with a call to
7253 the interceptor, currying an continuation->applicative of
7254 the guards' outer continuation.
7256 NB, continuation->applicative is correct. It would be
7257 wrong to shortcircuit it. Although there are no guards
7258 between there and the outer continuation, the
7259 continuation we pass might be called from another dynamic
7260 context. But it needs to be unwrapped.
7262 pko wrapped_interceptor
= cadr(car(x
));
7263 assert(is_applicative(wrapped_interceptor
));
7264 pko interceptor
= unwrap(0,wrapped_interceptor
);
7265 assert(is_operative(interceptor
));
7267 _kt_spagstack med_frame
=
7268 special_dynxtnt(outer
, prox_dest
, envir
);
7270 klink_push_cont_aux(med_frame
,
7271 mk_curried(dcrry_2VLLdotALL
,
7272 LIST1(continuation_to_applicative(mk_continuation(outer
))),
7276 /* We use only the first match so end the loop. */
7282 /*_ , add_guard_chain */
7285 (_kt_spagstack prox_dest
, pko guard_frame_list
, _kt_spagstack to_contain
, int exit
)
7288 const enum klink_stack_cell_types tag
7289 = exit
? ksct_exit_guards
: ksct_entry_guards
;
7290 for( ; guard_frame_list
!= K_NIL
; guard_frame_list
= cdr(guard_frame_list
))
7292 _kt_spagstack guard_frame
= cont_dump(car(guard_frame_list
));
7293 if(guard_frame
->type
== tag
)
7295 struct stack_guards
* pguards
= &guard_frame
->data
.guards
;
7297 add_guard(prox_dest
,
7301 exit
? guard_frame
->next
: guard_frame
);
7306 /*_ , continue_abnormally */
7307 /*** Arrange to "walk" from current continuation to c, passing control
7308 thru appropriate guards. ***/
7309 SIG_CHKARRAY(continue_abnormally
) =
7310 { REF_OPER(is_continuation
), K_ANY
, };
7311 /* I don't give this T_NO_K even though technically it longjmps
7312 rather than pushing into the eval loop. In the future we may
7313 distinguish those two cases. */
7314 DEF_SIMPLE_CFUNC(ps0a2
,continue_abnormally
,0)
7316 WITH_2_ARGS(c
,value
);
7318 _kt_spagstack source
= sc
->dump
;
7319 _kt_spagstack destination
= cont_dump (c
);
7321 /*** Find the guard frames on the intermediate path. ***/
7323 /* Control is exiting our current frame, so collect guards from
7324 there towards root. What we get is lowest first. */
7325 pko exiting_lo1st
= get_guards_lo1st(source
);
7326 /* Control is entering c's frame, so collect guards from there
7327 towards root. Again it's lowest first. */
7328 pko entering_lo1st
= get_guards_lo1st(destination
);
7330 /* Remove identical entries from the top, thus removing any merged
7332 while((exiting_lo1st
!= K_NIL
) &&
7333 (entering_lo1st
!= K_NIL
) &&
7334 (cont_dump(car(exiting_lo1st
)) == cont_dump(car(entering_lo1st
))))
7336 exiting_lo1st
= cdr(exiting_lo1st
);
7337 entering_lo1st
= cdr(entering_lo1st
);
7342 /*** Construct a string of calls to the appropriate guards, ending
7343 at destination. We collect in the reverse of the order that
7344 they will be run, so collect from "entering" first, from
7345 highest to lowest, then collect from "exiting", from lowest to
7348 _kt_spagstack prox_dest
= destination
;
7350 pko entering_hi1st
= reverse(sc
, entering_lo1st
);
7351 prox_dest
= add_guard_chain(prox_dest
, entering_hi1st
, destination
, 0);
7352 prox_dest
= add_guard_chain(prox_dest
, exiting_lo1st
, source
, 1);
7354 invoke_continuation(sc
, mk_continuation(prox_dest
), value
);
7355 return value
; /* NOTREACHED */
7360 SIG_CHKARRAY(call_cc
) = { REF_OPER(is_combiner
), };
7361 DEF_SIMPLE_APPLICATIVE(ps0a1
,call_cc
,0,ground
, "call/cc")
7363 WITH_1_ARGS(combiner
);
7364 pko cc
= current_continuation(sc
);
7365 return kernel_eval_aux(sc
,combiner
,LIST1(cc
),sc
->envir
);
7367 /*_ , extend-continuation */
7368 /*_ . extend_continuation_aux */
7370 extend_continuation_aux(_kt_spagstack old_frame
, pko a
, pko env
)
7372 _kt_spagstack frame
= klink_push_cont_aux(old_frame
, a
, env
);
7373 return mk_continuation(frame
);
7375 /*_ . extend_continuation */
7376 SIG_CHKARRAY(extend_continuation
) =
7377 { REF_OPER(is_continuation
),
7378 REF_OPER(is_applicative
),
7379 REF_KEY(K_TYCH_OPTIONAL
),
7380 REF_OPER(is_environment
),
7382 DEF_SIMPLE_APPLICATIVE(ps0a3
, extend_continuation
,T_NO_K
,ground
, "extend-continuation")
7384 WITH_3_ARGS(c
, a
, env
);
7385 assert(is_applicative(a
));
7386 if(env
== K_INERT
) { env
= make_new_frame(K_NIL
); }
7387 return extend_continuation_aux(cont_dump(c
), unwrap(sc
,a
), env
);
7389 /*_ , continuation->applicative */
7390 SIG_CHKARRAY(continuation_to_applicative
) = { REF_OPER(is_continuation
), };
7391 DEF_SIMPLE_APPLICATIVE(p00a1
,continuation_to_applicative
,T_NO_K
,ground
, "continuation->applicative")
7395 wrap(mk_curried (dcrry_2A01VLL
, LIST1(c
), REF_OPER(continue_abnormally
)));
7398 /*_ , guard-continuation */
7399 /* Each guard list is repeat (list continuation applicative) */
7400 /* We'd like to spec that applicative take 2 args, a continuation and
7401 a value, and be wrapped exactly once. */
7402 SIG_CHKARRAY(guard_continuation
) =
7403 { K_ANY
, REF_OPER(is_continuation
), K_ANY
, };
7404 DEF_SIMPLE_APPLICATIVE(ps0a3
,guard_continuation
,T_NO_K
,ground
, "guard-continuation")
7406 WITH_3_ARGS(entry_guards
, c
, exit_guards
);
7407 /* The spec wants an outer continuation to keeps sets of guards from
7408 being mixed together if there are two calls to guard_continuation
7409 with the same c. But that happens naturally here, so it seems
7412 /* $$IMPROVE ME Copy the es of both lists of guards. */
7413 _kt_spagstack frame
= cont_dump(c
);
7414 if(entry_guards
!= K_NIL
)
7416 frame
= klink_push_guards(frame
, entry_guards
, sc
->envir
, 0);
7418 if(exit_guards
!= K_NIL
)
7420 frame
= klink_push_guards(frame
, exit_guards
, sc
->envir
, 1);
7423 pko inner_cont
= mk_continuation(frame
);
7427 /*_ , guard-dynamic-extent */
7428 SIG_CHKARRAY(guard_dynamic_extent
) =
7430 REF_OPER(is_finite_list
),
7431 REF_OPER(is_applicative
),
7432 REF_OPER(is_finite_list
),
7434 /* DOES NOT RETURN */
7435 DEF_SIMPLE_APPLICATIVE(ps0a3
,guard_dynamic_extent
,0,ground
, "guard-dynamic-extent")
7437 WITH_3_ARGS(entry
,app
,exit
);
7438 pko cont
= guard_continuation(sc
,entry
,current_continuation(sc
),exit
);
7439 pko cont2
= extend_continuation(sc
,cont
, app
, sc
->envir
);
7440 /* Skip directly into the new continuation, don't invoke the
7442 invoke_continuation(sc
,cont2
, K_NIL
);
7447 /*_ , Keyed dynamic bindings */
7448 /*_ . klink_kdb_binder */
7449 SIG_CHKARRAY(klink_kdb_binder
) =
7450 { REF_OPER(is_key
), K_ANY
, REF_OPER(is_combiner
), };
7451 DEF_SIMPLE_CFUNC(ps0a3
,klink_kdb_binder
,T_NO_K
)
7453 WITH_3_ARGS(key
, value
, combiner
);
7454 /* Check that combiner is in fact a combiner. */
7455 if(!is_combiner(combiner
))
7458 "klink_kdb_binder: Arg 2 must be a combiner: ",
7461 /* Push the new binding. */
7462 klink_push_dyn_binding(sc
, key
, value
);
7463 /* $$IMPROVE ME In general, should can control calling better than
7464 this. Possibly do this thru invoke_continuation, except we're
7465 not arbitrarily changing continuations. */
7466 /* $$IMPROVE ME Want a better way to control what environment to
7467 push in. In fact, that's much like a dynamic variable. */
7468 /* $$IMPROVE ME Want a better and cheaper way to make empty
7469 environments. The vector thing should be controlled by a hint. */
7470 /* Make an empty static environment */
7471 new_frame_in_env(sc
,K_NIL
);
7472 /* Push combiner in that environment. */
7473 klink_push_cont(sc
,combiner
);
7474 /* And call it with no operands. */
7477 /* Combines with data to become "an applicative that takes two
7478 arguments, the second of which must be a oper. It calls its
7479 second argument with no operands (nil operand tree) in a fresh empty
7480 environment, and returns the result." */
7481 /*_ . klink_kdb_accessor */
7482 SIG_CHKARRAY(klink_kdb_accessor
) =
7483 { REF_OPER(is_key
), };
7484 DEF_SIMPLE_CFUNC(ps0a1
,klink_kdb_accessor
,T_NO_K
)
7487 pko value
= klink_find_dyn_binding(sc
,key
);
7490 KERNEL_ERROR_0(sc
, "klink_kdb_accessor: No binding found");
7494 /* Combines with data to become "an applicative that takes zero
7495 arguments. If the call to a occurs within the dynamic extent of a
7496 call to b, then a returns the value of the first argument passed to
7497 b in the smallest enclosing dynamic extent of a call to b. If the
7498 call to a is not within the dynamic extent of any call to b, an
7501 /*_ . make_keyed_dynamic_variable */
7502 RGSTR(ground
, "make-keyed-dynamic-variable", REF_OPER(make_keyed_dynamic_variable
))
7504 DEF_CFUNC(p00a0
, make_keyed_dynamic_variable
,K_NO_TYPE
,T_NO_K
)
7506 return make_keyed_variable(
7507 REF_OPER(klink_kdb_binder
),
7508 REF_OPER (klink_kdb_accessor
));
7513 typedef struct profiling_data
7521 profiling_data
* entries
;
7525 /*_ . Current data */
7526 /* This may be moved to per interpreter, or even more fine-grained. */
7527 /* This may not always be the way we get elapsed counts. */
7528 static long k_profiling_count
= 0;
7529 static int k_profiling_p
= 0; /* Are we profiling now? */
7530 /* If we are profiling, init this if it's not initted */
7531 static kt_profile_table k_profiling_table
= { 0 };
7532 /*_ . Dealing with table (All will be shared with other lookup tables) */
7535 init_profile_table(kt_profile_table
* p_table
, int initial_size
)
7537 p_table
->objs
= initial_size
?
7538 GC_MALLOC(sizeof(pko
) * initial_size
) : 0;
7539 p_table
->entries
= initial_size
?
7540 GC_MALLOC(sizeof(profiling_data
) * initial_size
) : 0;
7541 p_table
->alloced_size
= initial_size
;
7542 p_table
->table_size
= 0;
7544 /*_ , Increase its size */
7546 enlarge_profile_table(kt_profile_table
* p_table
)
7548 if(p_table
->table_size
== p_table
->alloced_size
)
7550 p_table
->alloced_size
*= 2;
7551 p_table
->entries
= GC_REALLOC(p_table
->entries
, sizeof(profiling_data
) * p_table
->alloced_size
);
7552 p_table
->objs
= GC_REALLOC(p_table
->objs
, sizeof(pko
) * p_table
->alloced_size
);
7557 /*_ , Searching in it */
7558 /* Use objtable_get_index */
7559 /*_ . On the stack */
7560 static struct stack_profiling
*
7561 klink_find_profile_in_frame (_kt_spagstack frame
, pko ff
)
7564 (frame
!= 0) && (frame
->type
!= ksct_frame
) ;
7565 frame
= frame
->next
)
7567 if(frame
->type
== ksct_profile
)
7569 struct stack_profiling
*pdata
= &frame
->data
.profiling
;
7570 if(pdata
->ff
== ff
) { return pdata
; }
7575 /*_ . Profile collection operations */
7576 /*_ , When eval loop steps */
7578 k_profiling_step(void)
7579 { k_profiling_count
++; }
7580 /*_ , When we begin executing a frame */
7581 /* Push a stack_profiling cell onto the frame. */
7584 k_profiling_new_frame(klink
* sc
, pko ff
)
7586 if(!k_profiling_p
) { return; }
7587 if(!is_operative(ff
)) { return; }
7588 /* Do this only if ff is interesting (which for the moment means
7589 that it can be found in ground environment). */
7590 if(!reverse_binds_p(ff
, ground_env
) &&
7591 !reverse_binds_p(ff
, print_lookup_unwraps
) &&
7592 !reverse_binds_p(ff
, print_lookup_to_xary
))
7594 struct stack_profiling
* found_profile
=
7595 klink_find_profile_in_frame (sc
->dump
, ff
);
7596 /* If the same combiner is already being profiled in this frame,
7597 don't add another copy. */
7600 /* $$IMPROVE ME Count tail calls */
7604 /* Push a profiling frame */
7605 _kt_spagstack old_frame
= sc
->dump
;
7606 _kt_spagstack frame
=
7608 GC_MALLOC (sizeof (dump_stack_frame_cell
));
7609 struct stack_profiling
* pdata
= &frame
->data
.profiling
;
7611 pdata
->initial_count
= k_profiling_count
;
7612 pdata
->returned_p
= 0;
7613 frame
->type
= ksct_profile
;
7614 frame
->next
= old_frame
;
7619 /*_ , When we pop a stack_profiling cell */
7621 k_profiling_done_frame(klink
* sc
, struct stack_profiling
* profile
)
7623 if(!k_profiling_p
) { return; }
7624 profiling_data
* pdata
= 0;
7625 pko ff
= profile
->ff
;
7627 /* This stack_profiling cell is popped past but it might be used
7628 again if we re-enter, so mark it accordingly. */
7629 profile
->returned_p
= 1;
7630 if(k_profiling_table
.alloced_size
== 0)
7631 { init_profile_table(&k_profiling_table
, 8); }
7634 int index
= objtable_get_index(k_profiling_table
.objs
, k_profiling_table
.table_size
, ff
);
7636 { pdata
= &k_profiling_table
.entries
[index
]; }
7639 /* Create it if needed */
7642 /* Increase size as needed */
7643 enlarge_profile_table(&k_profiling_table
);
7645 const int index
= k_profiling_table
.table_size
;
7646 k_profiling_table
.objs
[index
] = ff
;
7647 k_profiling_table
.table_size
++;
7648 pdata
= &k_profiling_table
.entries
[index
];
7649 /* Initialize it here */
7650 pdata
->num_calls
= 0;
7651 pdata
->num_evalloops
= 0;
7654 /* Add to its counts: Num calls. Num eval-loops taken. */
7656 pdata
->num_evalloops
+= k_profiling_count
- profile
->initial_count
;
7659 /*_ , Turn profiling on */
7660 /* Maybe better as a command-line switch or binder. */
7661 SIG_CHKARRAY(profiling
) = { REF_OPER(is_integer
), };
7662 DEF_SIMPLE_APPLICATIVE (ps0a1
, profiling
,T_NO_K
,ground
, "profiling")
7664 WITH_1_ARGS(profile_p
);
7665 int pr
= k_profiling_p
;
7666 k_profiling_p
= ivalue (profile_p
);
7667 return mk_integer (pr
);
7670 /*_ , Dumping profiling data */
7671 /* Return a list of the profiled combiners. */
7672 DEF_APPLICATIVE_W_DESTR(ps0a0
,get_profiling_data
,K_NO_TYPE
,T_NO_K
,ground
,"get-profiling-data")
7675 pko result_list
= K_NIL
;
7676 for(index
= 0; index
< k_profiling_table
.table_size
; index
++)
7678 pko ff
= k_profiling_table
.objs
[index
];
7679 profiling_data
* pdata
= &k_profiling_table
.entries
[index
];
7681 /* Element format: (object num-calls num-evalloops) */
7684 mk_integer(pdata
->num_calls
),
7685 mk_integer(pdata
->num_evalloops
)),
7688 /* Don't care about order so no need to reverse the list. */
7691 /*_ . Reset profiling data */
7692 /*_ , Alternative definitions for no profiling */
7694 #define k_profiling_step()
7695 #define k_profiling_new_frame(DUMMY, DUMMY2)
7697 /*_ . Error handling */
7698 /*_ , _klink_error_1 */
7700 _klink_error_1 (klink
* sc
, const char *s
, pko a
)
7703 const char *str
= s
;
7704 char sbuf
[STRBUFFSIZE
];
7705 pko the_inport
= klink_find_dyn_binding(sc
,K_INPORT
);
7706 if (the_inport
&& (the_inport
!= K_NIL
))
7708 port
* pt
= portvalue(the_inport
);
7709 /* Make sure error is not in REPL */
7710 if((pt
->kind
& port_file
) && (pt
->rep
.stdio
.file
!= stdin
))
7712 /* Count is 0-based but print it 1-based. */
7713 int ln
= pt
->rep
.stdio
.curr_line
+ 1;
7714 const char *fname
= pt
->rep
.stdio
.filename
;
7717 { fname
= "<unknown>"; }
7719 snprintf (sbuf
, STRBUFFSIZE
, "(%s : %i) %s", fname
, ln
, s
);
7721 str
= (const char *) sbuf
;
7725 const char *str
= s
;
7729 pko err_string
= mk_string (str
);
7732 err_arg
= mcons (a
, K_NIL
);
7738 err_arg
= mcons (err_string
, err_arg
);
7739 invoke_continuation (sc
, sc
->error_continuation
, err_arg
);
7745 /*_ , Default cheap error handlers */
7747 DEF_CFUNC (ps0a1
, kernel_err
, K_ANY
,0)
7752 putstr (sc
, "Error with no arguments. I know nut-ting!");
7755 if(!is_finite_list(arg1
))
7757 putstr (sc
, "kernel_err: arg must be a finite list");
7761 assert(is_pair(arg1
));
7762 int got_string
= is_string (car (arg1
));
7763 pko args_x
= got_string
? cdr (arg1
) : arg1
;
7764 const char *message
= got_string
? string_value (car (arg1
)) : " -- ";
7766 putstr (sc
, "Error: ");
7767 putstr (sc
, message
);
7768 return kernel_err_x (sc
, args_x
);
7771 /*_ . kernel_err_x */
7772 DEF_CFUNC (ps0a1
, kernel_err_x
, K_ANY_SINGLETON
,0)
7779 assert(is_pair(args
));
7780 CONTIN_1 (dcrry_1dotALL
, kernel_err_x
, sc
, cdr (args
));
7781 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_T
);
7782 CONTIN_1 (dcrry_1dotALL
, kernel_print_sexp
, sc
, car (args
));
7791 /*_ . kernel_err_return */
7792 DEF_CFUNC(ps0a1
,kernel_err_return
, K_ANY
,0)
7794 /* This should not set sc->done, because when it's called it still
7795 must print the error, which may require more eval loops. */
7797 return kernel_err(sc
, arg1
);
7801 DEF_APPLICATIVE_W_DESTR(ps0a1
,error
,K_ANY
,0,ground
,"error")
7803 WITH_1_ARGS(err_arg
);
7804 invoke_continuation (sc
, sc
->error_continuation
, err_arg
);
7805 return 0; /* NOTREACHED */
7807 /*_ . error-descriptor? */
7808 /* $$WRITE ME TO replace the punted version */
7810 /*_ . Support for calling C functions */
7812 /*_ , klink_call_cfunc_aux */
7814 klink_call_cfunc_aux (klink
* sc
, const kt_cfunc
* p_cfunc
, pko
* arg_array
)
7816 switch (p_cfunc
->type
)
7818 /* For these macros, the arglist is parenthesized so is
7821 /* ***************************************** */
7822 /* For function types returning bool as int (bXXaX) */
7823 #define CASE_CFUNCTYPE_bX(SUFFIX,ARGLIST) \
7824 case klink_ftype_##SUFFIX: \
7825 return kernel_bool(p_cfunc->func.f_##SUFFIX ARGLIST)
7827 CASE_CFUNCTYPE_bX (b00a1
, (arg_array
[0]));
7828 CASE_CFUNCTYPE_bX (b00a2
, (arg_array
[0], arg_array
[1]));
7829 CASE_CFUNCTYPE_bX (bs0a2
, (sc
, arg_array
[0], arg_array
[1]));
7831 #undef CASE_CFUNCTYPE_bX
7834 /* ***************************************** */
7835 /* For function types returning pko (pXXaX) */
7836 #define CASE_CFUNCTYPE_pX(SUFFIX,ARGLIST) \
7837 case klink_ftype_##SUFFIX: \
7838 return p_cfunc->func.f_##SUFFIX ARGLIST
7840 CASE_CFUNCTYPE_pX (p00a0
, ());
7841 CASE_CFUNCTYPE_pX (p00a1
, (arg_array
[0]));
7842 CASE_CFUNCTYPE_pX (p00a2
, (arg_array
[0], arg_array
[1]));
7843 CASE_CFUNCTYPE_pX (p00a3
, (arg_array
[0], arg_array
[1], arg_array
[2]));
7845 CASE_CFUNCTYPE_pX (ps0a0
, (sc
));
7846 CASE_CFUNCTYPE_pX (ps0a1
, (sc
, arg_array
[0]));
7847 CASE_CFUNCTYPE_pX (ps0a2
, (sc
, arg_array
[0], arg_array
[1]));
7848 CASE_CFUNCTYPE_pX (ps0a3
, (sc
, arg_array
[0], arg_array
[1], arg_array
[2]));
7849 CASE_CFUNCTYPE_pX (ps0a4
, (sc
, arg_array
[0], arg_array
[1],
7850 arg_array
[2], arg_array
[3]));
7851 CASE_CFUNCTYPE_pX (ps0a5
, (sc
, arg_array
[0], arg_array
[1], arg_array
[2], arg_array
[3], arg_array
[4]));
7853 #undef CASE_CFUNCTYPE_pX
7856 /* ***************************************** */
7857 /* For function types returning void (vXXaX) */
7858 #define CASE_CFUNCTYPE_vX(SUFFIX,ARGLIST) \
7859 case klink_ftype_##SUFFIX: \
7860 p_cfunc->func.f_##SUFFIX ARGLIST; \
7863 CASE_CFUNCTYPE_vX (vs0a2
, (sc
, arg_array
[0], arg_array
[1]));
7864 CASE_CFUNCTYPE_vX (vs0a3
, (sc
, arg_array
[0], arg_array
[1], arg_array
[2]));
7866 #undef CASE_CFUNCTYPE_vX
7870 "kernel_call: About that function type, I know nut-ting!");
7873 /*_ , klink_call_cfunc */
7875 klink_call_cfunc (klink
* sc
, pko functor
, pko env
, pko args
)
7877 const kt_cfunc
* p_cfunc
= get_cfunc_func (functor
);
7878 assert(p_cfunc
->argcheck
);
7879 const int max_args
= destructure_how_many (p_cfunc
->argcheck
);
7880 pko arg_array
[max_args
];
7881 destructure_to_array(sc
,args
,
7885 REF_OPER (k_resume_to_cfunc
),
7888 return klink_call_cfunc_aux (sc
, p_cfunc
, arg_array
);
7890 /*_ , k_resume_to_cfunc */
7891 SIG_CHKARRAY (k_resume_to_cfunc
) =
7893 REF_OPER (is_destr_result
),
7894 REF_KEY (K_TYCH_DOT
),
7895 REF_OPER (is_cfunc
),
7897 DEF_SIMPLE_CFUNC (ps0a2
, k_resume_to_cfunc
, 0)
7899 WITH_2_ARGS (destr_result
, functor
);
7900 assert_type (0, functor
, T_CFUNC
);
7901 const int max_args
= 5;
7902 pko arg_array
[max_args
];
7903 destr_result_fill_array (destr_result
, max_args
, arg_array
);
7904 return klink_call_cfunc_aux (sc
, get_cfunc_func (functor
), arg_array
);
7906 /*_ . Some decurriers */
7908 dcrry_2A01VLL (klink
* sc
, pko args
, pko value
)
7911 return LIST2(car (args
), value
);
7913 static pko
dcrry_3A01dotVLL (klink
* sc
, pko args
, pko value
)
7916 return cons (car (args
), value
);
7919 dcrry_2CA01VLLA02 (klink
* sc
, pko args
, pko value
)
7922 return LIST2( cons (car (args
), value
), cadr (args
));
7924 /* May not be needed */
7926 dcrry_3A01A02VLL (klink
* sc
, pko args
, pko value
)
7929 return LIST3(car (args
), cadr (args
), value
);
7932 dcrry_2ALLVLL (klink
* sc
, pko args
, pko value
)
7934 return LIST2(args
, value
);
7936 static pko
dcrry_2ALLV01 (klink
* sc
, pko args
, pko value
)
7939 return LIST2(args
, car (value
));
7943 dcrry_NCVLLA01dotAX1 (klink
* sc
, pko args
, pko value
)
7946 return cons(cons (value
, car (args
)), cdr (args
));
7948 static pko
dcrry_NdotALL (klink
* sc
, pko args
, pko value
)
7951 static pko
dcrry_1ALL (klink
* sc
, pko args
, pko value
)
7952 { return cons( args
, K_NIL
); }
7954 static pko
dcrry_5ALLdotVLL (klink
* sc
, pko args
, pko value
)
7955 { return cons (args
, value
); }
7957 static pko
dcrry_NVLLdotALL (klink
* sc
, pko args
, pko value
)
7958 { return cons (value
, args
); }
7961 dcrry_1VLL (klink
* sc
, pko args
, pko value
)
7962 { return LIST1 (value
); }
7965 /*_ , Internal functions */
7966 /*_ . kernel_define_tree_aux */
7968 kernel_define_tree_aux
7969 (klink
* sc
, pko value
, pko formal
, pko env
, pko
* extra_result
)
7972 if (is_pair (formal
))
7974 if (is_pair (value
))
7976 kt_destr_outcome outcome
=
7977 kernel_define_tree_aux (sc
, car (value
), car (formal
), env
,
7982 /* $$IMPROVE ME On error, give a more accurate position. */
7984 kernel_define_tree_aux (sc
, cdr (value
), cdr (formal
), env
,
7988 case destr_must_call_k
:
7989 /* $$IMPROVE ME Also schedule to resume the cdr */
7990 /* Operations to run, in reverse order. */
7994 REF_OPER (kernel_define_tree
),
7995 /* V= (value formal env) */
7996 mk_load (LIST3 (cdr (value
),
8000 return destr_must_call_k
;
8002 errx (7, "Unrecognized enumeration");
8005 if (is_promise (value
))
8007 /* Operations to run, in reverse order. */
8011 REF_OPER (kernel_define_tree
),
8012 /* V= (forced-value formal env) */
8013 mk_load (LIST3 (mk_load_ix (0, 0),
8016 mk_store (K_ANY
, 1),
8017 /* V= forced-argobject */
8020 mk_load (LIST1 (value
)));
8021 return destr_must_call_k
;
8026 "kernel_define_tree: value must be a pair: ", value
);
8027 return destr_err
; /* NOTREACHED */
8030 /* We can encounter NIL at the end of a non-dotted list, so mustn't
8031 try to bind it, and value list must end here too. */
8032 else if (formal
== K_NIL
)
8037 "kernel_define_tree: too many args: ", value
);
8038 return destr_err
; /* NOTREACHED */
8040 return destr_success
;
8042 /* If formal is #ignore, don't try to bind it, do nothing. */
8043 else if (formal
== K_IGNORE
)
8045 return destr_success
;
8047 /* If it's a symbol, bind it. Even a promise is bound thus. */
8048 else if (is_symbol (formal
))
8050 kernel_define (env
, formal
, value
);
8051 return destr_success
;
8056 "kernel_define_tree: can't bind to: ", formal
);
8057 return destr_err
; /* NOTREACHED */
8060 /*_ . kernel_define_tree */
8061 /* This can no longer be assumed to be T_NO_K, in case promises must
8063 SIG_CHKARRAY(kernel_define_tree
) =
8064 { K_ANY
, K_ANY
, REF_OPER(is_environment
), };
8065 DEF_SIMPLE_CFUNC(vs0a3
,kernel_define_tree
,0)
8067 WITH_3_ARGS(value
, formal
, env
);
8069 kt_destr_outcome outcome
=
8070 kernel_define_tree_aux(sc
, value
, formal
, env
, &extra_result
);
8076 /* Later this may raise the error */
8078 case destr_must_call_k
:
8079 schedule_rv_list (sc
, extra_result
);
8082 errx (7, "Unrecognized enumeration");
8085 /*_ . kernel_define */
8086 SIG_CHKARRAY(kernel_define
) =
8088 REF_OPER(is_environment
),
8089 REF_OPER(is_symbol
),
8092 DEF_SIMPLE_CFUNC(p00a3
,kernel_define
,T_NO_K
)
8094 WITH_3_ARGS(env
, symbol
, value
);
8095 assert(is_symbol(symbol
));
8096 pko x
= find_slot_in_env (env
, symbol
, 0);
8099 set_slot_in_env (x
, value
);
8103 new_slot_spec_in_env (env
, symbol
, value
);
8107 void klink_define (klink
* sc
, pko symbol
, pko value
)
8108 { kernel_define(sc
->envir
,symbol
,value
); }
8110 /*_ , Supporting kernel registerables */
8111 /*_ . eval_define */
8112 RGSTR(ground
, "$define!", REF_OPER(eval_define
))
8113 SIG_CHKARRAY(eval_define
) =
8115 DEF_SIMPLE_CFUNC(ps0a2
,eval_define
,0)
8117 pko env
= sc
->envir
;
8118 WITH_2_ARGS(formal
, expr
);
8119 CONTIN_2(dcrry_3VLLdotALL
,kernel_define_tree
,sc
,formal
,env
);
8120 /* Using args functionality:
8126 RUN, in reverse order
8127 kernel_define_tree (CONTIN_0)
8128 make arglist from 3 args ($$WRITE MY SUPPORT) - or from 2 args and value.
8129 (The 2 slots will go here)
8130 put return value in new slot ($$WRITE MY SUPPORT)
8134 Possibly "make arglist" will be an array of integers, -1 meaning
8135 the current value. And on its own it could do decurrying.
8137 return kernel_eval(sc
,expr
,env
);
8140 RGSTR(ground
, "$set!", REF_OPER(set
))
8142 { K_ANY
, K_ANY
, K_ANY
, };
8143 DEF_SIMPLE_CFUNC(ps0a3
,set
,0)
8145 pko env
= sc
->envir
;
8146 WITH_3_ARGS(env_expr
, formal
, expr
);
8147 /* Using args functionality:
8149 RUN, in reverse order
8150 kernel_define_tree (CONTIN_0)
8151 make arglist from 3 args - or from 2 args and value.
8152 put return value in new slot
8154 make arglist from 1 arg
8157 put return value in new slot
8159 expr (Passed directly)
8163 CONTIN_0(kernel_define_tree
,sc
);
8165 kernel_mapeval(sc
, K_NIL
,
8167 LIST2(REF_OPER (arg1
), formal
),
8172 /*_ . Misc Kernel functions */
8175 SIG_CHKARRAY(tracing
) = { REF_OPER(is_integer
), };
8176 DEF_SIMPLE_APPLICATIVE (ps0a1
, tracing
,T_NO_K
,ground
, "tracing")
8178 WITH_1_ARGS(trace_p
);
8179 int tr
= sc
->tracing
;
8180 sc
->tracing
= ivalue (trace_p
);
8181 return mk_integer (tr
);
8184 /*_ , new_tracing */
8186 SIG_CHKARRAY(new_tracing
) = { REF_OPER(is_integer
), };
8187 DEF_SIMPLE_APPLICATIVE (ps0a1
, new_tracing
,T_NO_K
,ground
, "new-tracing")
8189 WITH_1_ARGS(trace_p
);
8190 int tr
= sc
->new_tracing
;
8191 sc
->new_tracing
= ivalue (trace_p
);
8192 return mk_integer (tr
);
8196 /*_ , get-current-environment */
8197 DEF_APPLICATIVE_W_DESTR (ps0a0
, get_current_environment
, K_NO_TYPE
,T_NO_K
,ground
, "get-current-environment")
8198 { return sc
->envir
; }
8200 /*_ , arg1, $quote, list */
8201 DEF_APPLICATIVE_W_DESTR (ps0a1
, arg1
, K_ANY_SINGLETON
,T_NO_K
,ground
, "identity")
8206 /* Same, unwrapped */
8207 RGSTR(ground
, "$quote", REF_OPER(arg1
))
8210 RGSTR(ground
, "list", REF_APPL(val2val
))
8211 /* The underlying C function here is "arg1", but it's called with
8212 the whole argobject as arg1 */
8213 /* K_ANY instead of REF_OPER(is_finite_list) because we deliberately allow
8214 non-lists and improper lists. */
8215 DEF_CFUNC_RAW(OPER(val2val
),ps0a1
,arg1
,K_ANY
,T_NO_K
);
8216 DEF_BOXED_APPLICATIVE(val2val
, REF_OPER (val2val
));
8219 RGSTR(ground
,"exit",REF_OPER(k_quit
))
8220 DEF_CFUNC(ps0a0
,k_quit
,K_NO_TYPE
,0)
8222 if(!nest_depth_ok_p(sc
))
8223 { sc
->retcode
= 1; }
8226 return K_INERT
; /* Value is unused anyways */
8229 RGSTR(ground
,"gc",REF_OPER(k_gc
))
8230 DEF_CFUNC(ps0a0
,k_gc
,K_NO_TYPE
,0)
8238 RGSTR(ground
, "$if", REF_OPER(k_if
))
8239 FORWARD_DECL_CFUNC(static,ps0a3
,k_if_literal
);
8240 SIG_CHKARRAY(k_if
) = { K_ANY
, K_ANY
, K_ANY
, };
8241 DEF_SIMPLE_DESTR( k_if
);
8244 /* Store (test consequent alternative) */
8245 ANON_STORE(REF_DESTR(k_if
)),
8247 ANON_LOAD(ANON_LIST1(ANON_LOAD_IX( 0, 0 ))),
8248 /* value = (test) */
8250 REF_OPER(kernel_eval
),
8252 /* Store (test_result) */
8255 ANON_LOAD(ANON_LIST3(ANON_LOAD_IX( 0, 0 ),
8256 ANON_LOAD_IX( 1, 1 ),
8257 ANON_LOAD_IX( 1, 2 ))),
8259 /* test_result, consequent, alternative */
8260 REF_OPER(k_if_literal
),
8263 DEF_SIMPLE_CHAIN(k_if
);
8265 SIG_CHKARRAY(k_if_literal
) = { REF_OPER(is_bool
), K_ANY
, K_ANY
, };
8266 DEF_SIMPLE_CFUNC(ps0a3
,k_if_literal
,0)
8268 WITH_3_ARGS(test
, consequent
, alternative
);
8269 if(test
== K_T
) { return kernel_eval(sc
, consequent
, sc
->envir
); }
8270 if(test
== K_F
) { return kernel_eval(sc
, alternative
, sc
->envir
); }
8271 KERNEL_ERROR_1(sc
,"Must be a boolean: ", test
);
8274 /*_ . Routines for applicatives */
8275 BOX_OF_VOID (K_APPLICATIVE
);
8277 DEF_SIMPLE_PRED (is_applicative
,T_NO_K
,ground
, "applicative?/o1")
8280 return is_encap (REF_KEY(K_APPLICATIVE
), p
);
8283 DEF_SIMPLE_PRED (is_combiner
,T_NO_K
,ground
, "combiner?/o1")
8286 return is_applicative(p
) || is_operative(p
);
8289 SIG_CHKARRAY(wrap
) = { REF_OPER(is_combiner
) };
8290 DEF_SIMPLE_APPLICATIVE (p00a1
, wrap
,T_NO_K
,ground
, "wrap")
8293 return mk_encap (REF_KEY(K_APPLICATIVE
), p
);
8296 SIG_CHKARRAY(unwrap
) = { REF_OPER(is_applicative
) };
8297 DEF_SIMPLE_APPLICATIVE (ps0a1
, unwrap
,T_NO_K
,ground
, "unwrap")
8300 return unencap (sc
, REF_KEY(K_APPLICATIVE
), p
);
8303 SIG_CHKARRAY(unwrap_all
) = { REF_OPER(is_combiner
) };
8304 DEF_SIMPLE_APPLICATIVE (p00a1
, unwrap_all
,T_NO_K
,ground
, "unwrap-all")
8307 /* Wrapping does not allowing circular wrapping, so this will
8309 while(is_encap (REF_KEY(K_APPLICATIVE
), p
))
8310 { p
= unencap (0, REF_KEY(K_APPLICATIVE
), p
); }
8316 /*_ , is_operative */
8317 /* This can be hacked quicker by suppressing 1 more bit and testing
8318 * just once. Requires keeping those T_ types co-ordinated, though. */
8319 DEF_SIMPLE_PRED (is_operative
,T_NO_K
,ground
, "operative?/o1")
8323 is_type (p
, T_CFUNC
)
8324 || is_type (p
, T_CFUNC_RESUME
)
8325 || is_type (p
, T_CURRIED
)
8326 || is_type (p
, T_LISTLOOP
)
8327 || is_type (p
, T_CHAIN
)
8328 || is_type (p
, T_STORE
)
8329 || is_type (p
, T_LOAD
)
8330 || is_type (p
, T_TYPEP
);
8334 RGSTR(simple
, "$vau/3", REF_OPER(vau_1
))
8336 /* This is a simple vau for bootstrap. It handles just a single
8337 expression. It's in ground for now, but will be only in
8338 low-for-optimization later */
8340 /* $$IMPROVE ME Check that formals is a non-circular list with no
8341 duplicated symbols. If this check is typical for
8342 kernel_define_tree (probably), pass that an initially blank
8343 environment and it can check for symbols and error if they are
8346 eformal is almost REF_OPER(is_symbol) but must accept #ignore also.
8348 SIG_CHKARRAY(vau_1
) = { K_ANY
, K_ANY
, K_ANY
};
8349 DEF_SIMPLE_CFUNC (ps0a3
, vau_1
,0)
8351 pko env
= sc
->envir
;
8352 WITH_3_ARGS(formals
, eformal
, expression
);
8353 /* This defines a vau object. Evaluating it is different.
8356 /* $$IMPROVE ME Could compile the expression now, but that's not so
8357 easy in Kernel. At least make a hook for that. */
8359 /* Vau data is a list of the 4 things:
8360 The dynamic environment
8362 An immutable copy of the formals es
8363 An immutable copy of the expression
8365 $$IMPROVE ME Make not a list but a dedicated struct.
8370 copy_es_immutable(sc
, formals
),
8371 copy_es_immutable (sc
, expression
));
8373 mk_curried (dcrry_5VLLdotALL
, vau_data
, REF_OPER (eval_vau
));
8376 /*_ . Evaluation, Kernel style */
8377 /*_ , Calling operatives */
8379 /* Again, can't simply say REF_OPER(is_symbol) because it might be
8381 SIG_CHKARRAY(eval_vau
) =
8383 REF_OPER(is_environment
),
8387 DEF_SIMPLE_CFUNC (ps0a5
, eval_vau
,0)
8389 pko env
= sc
->envir
;
8390 WITH_5_ARGS(args
, old_env
, eformal
, formals
, expression
);
8392 /* Make a new environment, child of the static environment (which
8393 we get now while making the vau) and put it into the envir
8395 new_frame_in_env (sc
, old_env
);
8397 /* This will change in kernel_define, not here. */
8398 /* Bind the dynamic environment to the eformal symbol. */
8399 kernel_define_tree (sc
, env
, eformal
, sc
->envir
);
8401 /* Bind the formals (symbols) to the operands (values) treewise. */
8403 kt_destr_outcome outcome
=
8404 kernel_define_tree_aux(sc
, args
, formals
, sc
->envir
, &extra_result
);
8410 /* Later this may raise the error */
8412 case destr_must_call_k
:
8413 CONTIN_2 (dcrry_2dotALL
, kernel_eval
, sc
, expression
, sc
->envir
);
8414 schedule_rv_list (sc
, extra_result
);
8417 errx (7, "Unrecognized enumeration");
8420 /* Evaluate the expression. */
8421 return kernel_eval (sc
, expression
, sc
->envir
);
8424 /*_ , Kernel eval mutual callers */
8425 /*_ . kernel_eval */
8427 /* Optionally define a tracing kernel_eval */
8428 SIG_CHKARRAY(kernel_eval
) = { K_ANY
, REF_KEY(K_TYCH_OPTIONAL
), REF_OPER(is_environment
), };
8429 DEF_SIMPLE_DESTR(kernel_eval
);
8431 FORWARD_DECL_CFUNC(static,ps0a2
,kernel_real_eval
);
8432 DEF_APPLICATIVE_W_DESTR (ps0a2
, kernel_eval
, REF_DESTR(kernel_eval
),0,ground
, "eval")
8434 WITH_2_ARGS(form
, env
);
8435 /* $$RETHINK ME Set sc->envir here, remove arg from
8436 kernel_real_eval, and the tracing call will know its own env,
8437 it may just be a closure with form as value. */
8444 CONTIN_2 (dcrry_2dotALL
, kernel_real_eval
, sc
, form
, env
);
8445 putstr (sc
, "\nEval: ");
8446 CONTIN_1 (dcrry_1dotALL
, kernel_print_sexp
, sc
, form
);
8451 return kernel_real_eval (sc
, form
, env
);
8456 /* Define either kernel_eval (if not defined above) or kernel_real_eval */
8458 /* $$IMPROVE MY DESIGN Don't like the pointers being different
8459 levels of pointingness. In fact, we always potentially have
8460 tracing (or w/e) so let's lose the preprocessor condition. */
8462 DEF_CFUNC (ps0a2
, kernel_real_eval
, REF_DESTR(kernel_eval
),0)
8464 DEF_APPLICATIVE_W_DESTR (ps0a2
, kernel_eval
, REF_DESTR(kernel_eval
),0,ground
, "eval")
8468 WITH_2_ARGS(form
, env
);
8470 /* Evaluate form in env */
8472 form: form to be evaluated
8473 env: environment to evaluate it in.
8477 /* $$IMPROVE ME Let this be done in kernel_eval and lose the env
8478 argument, here just assert that we have an environment. */
8481 if (is_environment (env
))
8482 { sc
->envir
= env
; }
8485 KERNEL_ERROR_0 (sc
, "eval: Arg 2 must be an environment:");
8489 if (is_symbol (form
))
8491 pko x
= find_slot_in_env (env
, form
, 1);
8494 return slot_value_in_env (x
);
8498 KERNEL_ERROR_1 (sc
, "eval: unbound variable:", form
);
8502 else if (is_pair (form
))
8504 CONTIN_2 (dcrry_3VLLdotALL
, kernel_eval_aux
, sc
, cdr (form
), env
);
8505 return kernel_eval (sc
, car (form
), env
);
8507 /* Otherwise return the object literally. */
8513 /*_ . kernel_eval_aux */
8514 /* The stage of `eval' when we've already decided that we're to use a
8515 combiner and what that combiner is. */
8516 /* $$IMPROVE ME Lose the env argument, it's always sc->envir */
8517 SIG_CHKARRAY(kernel_eval_aux
) =
8518 { REF_OPER(is_combiner
), K_ANY
, REF_OPER(is_environment
), };
8519 DEF_SIMPLE_DESTR(kernel_eval_aux
);
8520 DEF_CFUNC (ps0a3
, kernel_eval_aux
, REF_DESTR(kernel_eval_aux
),0)
8522 WITH_3_ARGS(functor
, args
, env
);
8523 assert (is_environment (env
));
8525 functor: what the car of the form has evaluated to.
8526 args: cdr of form, as yet unevaluated.
8527 env: environment to evaluate in.
8529 k_profiling_new_frame(sc
, functor
);
8530 if(is_type(functor
, T_CFUNC
))
8532 return klink_call_cfunc(sc
, functor
, env
, args
);
8534 else if(is_type(functor
, T_CURRIED
))
8536 return call_curried(sc
, functor
, args
);
8538 else if(is_type(functor
, T_TYPEP
))
8540 /* $$MOVE ME Into something paralleling the other operative calls */
8541 /* $$IMPROVE ME Check arg number */
8544 { KERNEL_ERROR_1 (sc
, "Takes one arg: ", functor
); }
8545 return kernel_bool(call_T_typecheck(functor
,car(args
)));
8547 else if(is_type(functor
, T_LISTLOOP
))
8549 return eval_listloop(sc
, functor
,args
);
8551 else if(is_type(functor
, T_CHAIN
))
8553 return eval_chain( sc
, functor
, args
);
8555 else if ( is_type( functor
, T_STORE
))
8557 return k_do_store( sc
, functor
, args
);
8559 else if ( is_type( functor
, T_LOAD
))
8561 return k_do_load( sc
, functor
, args
);
8563 else if (is_applicative (functor
))
8566 Get the underlying operative.
8567 Evaluate arguments (may make frames)
8568 Use the oper on the arguments
8570 pko oper
= unwrap (sc
, functor
);
8573 get_list_metrics_aux(args
, metrics
);
8574 if(metrics
[lm_cyc_len
] != 0)
8576 KERNEL_ERROR_1 (sc
, "kernel_eval_aux: Arguments must be a list", args
);
8578 sc
->envir
= env
; /* $$IMPROVE ME Treat this cache better */
8579 CONTIN_2 (dcrry_2CA01VLLA02
, kernel_eval
, sc
, oper
, env
);
8583 CONTIN_3 (dcrry_4dotALL
, kernel_mapeval
, sc
, K_NIL
, args
, env
);
8584 CONTIN_1 (dcrry_1dotALL
, kernel_print_sexp
, sc
, args
);
8585 putstr (sc
, "\nApply to: ");
8590 { return kernel_mapeval (sc
, K_NIL
, args
, env
); }
8594 KERNEL_ERROR_1 (sc
, "eval: can't apply:", functor
);
8597 /*_ , Eval mappers */
8598 /*_ . kernel_mapeval */
8599 /* Evaluate each datum in list arg2, Kernel-returning a list of the results. */
8600 SIG_CHKARRAY(kernel_mapeval
) =
8601 { REF_OPER(is_finite_list
), REF_OPER(is_finite_list
), REF_OPER(is_environment
), };
8602 DEF_SIMPLE_DESTR(kernel_mapeval
);
8603 DEF_CFUNC (ps0a3
, kernel_mapeval
, REF_DESTR(kernel_mapeval
),0)
8606 WITH_3_ARGS(accum
, args
, env
);
8607 assert (is_environment (env
));
8610 * The list of evaluated arguments, in reverse order.
8611 * Purpose: Used as an accumulator.
8613 args: list of forms to be evaluated.
8614 * Precondition: Must be a proper list (is_list must give true)
8615 * When called by itself: The forms that remain yet to be evaluated
8617 env: The environment to evaluate in.
8620 /* If there are remaining arguments, arrange to evaluate one,
8621 add the result to accumulator, and return control here. */
8624 /* This can't be converted to a loop because we don't know
8625 whether kernel_eval_aux will create more frames. */
8626 CONTIN_3 (dcrry_3CVLLA01dotAX1
,
8627 kernel_mapeval
, sc
, accum
, cdr (args
), env
);
8628 return kernel_eval (sc
, car (args
), env
);
8630 /* If there are no remaining arguments, reverse the accumulator
8631 and return it. Can't reverse in place because other
8632 continuations might re-use the same accumulator state. */
8633 else if (args
== K_NIL
)
8634 { return reverse (sc
, accum
); }
8637 /* This shouldn't be reachable because we check for it being
8638 a list beforehand in kernel_eval_aux. */
8639 errx (4, "mapeval: arguments must be a list:");
8643 RGSTR(ground
,"$bad-sequence",REF_OPER(kernel_sequence
))
8644 SIG_CHKARRAY(kernel_sequence
) =
8645 { REF_KEY(K_TYCH_DOT
), REF_OPER(is_countable_list
), };
8646 DEF_SIMPLE_CFUNC(ps0a1
,kernel_sequence
,0)
8649 /* Ultimately return #inert */
8650 /* $$IMPROVE ME This shouldn't accumulate args only to discard
8652 CONTIN_0_RAW(mk_curried(dcrry_NdotALL
, K_INERT
, 0), sc
);
8653 return kernel_mapeval(sc
,K_NIL
,forms
,sc
->envir
);
8656 /*_ . kernel_mapand_aux */
8657 /* Call proc on each datum in args, Kernel-returning true if all
8658 succeed, otherwise false. */
8659 SIG_CHKARRAY(kernel_mapand_aux
) =
8660 { REF_OPER(is_bool
),
8661 REF_OPER(is_combiner
),
8662 REF_OPER(is_finite_list
),
8664 DEF_SIMPLE_CFUNC (ps0a3
, kernel_mapand_aux
,0)
8667 WITH_3_ARGS(ok
, proc
, args
);
8670 * Whether the last invocation of this succeeded. Initialize with
8673 * proc: A boolean combiner (predicate) to apply to these objects
8675 * args: list of objects to apply proc to
8676 * Precondition: Must be a proper list
8681 { KERNEL_ERROR_1(sc
, "kernel_mapand_aux: Must be boolean: ", ok
); }
8682 /* If there are remaining arguments, arrange to evaluate one and
8683 return control here. */
8686 /* This can't be converted to a loop because we don't know
8687 whether kernel_eval_aux will create more frames. */
8688 CONTIN_2 (dcrry_3VLLdotALL
,
8689 kernel_mapand_aux
, sc
, proc
, cdr (args
));
8690 return kernel_eval_aux (sc
, proc
, car (args
), sc
->envir
);
8692 /* If there are no remaining arguments, return true. */
8693 else if (args
== K_NIL
)
8697 /* This shouldn't be reachable because we check for it being a
8699 errx (4, "mapbool: arguments must be a list:");
8703 /*_ . kernel_mapand */
8704 SIG_CHKARRAY(kernel_mapand
) =
8705 { REF_OPER(is_combiner
),
8706 REF_OPER(is_finite_list
),
8708 DEF_SIMPLE_APPLICATIVE (ps0a2
, kernel_mapand
,0,simple
, "every?/2-xary")
8710 WITH_2_ARGS(proc
, args
);
8711 /* $$IMPROVE ME Get list metrics here and if we get a circular
8712 list, treat it correctly (How is TBD). */
8713 return kernel_mapand_aux(sc
,REF_KEY(K_T
), proc
, args
);
8715 /*_ . kernel_mapor_aux */
8716 /* Call proc on each datum in args, Kernel-returning true if all
8717 succeed, otherwise false. */
8718 SIG_CHKARRAY(kernel_mapor_aux
) =
8719 { REF_OPER(is_bool
),
8720 REF_OPER(is_combiner
),
8721 REF_OPER(is_finite_list
),
8723 DEF_SIMPLE_CFUNC (ps0a3
, kernel_mapor_aux
,0)
8726 WITH_3_ARGS(ok
, proc
, args
);
8729 * Whether the last invocation of this succeeded. Initialize with
8732 * proc: A boolean combiner (predicate) to apply to these objects
8734 * args: list of objects to apply proc to
8735 * Precondition: Must be a proper list
8740 { KERNEL_ERROR_1(sc
, "kernel_mapor_aux: Must be boolean: ", ok
); }
8741 /* If there are remaining arguments, arrange to evaluate one and
8742 return control here. */
8745 /* This can't be converted to a loop because we don't know
8746 whether kernel_eval_aux will create more frames. */
8747 CONTIN_2 (dcrry_3VLLdotALL
,
8748 kernel_mapor_aux
, sc
, proc
, cdr (args
));
8749 return kernel_eval_aux (sc
, proc
, car (args
), sc
->envir
);
8751 /* If there are no remaining arguments, return false. */
8752 else if (args
== K_NIL
)
8756 /* This shouldn't be reachable because we check for it being a
8758 errx (4, "mapbool: arguments must be a list:");
8761 /*_ . kernel_mapor */
8762 SIG_CHKARRAY(kernel_mapor
) =
8763 { REF_OPER(is_combiner
),
8764 REF_OPER(is_finite_list
),
8766 DEF_SIMPLE_APPLICATIVE (ps0a2
, kernel_mapor
,0,simple
, "some?/2-xary")
8768 WITH_2_ARGS(proc
, args
);
8769 /* $$IMPROVE ME Get list metrics here and if we get a circular
8770 list, treat it correctly (How is TBD). */
8771 return kernel_mapor_aux(sc
,REF_KEY(K_F
), proc
, args
);
8774 /*_ , Kernel combiners */
8776 /* $$IMPROVE ME Make referring to curried operatives neater. */
8777 RGSTR(ground
, "$and?", REF_OBJ(k_oper_andp
))
8778 DEF_BOXED_CURRIED(k_oper_andp
,
8780 REF_OPER(kernel_internal_eval
),
8781 REF_OPER(kernel_mapand
));
8784 RGSTR(ground
, "$or?", REF_OBJ(k_oper_orp
))
8785 DEF_BOXED_CURRIED(k_oper_orp
,
8787 REF_OPER(kernel_internal_eval
),
8788 REF_OPER(kernel_mapor
));
8791 /*_ . k_counted_map_aux */
8792 /* $$USE ME MORE Export both to simple: "counted-map1-car"
8793 "counted-map1-cdr" */
8795 k_counted_map_car(klink
* sc
, int count
, pko list
, _kt_tag t_enum
)
8798 pko rv_result
= K_NIL
;
8799 for(i
= 0; i
< count
; ++i
, list
= pair_cdr(0, list
))
8801 assert(is_pair(list
));
8802 pko obj
= pair_car(0, list
);
8803 rv_result
= v2cons (t_enum
, pair_car(sc
, obj
), rv_result
);
8806 /* Reverse the list in place. */
8807 return unsafe_v2reverse_in_place(K_NIL
, rv_result
);
8811 k_counted_map_cdr(klink
* sc
, int count
, pko list
, _kt_tag t_enum
)
8814 pko rv_result
= K_NIL
;
8815 for(i
= 0; i
< count
; ++i
, list
= pair_cdr(0, list
))
8817 assert(is_pair(list
));
8818 pko obj
= pair_car(0, list
);
8819 rv_result
= v2cons (t_enum
, pair_cdr(sc
, obj
), rv_result
);
8822 /* Reverse the list in place. */
8823 return unsafe_v2reverse_in_place(K_NIL
, rv_result
);
8826 /* Evaluate COUNT datums in list ARGS, Kernel-returning a list of the
8828 SIG_CHKARRAY(k_counted_map_aux
) =
8829 { REF_OPER(is_finite_list
),
8830 REF_OPER(is_integer
),
8831 REF_OPER(is_integer
),
8832 REF_OPER(is_operative
),
8833 REF_OPER(is_finite_list
),
8835 DEF_SIMPLE_APPLICATIVE (ps0a5
, k_counted_map_aux
, 0,simple
, "counted-map/5")
8837 WITH_5_ARGS(accum
, count
, len
, oper
, args
);
8838 assert (is_integer (count
));
8839 /* $$IMPROVE ME Check the other args too */
8843 * The list of evaluated arguments, in reverse order.
8844 * Purpose: Used as an accumulator.
8847 * The number of arguments remaining
8850 * The effective length of args.
8855 args: list of lists of arguments to this.
8857 * Precondition: Must be a proper list (is_finite_list must give
8858 true). args will not be cyclic, we'll check for and handle
8859 encycling outside of here.
8862 /* If there are remaining arguments, arrange to operate on one, cons
8863 the result to accumulator, and return control here. */
8864 if (ivalue (count
) > 0)
8866 assert(is_pair(args
));
8867 int len_v
= ivalue(len
);
8868 /* This can't be converted to a loop because we don't know
8869 whether kernel_eval_aux will create more frames.
8871 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8873 CONTIN_5 (dcrry_5CVLLA01dotAX1
,
8874 k_counted_map_aux
, sc
, accum
,
8875 mk_integer(ivalue(count
) - 1),
8878 k_counted_map_cdr(sc
, len_v
, args
, T_PAIR
));
8880 return kernel_eval_aux (sc
,
8882 k_counted_map_car(sc
, len_v
, args
, T_PAIR
),
8885 /* If there are no remaining arguments, reverse the accumulator
8886 and return it. Can't reverse in place because other
8887 continuations might re-use the same accumulator state. */
8889 { return reverse (sc
, accum
); }
8893 /*_ . counted-every?/5 */
8894 SIG_CHKARRAY(k_counted_every
) =
8895 { REF_OPER(is_bool
),
8896 REF_OPER(is_integer
),
8897 REF_OPER(is_integer
),
8898 REF_OPER(is_operative
),
8899 REF_OPER(is_finite_list
),
8901 DEF_SIMPLE_APPLICATIVE (ps0a5
, k_counted_every
,0,simple
,"counted-every?/5")
8903 WITH_5_ARGS(ok
, count
, len
, oper
, args
);
8904 assert (is_bool (ok
));
8905 assert (is_integer (count
));
8906 assert (is_integer (len
));
8910 * Whether the last invocation of this succeeded. Initialize with
8914 * The number of arguments remaining
8917 * The effective length of args.
8922 args: list of lists of arguments to this.
8924 * Precondition: Must be a proper list (is_finite_list must give
8925 true). args will not be cyclic, we'll check for and handle
8926 encycling outside of here.
8932 { KERNEL_ERROR_1(sc
, "k_counted_every: Must be boolean: ", ok
); }
8934 /* If there are remaining arguments, arrange to evaluate one and
8935 return control here. */
8936 if (ivalue (count
) > 0)
8938 assert(is_pair(args
));
8939 int len_v
= ivalue(len
);
8940 /* This can't be converted to a loop because we don't know
8941 whether kernel_eval_aux will create more frames.
8943 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8945 CONTIN_4 (dcrry_4VLLdotALL
,
8946 k_counted_every
, sc
,
8947 mk_integer(ivalue(count
) - 1),
8950 k_counted_map_cdr(sc
, len_v
, args
, T_PAIR
));
8952 return kernel_eval_aux (sc
,
8954 k_counted_map_car(sc
, len_v
, args
, T_PAIR
),
8957 /* If there are no remaining arguments, return true. */
8963 /*_ . counted-some?/5 */
8964 SIG_CHKARRAY(k_counted_some
) =
8965 { REF_OPER(is_bool
),
8966 REF_OPER(is_integer
),
8967 REF_OPER(is_integer
),
8968 REF_OPER(is_operative
),
8969 REF_OPER(is_finite_list
),
8971 DEF_SIMPLE_APPLICATIVE (ps0a5
, k_counted_some
,0,simple
,"counted-some?/5")
8973 WITH_5_ARGS(ok
, count
, len
, oper
, args
);
8974 assert (is_bool (ok
));
8975 assert (is_integer (count
));
8976 assert (is_integer (len
));
8981 { KERNEL_ERROR_1(sc
, "k_counted_some: Must be boolean: ", ok
); }
8983 /* If there are remaining arguments, arrange to evaluate one and
8984 return control here. */
8985 if (ivalue (count
) > 0)
8987 assert(is_pair(args
));
8988 int len_v
= ivalue(len
);
8989 /* This can't be converted to a loop because we don't know
8990 whether kernel_eval_aux will create more frames.
8992 $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8994 CONTIN_4 (dcrry_4VLLdotALL
,
8996 mk_integer(ivalue(count
) - 1),
8999 k_counted_map_cdr(sc
, len_v
, args
, T_PAIR
));
9001 return kernel_eval_aux (sc
,
9003 k_counted_map_car(sc
, len_v
, args
, T_PAIR
),
9006 /* If there are no remaining arguments, return false. */
9012 /*_ . Klink top level */
9013 /*_ , kernel_repl */
9014 DEF_CFUNC(ps0a0
, kernel_repl
, K_NO_TYPE
,0)
9016 /* If we reached the end of file, this loop is done. */
9017 port
*pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
9019 if (pt
->kind
& port_saw_EOF
)
9023 putstr (sc
, prompt
);
9025 assert (is_environment (sc
->envir
));
9027 /* Arrange another iteration */
9028 CONTIN_0 (kernel_repl
, sc
);
9029 klink_push_dyn_binding(sc
,K_PRINT_FLAG
,K_T
);
9030 klink_push_cont(sc
, REF_OBJ(print_value
));
9032 CONTIN_1 (dcrry_2A01VLL
, tracing_say
, sc
, mk_string("\nGives: "));
9034 CONTIN_0 (kernel_internal_eval
, sc
);
9035 CONTIN_0 (kernel_read_internal
, sc
);
9040 static const kt_vector rel_chain
=
9045 REF_OPER(kernel_read_internal
),
9046 REF_OPER(kernel_internal_eval
),
9047 REF_OPER(kernel_rel
),
9051 DEF_CFUNC(ps0a0
, kernel_rel
, K_NO_TYPE
,0)
9053 /* If we reached the end of file, this loop is done. */
9054 port
*pt
= portvalue (klink_find_dyn_binding(sc
,K_INPORT
));
9056 if (pt
->kind
& port_saw_EOF
)
9059 assert (is_environment (sc
->envir
));
9062 schedule_chain( sc
, &rel_chain
);
9064 /* Arrange another iteration */
9065 CONTIN_0 (kernel_rel
, sc
);
9066 CONTIN_0 (kernel_internal_eval
, sc
);
9067 CONTIN_0 (kernel_read_internal
, sc
);
9072 /*_ , kernel_internal_eval */
9073 /* Convert the aftermath of kernel_read_internal to something kernel_eval
9075 /* $$IMPROVE ME realize this as a currier. But it's not a curried
9076 object as such because it carries no internal data. */
9077 DEF_CFUNC (ps0a1
, kernel_internal_eval
, K_ANY
,0)
9080 if( sc
->new_tracing
)
9081 { klink_push_dyn_binding( sc
, K_TRACING
, K_T
); }
9082 return kernel_eval (sc
, value
, sc
->envir
);
9085 /*_ . Constructing environments */
9086 /*_ , Declarations for built-in environments */
9087 /* These are initialized before they are registered. */
9088 static pko print_lookup_env
= 0;
9089 static pko all_builtins_env
= 0;
9090 static pko ground_env
= 0;
9091 #define unsafe_env ground_env
9092 #define simple_env ground_env
9093 static pko typecheck_env_syms
= 0;
9095 /*_ , What to include */
9096 #ifndef COLLECT_RGSTRS /* If we're collecting, these files may not
9097 have been generated yet */
9098 const kernel_registerable preregister
[] =
9100 /* $$MOVE ME These others will move into dedicated arrays, and be
9101 combined so that they can all be seen in init.krn but not in
9103 #include "registerables/ground.inc"
9104 #include "registerables/unsafe.inc"
9105 #include "registerables/simple.inc"
9106 /* $$TRANSITIONAL */
9107 { "type?", REF_APPL(typecheck
), },
9108 { "do-destructure", REF_APPL(do_destructure
), },
9111 const kernel_registerable all_builtins
[] =
9113 #include "registerables/all-builtins.inc"
9116 const kernel_registerable print_lookup_rgsts
[] =
9118 { "#f", REF_KEY(K_F
), },
9119 { "#t", REF_KEY(K_T
), },
9120 { "#inert", REF_KEY(K_INERT
), },
9121 { "#ignore", REF_KEY(K_IGNORE
), },
9123 { "$quote", REF_OPER(arg1
), },
9125 /* $$IMPROVE ME Add the other quote-like symbols here. */
9126 /* quasiquote, unquote, unquote-splicing */
9130 const kernel_registerable typecheck_syms_rgsts
[] =
9132 #include "registerables/type-keys.inc"
9139 /* Bind each of an array of kernel_registerables into env. */
9141 k_register_list (const kernel_registerable
* list
, int count
, pko env
)
9145 assert (is_environment (env
));
9146 for (i
= 0; i
< count
; i
++)
9148 kernel_define (env
, mk_symbol (list
[i
].name
), list
[i
].data
);
9152 /*_ , k_regstrs_to_env */
9154 k_regstrs_to_env(const kernel_registerable
* list
, int count
)
9156 pko env
= make_new_frame(K_NIL
);
9157 k_register_list (list
, count
, env
);
9161 #define K_REGSTRS_TO_ENV(RGSTRS)\
9162 k_regstrs_to_env(RGSTRS, sizeof (RGSTRS) / sizeof (RGSTRS[0]))
9163 /*_ , setup_print_secondary_lookup */
9164 static pko print_lookup_unwraps
= 0;
9165 static pko print_lookup_to_xary
= 0;
9167 setup_print_secondary_lookup(void)
9169 /* Quick and dirty: Set up tables corresponding to the ground env
9170 and put the registering stuff in them. */
9171 /* What this really accomplishes is to make prepared lookup tables
9172 available for particular print operations. Later we'll use a
9173 more general approach and this will become just a cache. */
9174 print_lookup_unwraps
= make_new_frame(K_NIL
);
9175 print_lookup_to_xary
= make_new_frame(K_NIL
);
9177 const kernel_registerable
* list
= preregister
;
9178 int count
= sizeof (preregister
) / sizeof (preregister
[0]);
9179 for (i
= 0; i
< count
; i
++)
9181 pko obj
= list
[i
].data
;
9182 if(is_applicative(obj
))
9184 kernel_define (print_lookup_unwraps
,
9185 mk_symbol (list
[i
].name
),
9188 pko xary
= k_to_trivpred(obj
);
9189 if((xary
!= K_NIL
) && xary
!= obj
)
9191 kernel_define (print_lookup_to_xary
,
9192 mk_symbol (list
[i
].name
),
9198 /*_ , make-kernel-standard-environment */
9199 /* Though it would be neater for this to define ground environment if
9200 there is none, that would mean it would need the eval loop and so
9201 couldn't be done early. So it relies on the ground environment
9202 being already defined. */
9203 RGSTR(ground
,"make-kernel-standard-environment", REF_OPER(mk_std_environment
))
9204 DEF_CFUNC(p00a0
, mk_std_environment
, K_NO_TYPE
,T_NO_K
)
9207 return make_new_frame(ground_env
);
9210 /*_ . The eval cycle */
9212 /*_ . Make an error continuation */
9214 klink_record_error_cont (klink
* sc
, pko error_continuation
)
9216 /* Record error continuation. */
9217 kernel_define (sc
->envir
,
9218 mk_symbol ("error-continuation"),
9219 error_continuation
);
9220 /* Also record it in interpreter, so built-ins can see it w/o
9222 sc
->error_continuation
= error_continuation
;
9225 /*_ , Entry points */
9226 /*_ . Eval cycle that restarts on error */
9228 klink_cycle_restarting (klink
* sc
, pko combiner
)
9230 assert(is_combiner(combiner
));
9231 assert(is_environment(sc
->envir
));
9232 /* Arrange to stop if we ever reach where we started. */
9233 klink_push_cont (sc
, REF_OPER (k_quit
));
9235 /* Grab root continuation. */
9236 kernel_define (sc
->envir
,
9237 mk_symbol ("root-continuation"),
9238 current_continuation (sc
));
9240 /* Make main continuation */
9241 klink_push_cont (sc
, combiner
);
9243 /* Make error continuation on top of main continuation. */
9244 pko error_continuation
=
9245 extend_continuation_aux(sc
->dump
, REF_OPER(kernel_err
), sc
->envir
);
9247 klink_record_error_cont(sc
, error_continuation
);
9249 /* Conceptually sc->retcode is a keyed dynamic variable that
9253 /* $$RECONSIDER ME Maybe indicate quit value */
9255 /*_ . Eval cycle that terminates on error */
9257 klink_cycle_no_restart (klink
* sc
, pko combiner
)
9259 assert(is_combiner(combiner
));
9260 assert(is_environment(sc
->envir
));
9261 /* Arrange to stop if we ever reach where we started. */
9262 klink_push_cont (sc
, REF_OPER (k_quit
));
9264 /* Grab root continuation. */
9265 kernel_define (sc
->envir
,
9266 mk_symbol ("root-continuation"),
9267 current_continuation (sc
));
9269 /* Make error continuation that quits. */
9270 pko error_continuation
=
9271 extend_continuation_aux(sc
->dump
, REF_OPER(kernel_err_return
), sc
->envir
);
9273 klink_record_error_cont(sc
, error_continuation
);
9275 klink_push_cont (sc
, combiner
);
9277 /* Conceptually sc->retcode is a keyed dynamic variable that
9278 kernel_err sets. Actually it's entirely cached in the
9285 /*_ , _klink_cycle (Don't use this directly) */
9287 _klink_cycle (klink
* sc
)
9289 pko value
= K_INERT
;
9294 int i
= setjmp (sc
->pseudocontinuation
);
9298 int got_new_frame
= klink_pop_cont (sc
);
9299 /* $$RETHINK ME Is this test still needed? Could be just
9303 /* $$IMPROVE ME Instead, a function that governs
9305 if (sc
->new_tracing
)
9307 if(_get_type( sc
->next_func
) == T_NOTRACE
)
9309 sc
->next_func
= notrace_comb( sc
->next_func
);
9313 klink_find_dyn_binding(sc
, K_TRACING
);
9314 /* Now we know the other branch should have been
9316 if( !tracing
|| ( tracing
== K_F
))
9319 /* Enqueue a version that will execute without
9320 tracing. Its descendants will be traced. */
9321 CONTIN_0_RAW (mk_notrace(mk_curried(dcrry_1dotALL
,
9323 mk_notrace(sc
->next_func
))),
9325 switch (_get_type (sc
->next_func
))
9328 putstr (sc
, "\nLoad ");
9332 putstr (sc
, "\nStore ");
9336 putstr (sc
, "\nDecurry ");
9342 /* Find and print current frame depth */
9343 int depth
= curr_frame_depth (sc
->dump
);
9344 char * str
= sc
->strbuff
;
9345 snprintf (str
, STRBUFFSIZE
, "\n%d: ", depth
);
9348 klink_push_dyn_binding (sc
, K_TRACING
, K_F
);
9349 putstr (sc
, "Eval: ");
9350 value
= kernel_print_sexp (sc
,
9351 cons (sc
->next_func
, value
),
9358 value
= kernel_eval_aux (sc
, sc
->next_func
, value
, sc
->envir
);
9362 /* Stop looping if stack is empty. */
9367 /* Otherwise something jumped to a continuation. Get the
9368 value and keep looping. */
9373 /* In case we're called nested in another _klink_cycle, don't
9378 /*_ . Vtable interface */
9379 /* initialization of Klink */
9382 static struct klink_interface vtbl
=
9434 /* $$MOVE ME Later after I separate some headers
9435 This belongs in dynload.c, could be just:
9436 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9437 DEF_SIMPLE_APPLICATIVE(ps0a1,klink_load_ext,0,ground, "load-extension") {...}
9439 RGSTR(ground
, "load-extension", REF_APPL(klink_load_ext
))
9440 SIG_CHKARRAY(klink_load_ext
) = { REF_OPER(is_string
), };
9441 DEF_SIMPLE_DESTR(klink_load_ext
);
9442 DEF_CFUNC_PSYCNAME(ps0a1
,klink_load_ext
, REF_DESTR(klink_load_ext
),0);
9443 DEF_BOXED_APPLICATIVE(klink_load_ext
, REF_OPER (klink_load_ext
));
9449 /*_ . Initializing Klink */
9450 /*_ , Allocate and initialize */
9453 klink_alloc_init (FILE * in
, FILE * out
)
9455 klink
*sc
= (klink
*) GC_MALLOC (sizeof (klink
));
9456 if (!klink_init (sc
, in
, out
))
9467 /*_ , Initialization without allocation */
9469 klink_init (klink
* sc
, FILE * in
, FILE * out
)
9471 /* Init stack first, just in case something calls _klink_error_1. */
9472 dump_stack_initialize (sc
);
9473 /* Initialize ports early in case something prints. */
9474 /* $$IMPROVE ME Should accept general ports of appropriate in/out. */
9475 klink_set_input_port_file (sc
, in
);
9476 klink_set_output_port_file (sc
, out
);
9479 /* Why do we need this field if there is a static table? */
9484 sc
->new_tracing
= 0;
9487 { oblist
= oblist_initial_value (); }
9490 /* Add the Kernel built-ins */
9491 if(!print_lookup_env
)
9493 print_lookup_env
= K_REGSTRS_TO_ENV(print_lookup_rgsts
);
9495 if(!all_builtins_env
)
9497 all_builtins_env
= K_REGSTRS_TO_ENV(all_builtins
);
9499 if(!typecheck_env_syms
)
9500 { typecheck_env_syms
= K_REGSTRS_TO_ENV(typecheck_syms_rgsts
); }
9503 /** Register objects from hard-coded list. **/
9504 ground_env
= K_REGSTRS_TO_ENV(preregister
);
9505 /* $$TRANSITIONAL Set up special lookup tables related to preregister. */
9506 setup_print_secondary_lookup();
9507 /** Bind certain objects that we make at init time. **/
9508 kernel_define (ground_env
,
9509 mk_symbol ("print-lookup-env"),
9511 kernel_define (unsafe_env
,
9512 mk_symbol ("typecheck-special-syms"),
9513 typecheck_env_syms
);
9515 /** Read some definitions from a prolog **/
9516 /* We need an envir before klink_call, because that defines a
9517 few things. Those bindings are specific to one instance of
9518 the interpreter so they do not belong in anything shared such
9520 /* $$IMPROVE ME Something in the call chain (klink_call?) should
9521 guarantee an environment. Needn't have anything in it to
9523 sc
->envir
= make_new_frame(K_NIL
);
9525 /* Can't easily merge this with klink_load_named_file. Two
9526 difficulties: it uses klink_cycle_restarting while klink_call
9527 uses klink_cycle_no_restart, and here we need to control the
9528 load environment. */
9529 pko p
= port_from_filename (InitFile
, port_file
| port_input
);
9530 if (p
== K_NIL
) { return 0; }
9532 /* We can't use k_get_mod_fm_port to manage parameters because
9533 later we will need the environment to have several parents:
9534 ground, simple, unsafe, possibly more. */
9535 /* Params: `into' = ground environment */
9536 /* We can't share this with the previous frame-making, because
9537 it should not define in the same environment. */
9538 pko params
= make_new_frame(K_NIL
);
9539 kernel_define (params
, mk_symbol ("into"), ground_env
);
9540 pko env
= make_new_frame(ground_env
);
9541 kernel_define (env
, mk_symbol ("module-parameters"), params
);
9542 int retcode
= klink_call(sc
,
9543 REF_OPER(load_from_port
),
9545 if(retcode
) { return 0; }
9547 /* The load will have written various things into ground
9548 environment. sc->envir is unsuitable now because it is this
9549 load's environment. */
9552 assert (is_environment (ground_env
));
9553 sc
->envir
= make_new_frame(ground_env
);
9555 #if 1 /* Transitional. Leave this on for the moment */
9556 /* initialization of global pointers to special symbols */
9557 sc
->QUOTE
= mk_symbol ("quote");
9558 sc
->QQUOTE
= mk_symbol ("quasiquote");
9559 sc
->UNQUOTE
= mk_symbol ("unquote");
9560 sc
->UNQUOTESP
= mk_symbol ("unquote-splicing");
9561 sc
->COLON_HOOK
= mk_symbol ("*colon-hook*");
9562 sc
->SHARP_HOOK
= mk_symbol ("*sharp-hook*");
9569 klink_deinit (klink
* sc
)
9574 /*_ . Using Klink from C */
9575 /*_ , To set ports */
9577 klink_set_input_port_file (klink
* sc
, FILE * fin
)
9579 klink_push_dyn_binding(sc
,K_INPORT
,port_from_file (fin
, port_input
));
9583 klink_set_input_port_string (klink
* sc
, char *start
, char *past_the_end
)
9585 klink_push_dyn_binding(sc
,
9587 port_from_string (start
, past_the_end
, port_input
));
9591 klink_set_output_port_file (klink
* sc
, FILE * fout
)
9593 klink_push_dyn_binding(sc
,K_OUTPORT
,port_from_file (fout
, port_output
));
9597 klink_set_output_port_string (klink
* sc
, char *start
, char *past_the_end
)
9599 klink_push_dyn_binding(sc
,
9601 port_from_string (start
, past_the_end
, port_output
));
9603 /*_ , To set external data */
9605 klink_set_external_data (klink
* sc
, void *p
)
9612 /*_ . Load file (C) */
9615 klink_load_port (klink
* sc
, pko p
, int interactive
)
9624 klink_push_dyn_binding(sc
,K_INPORT
,p
);
9630 REF_OPER (kernel_repl
) :
9631 REF_OPER (kernel_rel
);
9632 klink_cycle_restarting (sc
, combiner
);
9636 /*_ , klink_load_file */
9638 klink_load_file (klink
* sc
, FILE * fin
)
9640 klink_load_port (sc
,
9641 port_from_file (fin
, port_file
| port_input
),
9645 /*_ , klink_load_named_file */
9647 klink_load_named_file (klink
* sc
, FILE * fin
, const char *filename
)
9650 port_from_filename (filename
, port_file
| port_input
),
9654 /*_ . load string (C) */
9657 klink_load_string (klink
* sc
, const char *cmd
)
9660 port_from_string ((char *)cmd
,
9661 (char *)cmd
+ strlen (cmd
),
9662 port_input
| port_string
),
9666 /*_ , Apply combiner */
9667 /* sc is presumed to be already set up.
9668 The final value or error argument is in sc->value.
9669 The return code is duplicated in sc->retcode.
9672 klink_call (klink
* sc
, pko func
, pko args
)
9674 klink_cycle_no_restart (sc
,
9675 mk_curried(dcrry_NdotALL
,args
,func
));
9680 /* This is completely unexercised. */
9683 klink_eval (klink
* sc
, pko obj
)
9685 klink_cycle_no_restart(sc
,
9686 mk_curried(dcrry_2dotALL
,
9687 LIST2(obj
,sc
->envir
),
9688 REF_OPER(kernel_eval
)));
9692 /*_ . Main (if standalone) */
9695 #if defined(__APPLE__) && !defined (OSX)
9699 extern MacTS_main (int argc
, char **argv
);
9701 int argc
= ccommand (&argv
);
9702 MacTS_main (argc
, argv
);
9708 MacTS_main (int argc
, char **argv
)
9712 main (int argc
, char **argv
)
9717 char *file_name
= 0; /* Was InitFile */
9725 if (argc
== 2 && strcmp (argv
[1], "-?") == 0)
9727 printf ("Usage: klink -?\n");
9728 printf ("or: klink [<file1> <file2> ...]\n");
9729 printf ("followed by\n");
9730 printf (" -1 <file> [<arg1> <arg2> ...]\n");
9731 printf (" -c <Kernel commands> [<arg1> <arg2> ...]\n");
9732 printf ("assuming that the executable is named klink.\n");
9733 printf ("Use - as filename for stdin.\n");
9737 /* Make error_continuation semi-safe until it's properly set. */
9738 sc
.error_continuation
= 0;
9739 int i
= setjmp (sc
.pseudocontinuation
);
9742 if (!klink_init (&sc
, stdin
, stdout
))
9744 fprintf (stderr
, "Could not initialize!\n");
9750 fprintf (stderr
, "Kernel error encountered while initializing!\n");
9754 /* $$IMPROVE ME Maybe use get_opts instead. */
9757 /* $$IMPROVE ME Add a principled way of sometimes including
9758 filename defined in environment. Eg getenv
9762 if(!file_name
) { break; }
9763 if (strcmp (file_name
, "-") == 0)
9767 else if (strcmp (file_name
, "-1") == 0 || strcmp (file_name
, "-c") == 0)
9770 /* $$FACTOR ME This is a messy way to distinguish command
9771 string from filename string */
9772 isfile
= (file_name
[1] == '1');
9773 file_name
= *argv
++;
9774 if (strcmp (file_name
, "-") == 0)
9780 fin
= fopen (file_name
, "r");
9783 /* Put remaining command-line args into *args* in envir. */
9784 for (; *argv
; argv
++)
9786 pko value
= mk_string (*argv
);
9787 args
= mcons (value
, args
);
9789 args
= unsafe_v2reverse_in_place (K_NIL
, args
);
9790 /* Instead, use (command-line) as accessor and provide the
9791 whole command line as a list of strings. */
9792 kernel_define (sc
.envir
, mk_symbol ("*args*"), args
);
9797 fin
= fopen (file_name
, "r");
9799 if (isfile
&& fin
== 0)
9801 fprintf (stderr
, "Could not open file %s\n", file_name
);
9807 /* $$IMPROVE ME Use klink_load_named_file, replacing the
9808 file-opening code, so we can report filename */
9809 klink_load_file (&sc
, fin
);
9813 klink_load_string (&sc
, file_name
);
9815 if (!isfile
|| fin
!= stdin
)
9817 if (sc
.retcode
!= 0)
9819 fprintf (stderr
, "Errors encountered reading %s\n",
9832 /* $$MAKE ME CLEANER Quick and dirty for now, we make an
9833 environment for this but let everything else modify ground
9834 env. I'd like to be more correct about that. */
9835 /* Make an interactive environment over ground_env. */
9836 new_frame_in_env (&sc
, sc
.envir
);
9837 klink_load_file (&sc
, stdin
);
9839 retcode
= sc
.retcode
;