klink.c

   1 /*_. Klink 0.0 */
   2 /* Interpreter for the Kernel programming language*/
   3 /*_ , Header */
   4 /*_  . Credits and License */
   5 /*
   6     Copyright (C) 2010,2011 Tom Breton (Tehom)
   7
   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.
  12
  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.
  17
  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/>.
  20  */
  21
  22 /*_  . Includes */
  23 #define _KLINK_SOURCE
  24 #include "klink-private.h"
  25 #ifndef WIN32
  26 # include <unistd.h>
  27 #endif
  28 #ifdef WIN32
  29 #define snprintf _snprintf
  30 #endif
  31 #if USE_DL
  32 # include "dynload.h"
  33 #endif
  34 #if USE_MATH
  35 # include <math.h>
  36 #endif
  37
  38 #include <limits.h>
  39 #include <float.h>
  40 #include <ctype.h>
  41 #include <assert.h>
  42 #include <err.h>
  43 #include <gc.h>
  44
  45 #if USE_STRCASECMP
  46 #include <strings.h>
  47 # ifndef __APPLE__
  48 #  define stricmp strcasecmp
  49 # endif
  50 #endif
  51
  52 /* Used for documentation purposes, to signal functions in 'interface' */
  53 #define INTERFACE
  54
  55 #include <string.h>
  56 #include <stdlib.h>
  57
  58 #ifdef __APPLE__
  59 static int
  60 stricmp (const char *s1, const char *s2)
  61 {
  62   unsigned char c1, c2;
  63   do
  64     {
  65       c1 = tolower (*s1);
  66       c2 = tolower (*s2);
  67       if (c1 < c2)
  68         return -1;
  69       else if (c1 > c2)
  70         return 1;
  71       s1++, s2++;
  72     }
  73   while (c1 != 0);
  74   return 0;
  75 }
  76 #endif /* __APPLE__ */
  77
  78 #if USE_STRLWR
  79 static const char *
  80 strlwr (char *s)
  81 {
  82   const char *p = s;
  83   while (*s)
  84     {
  85       *s = tolower (*s);
  86       s++;
  87     }
  88   return p;
  89 }
  90 #endif
  91
  92 /*_  . Configuration */
  93
  94 #define banner "Klink 0.0\n"
  95
  96 #ifndef prompt
  97 # define prompt "klink> "
  98 #endif
  99
 100 #ifndef InitFile
 101 # define InitFile "init.krn"
 102 #endif
 103
 104 /*_ , Internal declarations */
 105 /*_  . Macros */
 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
 113
 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)
 118
 119 #define FORWARD_DECL_PRED(LINKAGE,C_NAME)       \
 120   FORWARD_DECL_CFUNC(LINKAGE,b00a1,C_NAME)
 121
 122 #define FORWARD_DECL_T_PRED(LINKAGE,C_NAME)     \
 123   LINKAGE kt_boxed_T OPER(C_NAME)
 124
 125 #define FORWARD_DECL_CHAIN(LINKAGE,C_NAME)      \
 126   LINKAGE kt_boxed_vector OPER(C_NAME)
 127
 128 #define FORWARD_DECL_APPLICATIVE(LINKAGE,SUFFIX,C_NAME) \
 129   FORWARD_DECL_CFUNC(LINKAGE,SUFFIX,C_NAME);            \
 130   kt_boxed_encap APPLICATIVE(C_NAME);                   \
 131
 132
 133 /*_   , WITH_ARGS */
 134 /* No noun/number agreement for WITH_1_ARGS because I prefer name
 135    regularity. */
 136 #define WITH_1_ARGS(A1)                         \
 137   pko A1 = arg1
 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 */
 150 #define DEF_VEC(T_ENUM, NAME, ARRAY_NAME)                       \
 151   kt_boxed_vector NAME =                                        \
 152   {                                                             \
 153     T_ENUM,                                                     \
 154     {                                                           \
 155       sizeof(ARRAY_NAME)/sizeof(ARRAY_NAME[0]),                 \
 156       ARRAY_NAME,                                               \
 157     },                                                          \
 158   }                                                             \
 159
 160 /*_   , Checking type */
 161 /*_    . Certain destructurers and type checks */
 162 #define K_ANY REF_OPER(is_any)
 163 #define K_NO_TYPE       REF_KEY(K_TYCH_NO_TYPE)
 164 #define K_ANY_SINGLETON REF_OBJ(_K_any_singleton)
 165
 166 /*_    . Internal: Arrays to be in typechecks and destructurers */
 167 /* Elements of this array should not call Kernel - should be T_NO_K */
 168 /* $$IMPROVE ME  Check that when registering combiners */
 169 #define SIG_CHKARRAY(C_NAME) pko CHKARRAY(C_NAME)[]
 170 /*_    . Boxed destructurers */
 171 #define REF_DESTR(C_NAME) REF_OBJ(DESTR_NAME(C_NAME))
 172 #define DEF_DESTR(NAME,ARRAY_NAME)                                      \
 173   DEF_VEC(T_DESTRUCTURE | T_IMMUTABLE | T_NO_K, NAME, ARRAY_NAME)
 174
 175 #define DEF_SIMPLE_DESTR(C_NAME)                        \
 176   DEF_DESTR(DESTR_NAME(C_NAME), CHKARRAY(C_NAME))
 177
 178
 179 /*_   , BOX macros */
 180 /*_    . Allocators */
 181 /* Awkward because we both declare stuff and assign stuff. */
 182 #define ALLOC_BOX(NAME,T_ENUM,BOXTYPE)                          \
 183   typedef BOXTYPE _TT;                                          \
 184   _TT * NAME = GC_MALLOC(sizeof(_TT));                          \
 185   NAME->type = T_ENUM
 186
 187 /* ALLOC_BOX_PRESUME defines the following:
 188    pbox - a pointer to the box
 189    pdata - a pointer to the box's contents
 190  */
 191 #define ALLOC_BOX_PRESUME(TYPE,T_ENUM)                  \
 192   TYPE * pdata;                                         \
 193   ALLOC_BOX(pbox,T_ENUM,BOX_OF(TYPE));                  \
 194   pdata = &(pbox)->data
 195
 196 /*_    . Unboxers */
 197 /*_     , General */
 198 #define WITH_BOX_TYPE(NAME,P)                                   \
 199   _kt_tag * NAME = &((kt_boxed_any *)(P))->type;
 200
 201 /*_     , Raw */
 202 /* This could mostly be an inlined function, but it wouldn't know
 203    types. */
 204 #define WITH_UNBOXED_RAW(P,NAME,TYPE,BOXTYPE)           \
 205   TYPE * NAME;                                          \
 206   {                                                     \
 207     typedef BOXTYPE _TT;                                \
 208     _TT * _pbox = (_TT *)(P);                           \
 209     NAME = &_pbox->data;                                \
 210   }
 211
 212 /*_     , Entry points */
 213 #define WITH_UNBOXED_UNSAFE(NAME,TYPE,P)                \
 214   WITH_UNBOXED_RAW(P,NAME,TYPE,BOX_OF(TYPE))
 215
 216
 217 /* WITH_PSYC_UNBOXED defines the following:
 218    pdata - a pointer to the box's contents
 219  */
 220 #define WITH_PSYC_UNBOXED(TYPE,P,T_ENUM,SC)     \
 221   assert_type(SC,(P),T_ENUM);                   \
 222   WITH_UNBOXED_UNSAFE(pdata,TYPE,P)
 223
 224 /*_   , Boxes of */
 225 /*_    . void */
 226 #define REF_KEY(NAME) REF_OBJ(KEY(NAME))
 227
 228 #define BOX_OF_VOID(NAME)                               \
 229   kt_boxed_void KEY(NAME) = { T_KEY | T_IMMUTABLE };    \
 230   pko NAME = REF_KEY(NAME)
 231
 232 /*_    . Operatives */
 233 /* All operatives use this, regardless whether they are cfuncs,
 234    curried, etc. */
 235 #define REF_OPER(C_NAME) REF_OBJ(OPER(C_NAME))
 236
 237 /*_    . Cfuncs */
 238 #define DEF_CFUNC_RAW(NAME,SUFFIX,C_NAME,DESTR,XTRA_FLAGS)              \
 239   RGSTR(all-builtins,"C-" #C_NAME, REF_OBJ (NAME))                      \
 240   kt_boxed_cfunc NAME =                                                 \
 241     { T_CFUNC | T_IMMUTABLE | XTRA_FLAGS,                               \
 242     {{C_NAME}, klink_ftype_##SUFFIX, DESTR, 0}};
 243
 244 #define DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME, DESTR,XTRA_FLAGS)             \
 245   DEF_CFUNC_RAW(OPER(C_NAME),SUFFIX,C_NAME, DESTR,XTRA_FLAGS)
 246
 247 #define DEF_CFUNC(SUFFIX,C_NAME,DESTR,XTRA_FLAGS)       \
 248   KERNEL_FUN_SIG_##SUFFIX(C_NAME);                      \
 249   DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS);   \
 250   KERNEL_FUN_SIG_##SUFFIX(C_NAME)
 251
 252 #define DEF_SIMPLE_CFUNC(SUFFIX,C_NAME,XTRA_FLAGS)              \
 253   DEF_SIMPLE_DESTR(C_NAME);                                     \
 254   KERNEL_FUN_SIG_##SUFFIX(C_NAME);                              \
 255   DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS);       \
 256   KERNEL_FUN_SIG_##SUFFIX(C_NAME)
 257
 258 /*_    . Applicatives */
 259 #define REF_APPL(C_NAME) REF_OBJ(APPLICATIVE(C_NAME))
 260
 261 #define DEF_BOXED_APPLICATIVE(C_NAME,FF)        \
 262   kt_boxed_encap APPLICATIVE (C_NAME) =         \
 263   { T_ENCAP | T_IMMUTABLE,                      \
 264     {REF_KEY(K_APPLICATIVE), FF}};
 265
 266 #define DEF_APPLICATIVE_W_DESTR(SUFFIX,C_NAME,DESTR,XTRA_FLAGS,RG,K_NAME) \
 267   RGSTR(RG,K_NAME, REF_APPL(C_NAME))                                    \
 268   KERNEL_FUN_SIG_##SUFFIX(C_NAME);                                      \
 269   DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,DESTR,XTRA_FLAGS);                   \
 270   DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME));                     \
 271   KERNEL_FUN_SIG_##SUFFIX(C_NAME)
 272
 273 #define DEF_SIMPLE_APPLICATIVE(SUFFIX,C_NAME,XTRA_FLAGS,RG,K_NAME)      \
 274   RGSTR(RG,K_NAME, REF_APPL(C_NAME))                                    \
 275   DEF_SIMPLE_DESTR(C_NAME);                                             \
 276   KERNEL_FUN_SIG_##SUFFIX(C_NAME);                                      \
 277   DEF_CFUNC_PSYCNAME(SUFFIX,C_NAME,REF_DESTR(C_NAME),XTRA_FLAGS);       \
 278   DEF_BOXED_APPLICATIVE(C_NAME, REF_OPER (C_NAME));                     \
 279   KERNEL_FUN_SIG_##SUFFIX(C_NAME)
 280
 281 /*_    . Abbreviations for predicates */
 282 /* The underlying C function takes the whole value as its sole arg.
 283    Above that, in init.krn an applicative wrapper applies it over a
 284    list, using `every?'.
 285  */
 286 #define DEF_SIMPLE_PRED(C_NAME,XTRA_FLAGS,RG,K_NAME)    \
 287   RGSTR(RG,K_NAME, REF_OPER(C_NAME))                    \
 288   DEF_CFUNC(b00a1,C_NAME,K_ANY_SINGLETON,XTRA_FLAGS)
 289
 290 /* The cfunc is there just to be exported for C use. */
 291 #define DEF_T_PRED(C_NAME,T_ENUM,RG,K_NAME)                     \
 292   RGSTR(RG,K_NAME, REF_OPER(C_NAME))                            \
 293   kt_boxed_T OPER(C_NAME) =                                     \
 294   { T_TYPEP | T_IMMUTABLE | T_NO_K, {T_ENUM}};                  \
 295   int C_NAME(pko p) { return is_type(p,T_ENUM); }
 296
 297
 298 /*_    . Curried Functions */
 299
 300 #define DEF_BOXED_CURRIED(CURRY_NAME,DECURRIER,ARGS,NEXT)       \
 301   RGSTR(all-builtins,"C-" #CURRY_NAME, REF_OBJ (CURRY_NAME))    \
 302   kt_boxed_curried CURRY_NAME =                                 \
 303   { T_CURRIED  | T_IMMUTABLE,                                   \
 304     {DECURRIER, ARGS, NEXT, 0}};
 305 /*_    . Pairs */
 306 #define DEF_BOXED_PAIR(C_NAME,CAR,CDR)  \
 307   boxed_vec2 C_NAME =                   \
 308     { T_PAIR | T_IMMUTABLE, {CAR, CDR, }}
 309
 310 /* $$OBSOLESCENT */
 311 #define DEF_LISTSTAR2 DEF_BOXED_PAIR
 312
 313 #define DEF_LISTSTAR3(C_NAME,A1,A2,A3) \
 314   DEF_BOXED_PAIR(C_NAME##__1,A2,A3);   \
 315   DEF_BOXED_PAIR(C_NAME,A1,REF_OBJ(C_NAME##__1))
 316
 317 #define DEF_LIST1(C_NAME,A1)    DEF_LISTSTAR2(C_NAME,A1,   REF_KEY(K_NIL))
 318 #define DEF_LIST2(C_NAME,A1,A2) DEF_LISTSTAR3(C_NAME,A1,A2,REF_KEY(K_NIL))
 319
 320 /*_   , Building objects in C */
 321 #define ANON_OBJ( TYPE, X )                     \
 322   (((BOX_OF( TYPE )[]) { X })[0])
 323
 324 /* Middle is the same as ANON_OBJ but we can't just use that because
 325    of expansion issues */
 326 #define ANON_REF( TYPE, X )                     \
 327   REF_OBJ((((BOX_OF( TYPE )[]) { X })[0]))
 328
 329 #define PAIR_DEF( CAR, CDR )                    \
 330   { T_PAIR | T_IMMUTABLE, { CAR, CDR, }, }
 331
 332 #define ANON_PAIR( CAR, CDR ) \
 333   ANON_REF(kt_vec2, PAIR_DEF( CAR, CDR ))
 334
 335 #define INT_DEF( N )                            \
 336   { T_NUMBER | T_IMMUTABLE, { 1, { N }, }, }
 337
 338
 339 /*_   , Building lists in C */
 340 /*_    . Anonymous lists */
 341 /*_     , Dotted */
 342 #define ANON_LISTSTAR2(A1, A2)                  \
 343   ANON_PAIR(A1, A2)
 344
 345 #define ANON_LISTSTAR3(A1, A2, A3)              \
 346   ANON_PAIR(A1, ANON_LISTSTAR2(A2, A3))
 347
 348 #define ANON_LISTSTAR4(A1, A2, A3, A4)          \
 349   ANON_PAIR(A1, ANON_LISTSTAR3(A2, A3, A4))
 350
 351 /*_     , Undotted */
 352 #define ANON_LIST1(A1) \
 353   ANON_LISTSTAR2(A1, REF_KEY(K_NIL))
 354
 355 #define ANON_LIST2(A1, A2)                      \
 356   ANON_PAIR(A1, ANON_LIST1(A2))
 357
 358 #define ANON_LIST3(A1, A2, A3)                  \
 359   ANON_PAIR(A1, ANON_LIST2(A2, A3))
 360
 361 #define ANON_LIST4(A1, A2, A3, A4)              \
 362   ANON_PAIR(A1, ANON_LIST3(A2, A3, A4))
 363
 364 #define ANON_LIST5(A1, A2, A3, A4, A5)          \
 365   ANON_PAIR(A1, ANON_LIST4(A2, A3, A4, A5))
 366
 367 #define ANON_LIST6(A1, A2, A3, A4, A5, A6)      \
 368   ANON_PAIR(A1, ANON_LIST5(A2, A3, A4, A5, A6))
 369
 370
 371 /*_    . Dynamic lists */
 372 /*_     , Dotted */
 373 #define LISTSTAR2(A1, A2)                       \
 374   cons (A1, A2)
 375 #define LISTSTAR3(A1, A2, A3)                   \
 376   cons (A1, LISTSTAR2(A2, A3))
 377 #define LISTSTAR4(A1, A2, A3, A4)               \
 378   cons (A1, LISTSTAR3(A2, A3, A4))
 379
 380 /*_     , Undotted */
 381
 382 #define LIST1(A1)                               \
 383   cons (A1, K_NIL)
 384 #define LIST2(A1, A2)                           \
 385   cons (A1, LIST1 (A2))
 386 #define LIST3(A1, A2, A3)                       \
 387   cons (A1, LIST2 (A2, A3))
 388 #define LIST4(A1, A2, A3, A4)                   \
 389   cons (A1, LIST3 (A2, A3, A4))
 390 #define LIST5(A1, A2, A3, A4, A5)               \
 391   cons (A1, LIST4 (A2, A3, A4, A5))
 392 #define LIST6(A1, A2, A3, A4, A5, A6)           \
 393   cons (A1, LIST5 (A2, A3, A4, A5, A6))
 394
 395 /*_   , Kernel continuation macros */
 396 /*_    . W/o decurrying */
 397 #define CONTIN_0_RAW(C_NAME,SC)                 \
 398   klink_push_cont((SC), (C_NAME))
 399 #define CONTIN_0(OPER_NAME,SC)                  \
 400   klink_push_cont((SC), REF_OPER (OPER_NAME))
 401
 402 /*_    . Dotting */
 403 /* The use of REF_OPER requires these to be macros. */
 404
 405 #define CONTIN_1R(DECURRIER,C_NAME,SC,ARGS)                             \
 406   klink_push_cont((SC),                                                 \
 407                   mk_curried(DECURRIER, ARGS, REF_OPER (C_NAME)))
 408
 409 #define CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,ARG2)                        \
 410   CONTIN_1R(DECURRIER,C_NAME,SC,cons(ARG1,ARG2))
 411
 412 #define CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3)                   \
 413   CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,cons(ARG2,ARG3))
 414
 415 #define CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4)              \
 416   CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,cons(ARG3,ARG4))
 417
 418 #define CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5)         \
 419   CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,cons(ARG4,ARG5))
 420
 421 #define CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,ARG6)    \
 422   CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,cons(ARG5,ARG6))
 423
 424
 425 /*_    . Straight */
 426 #define CONTIN_1(DECURRIER,C_NAME,SC,ARG1)      \
 427   CONTIN_2R(DECURRIER,C_NAME,SC,ARG1,K_NIL)
 428
 429 #define CONTIN_2(DECURRIER,C_NAME,SC,ARG1,ARG2)         \
 430   CONTIN_3R(DECURRIER,C_NAME,SC,ARG1,ARG2,K_NIL)
 431
 432 #define CONTIN_3(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3)    \
 433   CONTIN_4R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,K_NIL)
 434
 435 #define CONTIN_4(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4)       \
 436   CONTIN_5R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,K_NIL)
 437
 438 #define CONTIN_5(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5)  \
 439   CONTIN_6R(DECURRIER,C_NAME,SC,ARG1,ARG2,ARG3,ARG4,ARG5,K_NIL)
 440
 441 /*_   , C to bool */
 442 #define kernel_bool(tf)    ((tf) ? K_T : K_F)
 443
 444 /*_   , Control macros */
 445
 446 /* These never return because _klink_error_1 longjmps. */
 447 /* $$IMPROVE ME If GCC is used or C99 is available, use __func__ as the function name. */
 448 #define KERNEL_ERROR_1(sc,s, a) { _klink_error_1(sc,s,a); return 0; }
 449 #define KERNEL_ERROR_0(sc,s)    { _klink_error_1(sc,s,0); return 0; }
 450
 451 /*_  . Enumerations */
 452 /*_   , The port types & flags */
 453
 454 enum klink_port_kind
 455 {
 456   port_free = 0,
 457   port_file = 1,
 458   port_string = 2,
 459   port_srfi6 = 4,
 460   port_input = 16,
 461   port_output = 32,
 462   port_saw_EOF = 64,
 463 };
 464
 465 /*_   , Tokens */
 466
 467 typedef enum klink_token
 468 {
 469   TOK_LPAREN,
 470   TOK_RPAREN,
 471   TOK_DOT,
 472   TOK_ATOM,
 473   TOK_QUOTE,
 474   TOK_COMMENT,
 475   TOK_DQUOTE,
 476   TOK_BQUOTE,
 477   TOK_COMMA,
 478   TOK_ATMARK,
 479   TOK_SHARP,
 480   TOK_SHARP_CONST,
 481   TOK_VEC,
 482
 483   TOK_EOF = -1,
 484 } token_t;
 485 /*_   , List metrics */
 486 typedef enum
 487 {
 488   lm_num_pairs,
 489   lm_num_nils,
 490   lm_acyc_len,
 491   lm_cyc_len,
 492   lm_max,
 493 } lm_index;
 494 typedef int int4[lm_max];
 495
 496 /*_  . Struct definitions */
 497
 498 /*_   , FF */
 499 typedef BOX_OF (kt_cfunc)
 500 kt_boxed_cfunc;
 501
 502 /*_   , Encap */
 503 typedef
 504 struct
 505 {
 506   /* Object identity lets us compare instances. */
 507   pko  type;
 508   pko  value;
 509 } kt_encap;
 510
 511 typedef BOX_OF (kt_encap)
 512 kt_boxed_encap;
 513
 514 /*_   , Curried calls */
 515
 516 typedef pko (* decurrier_f) (klink * sc, pko args, pko value);
 517
 518 typedef
 519 struct
 520 {
 521   decurrier_f decurrier;
 522   pko     args;
 523   pko     next;
 524   pko     argcheck;
 525 } kt_curried;
 526
 527 typedef BOX_OF (kt_curried)
 528 kt_boxed_curried;
 529
 530 /*_   , T_typep calls */
 531 /*_    . Structures */
 532 typedef struct
 533 {
 534   _kt_tag T_tag;
 535 } typep_t;
 536
 537 typedef BOX_OF(typep_t)
 538 kt_boxed_T;
 539
 540 /*_   , Ports */
 541
 542   typedef struct port
 543   {
 544     unsigned char kind;
 545     union
 546     {
 547       struct
 548       {
 549         FILE *file;
 550         int closeit;
 551 #if SHOW_ERROR_LINE
 552         int curr_line;
 553         char *filename;
 554 #endif
 555       } stdio;
 556       struct
 557       {
 558         char *start;
 559         char *past_the_end;
 560         char *curr;
 561       } string;
 562     } rep;
 563   } port;
 564 /*_   , Vectors */
 565 typedef struct
 566 {
 567   long int len;
 568   pko * els;
 569 } kt_vector;
 570
 571 typedef BOX_OF(kt_vector)
 572 kt_boxed_vector;
 573
 574 /*_  . Signatures */
 575 /*_   , Initialization */
 576 static void klink_setup_error_cont (klink * sc);
 577 static void klink_cycle_restarting (klink * sc, pko combiner);
 578 static int  klink_cycle_no_restart (klink * sc, pko combiner);
 579 static void _klink_cycle (klink * sc);
 580
 581
 582 /*_   , Error handling */
 583 static void _klink_error_1 (klink * sc, const char *s, pko a);
 584 /*_    . Stack control */
 585 static int klink_pop_cont (klink * sc);
 586
 587 /*_   , Evaluation */
 588 static pko klink_call_cfunc (klink * sc, pko functor, pko env, pko args);
 589 FORWARD_DECL_CFUNC (static, ps0a2, k_resume_to_cfunc);
 590
 591 /*_    . load */
 592 extern pko
 593 mk_load_ix (int x, int y);
 594 extern pko
 595 mk_load (pko data);
 596 /*_    . store */
 597 extern pko
 598 mk_store (pko data, int depth);
 599 /*_    . curried */
 600 /* $$DEPRECATED */
 601 static pko
 602 call_curried(klink * sc, pko curried, pko value);
 603
 604 /*_   , Top level operatives */
 605 FORWARD_DECL_APPLICATIVE(static,ps0a0,kernel_repl);
 606 FORWARD_DECL_APPLICATIVE(static,ps0a0,kernel_rel);
 607 FORWARD_DECL_APPLICATIVE(static,ps0a1,kernel_internal_eval);
 608
 609 /*_   , Oblist */
 610 static INLINE pko oblist_find_by_name (const char *name);
 611 static pko oblist_add_by_name (const char *name);
 612
 613 /*_   , Numbers */
 614 static pko mk_number (num n);
 615 /*_    . Operations */
 616 static num num_add (num a, num b);
 617 static num num_mul (num a, num b);
 618 static num num_div (num a, num b);
 619 static num num_intdiv (num a, num b);
 620 static num num_sub (num a, num b);
 621 static num num_rem (num a, num b);
 622 static num num_mod (num a, num b);
 623 static int num_eq (num a, num b);
 624 static int num_gt (num a, num b);
 625 static int num_ge (num a, num b);
 626 static int num_lt (num a, num b);
 627 static int num_le (num a, num b);
 628
 629 #if USE_MATH
 630 static double round_per_R5RS (double x);
 631 #endif
 632
 633 /*_   , Lists and vectors */
 634 FORWARD_DECL_PRED (extern, is_finite_list);
 635 FORWARD_DECL_PRED (extern, is_countable_list);
 636 extern int list_length (pko a);
 637 static pko reverse (klink * sc, pko a);
 638 static pko unsafe_v2reverse_in_place (pko term, pko list);
 639 static pko append (klink * sc, pko a, pko b);
 640
 641 static pko alloc_basvector (int len, _kt_tag t_enum);
 642 static void unsafe_basvector_fill (pko vec, pko obj);
 643
 644 static pko mk_vector (int len, pko fill);
 645 INTERFACE static void fill_vector (pko vec, pko obj);
 646 INTERFACE static pko vector_elem (pko vec, int ielem);
 647 INTERFACE static void set_vector_elem (pko vec, int ielem, pko a);
 648 INTERFACE static int vector_len (pko vec);
 649 extern void
 650 get_list_metrics_aux (pko a, int4 presults);
 651
 652 extern pko
 653 k_counted_map_car(klink * sc, int count, pko list, _kt_tag t_enum);
 654 extern pko
 655 k_counted_map_cdr(klink * sc, int count, pko list, _kt_tag t_enum);
 656
 657 /*_   , Ports */
 658 static pko port_from_filename (const char *fn, int prop);
 659 static pko port_from_file (FILE *, int prop);
 660 static pko port_from_string (char *start, char *past_the_end, int prop);
 661 static void port_close (pko p, int flag);
 662 static void port_finalize_file(GC_PTR obj, GC_PTR client_data);
 663 static port *port_rep_from_filename (const char *fn, int prop);
 664 static port *port_rep_from_file (FILE *, int prop);
 665 static port *port_rep_from_string (char *start, char *past_the_end, int prop);
 666 static void port_close_port (port * pt, int flag);
 667 INLINE port * portvalue (pko p);
 668 static int basic_inchar (port * pt);
 669 static int inchar (port *pt);
 670 static void backchar (port * pt, int c);
 671 /*_   , Typechecks */
 672 FORWARD_DECL_APPLICATIVE (extern,ps0a1, mk_typecheck);
 673 FORWARD_DECL_APPLICATIVE (extern,ps0a1, mk_destructurer);
 674 FORWARD_DECL_CFUNC (extern, ps0a4, destructure_resume);
 675 FORWARD_DECL_PRED (extern, is_any);
 676 FORWARD_DECL_T_PRED (extern, is_environment);
 677 FORWARD_DECL_PRED (extern, is_integer);
 678 /*_   , Promises */
 679 FORWARD_DECL_CFUNC (extern,ps0a2,handle_promise_result);
 680 FORWARD_DECL_CFUNC (extern, ps0a1, mk_promise_lazy);
 681 FORWARD_DECL_APPLICATIVE (extern, ps0a1, force);
 682 /*_   , About encapsulation */
 683 FORWARD_DECL_CFUNC (static,b00a2, is_encap);
 684 FORWARD_DECL_CFUNC (static,p00a2, mk_encap);
 685 FORWARD_DECL_CFUNC (static,ps0a2, unencap);
 686 FORWARD_DECL_APPLICATIVE (extern,p00a0, mk_encapsulation_type);
 687
 688 /*_   , About combiners per se */
 689 FORWARD_DECL_PRED(extern,is_combiner);
 690 /*_   , About operatives */
 691 FORWARD_DECL_PRED(extern,is_operative);
 692 extern void
 693 schedule_rv_list(klink * sc, pko list);
 694
 695 /*_   , About applicatives */
 696
 697 FORWARD_DECL_PRED(extern,is_applicative);
 698 FORWARD_DECL_APPLICATIVE(extern,p00a1,wrap);
 699 FORWARD_DECL_APPLICATIVE(extern,ps0a1,unwrap);
 700 FORWARD_DECL_APPLICATIVE(extern,p00a1,unwrap_all);
 701
 702 /*_   , About currying */
 703 static INLINE int
 704 is_curried (pko p);
 705
 706 /*_    . Decurriers */
 707 static pko dcrry_2A01VLL (klink * sc, pko args, pko value);
 708 static pko dcrry_3A01dotVLL (klink * sc, pko args, pko value);
 709 static pko dcrry_2CA01VLLA02 (klink * sc, pko args, pko value);
 710 /* May not be needed */
 711 static pko dcrry_3A01A02VLL  (klink * sc, pko args, pko value);
 712 static pko dcrry_2ALLVLL     (klink * sc, pko args, pko value);
 713 static pko dcrry_2ALLV01     (klink * sc, pko args, pko value);
 714
 715 static pko dcrry_NdotALL (klink * sc, pko args, pko value);
 716 #define dcrry_1A01    dcrry_NdotALL
 717 #define dcrry_1dotALL dcrry_NdotALL
 718 #define dcrry_2dotALL dcrry_NdotALL
 719 #define dcrry_3dotALL dcrry_NdotALL
 720 #define dcrry_4dotALL dcrry_NdotALL
 721
 722 static pko dcrry_1ALL (klink * sc, pko args, pko value);
 723
 724 static pko dcrry_5ALLdotVLL (klink * sc, pko args, pko value);
 725 #define dcrry_3ALLdotVLL dcrry_5ALLdotVLL
 726
 727 static pko dcrry_NVLLdotALL (klink * sc, pko args, pko value);
 728 #define dcrry_2VLLdotALL dcrry_NVLLdotALL
 729 #define dcrry_3VLLdotALL dcrry_NVLLdotALL
 730 #define dcrry_4VLLdotALL dcrry_NVLLdotALL
 731 #define dcrry_5VLLdotALL dcrry_NVLLdotALL
 732
 733 static pko dcrry_1VLL (klink * sc, pko args, pko value);
 734 static pko dcrry_NCVLLA01dotAX1 (klink * sc, pko args, pko value);
 735 #define dcrry_2CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
 736 #define dcrry_3CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
 737 #define dcrry_4CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
 738 #define dcrry_5CVLLA01dotAX1 dcrry_NCVLLA01dotAX1
 739 /*_    . Associated */
 740 FORWARD_DECL_CFUNC(static,ps0a4,values_pair);
 741
 742
 743 /*_   , Of Kernel evaluation */
 744 /*_    .  Public functions */
 745 FORWARD_DECL_APPLICATIVE(extern,ps0a2,kernel_eval);
 746 FORWARD_DECL_CFUNC (extern,ps0a3, vau_1);
 747 /*_    . Other signatures */
 748 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_eval_aux);
 749 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_mapeval);
 750 FORWARD_DECL_APPLICATIVE(static,ps0a3, kernel_mapand_aux);
 751 FORWARD_DECL_APPLICATIVE(extern,ps0a2, kernel_mapand);
 752 FORWARD_DECL_APPLICATIVE(static,ps0a5,eval_vau);
 753
 754 /*_   , Reading */
 755
 756 FORWARD_DECL_APPLICATIVE(static,ps0a0,kernel_read_internal);
 757 FORWARD_DECL_CFUNC(extern,ps0a0,kernel_read_sexp);
 758 FORWARD_DECL_CFUNC(static,ps0a2,kernel_read_list);
 759 FORWARD_DECL_CFUNC(static,ps0a2,kernel_treat_dotted_list);
 760 FORWARD_DECL_CFUNC(static,ps0a1,kernel_treat_qquoted_vec);
 761
 762 static INLINE int is_one_of (char *s, int c);
 763 static long binary_decode (const char *s);
 764 static char *readstr_upto (klink * sc, char *delim);
 765 static pko readstrexp (klink * sc);
 766 static INLINE int skipspace (klink * sc);
 767 static int token (klink * sc);
 768 static pko mk_atom (klink * sc, char *q);
 769 static pko mk_sharp_const (char *name);
 770
 771 /*_   , Printing */
 772 /* $$IMPROVE ME These should mostly be just operatives. */
 773 FORWARD_DECL_APPLICATIVE(static,ps0a2,kernel_print_sexp);
 774 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_print_sexp_aux);
 775 FORWARD_DECL_APPLICATIVE(static,ps0a3,kernel_print_list);
 776 FORWARD_DECL_APPLICATIVE(static,ps0a4,kernel_print_vec_from);
 777 static kt_boxed_curried k_print_terminate_list;
 778
 779 static void printslashstring (klink * sc, char *s, int len);
 780 static void atom2str (klink * sc, pko l, char **pp, int *plen);
 781 static void printatom (klink * sc, pko l);
 782
 783 /*_   , Stack & continuations */
 784 /*_    . Continuations */
 785 static pko mk_continuation (_kt_spagstack d);
 786 static void klink_push_cont (klink * sc, pko combiner);
 787 static _kt_spagstack
 788 klink_push_cont_aux (_kt_spagstack old_frame, pko ff, pko env);
 789 FORWARD_DECL_APPLICATIVE(extern,p00a1,continuation_to_applicative);
 790 FORWARD_DECL_CFUNC(static,vs0a2,invoke_continuation);
 791 FORWARD_DECL_CFUNC(static,ps0a2,continue_abnormally);
 792 static _kt_spagstack special_dynxtnt
 793 (_kt_spagstack outer, _kt_spagstack prox_dest, pko envir);
 794 static _kt_spagstack
 795 cont_dump (pko p);
 796
 797 /*_    . Dynamic bindings */
 798 static void klink_push_dyn_binding (klink * sc, pko id, pko value);
 799 static pko klink_find_dyn_binding(klink * sc, pko id);
 800 /*_    . Profiling */
 801 struct stack_profiling;
 802 static void
 803 k_profiling_done_frame(klink * sc, struct stack_profiling * profile);
 804 /*_    . Stack args */
 805 static pko
 806 get_nth_arg( _kt_spagstack frame, int n );
 807 static void
 808 push_arg (klink * sc, pko value);
 809
 810 /*_   , Environment and defining */
 811 FORWARD_DECL_CFUNC(static,vs0a3,kernel_define_tree);
 812 FORWARD_DECL_CFUNC(extern,p00a3,kernel_define);
 813 FORWARD_DECL_CFUNC(extern,ps0a2,eval_define);
 814 FORWARD_DECL_CFUNC(extern,ps0a3,set);
 815 FORWARD_DECL_CFUNC(static,ps0a4,set_aux);
 816
 817 static pko find_slot_in_env (pko env, pko sym, int all);
 818 static INLINE pko slot_value_in_env (pko slot);
 819 static INLINE void set_slot_in_env (pko slot, pko value);
 820 static pko
 821 reverse_find_slot_in_env_aux (pko env, pko value);
 822 /*_    . Standard environment */
 823 FORWARD_DECL_CFUNC(extern,p00a0, mk_std_environment);
 824 FORWARD_DECL_APPLICATIVE (extern,ps0a0, get_current_environment);
 825 /*_   , Misc kernel functions */
 826
 827 FORWARD_DECL_CFUNC(extern,ps0a1,arg1);
 828 FORWARD_DECL_APPLICATIVE(extern,ps0a1,val2val)
 829
 830 /*_   , Error functions */
 831 FORWARD_DECL_CFUNC(static,ps0a1,kernel_err);
 832 FORWARD_DECL_CFUNC(static,ps0a1,kernel_err_x);
 833
 834 /*_   , For DL if present */
 835 #if USE_DL
 836 FORWARD_DECL_APPLICATIVE(extern,ps0a1,klink_load_ext);
 837 #endif
 838
 839 /*_   , Symbols */
 840 static pko mk_symbol_obj (const char *name);
 841
 842 /*_   , Strings */
 843 static char *store_string (int len, const char *str, char fill);
 844
 845 /*_  . Object declarations */
 846 /*_   , Keys */
 847 /* These objects are declared here because some macros use them, but
 848    should not be directly used. */
 849 /* $$IMPROVE ME Somehow hide these better without hiding it from the
 850    applicative & destructure macros. */
 851 kt_boxed_void KEY(K_APPLICATIVE);
 852 kt_boxed_void KEY(K_NIL);
 853 /*_   , Typechecks */
 854 kt_boxed_vector _K_any_singleton;
 855 /*_   , Pointers to base environments */
 856 static pko print_lookup_env;
 857 static pko all_builtins_env;
 858 static pko ground_env;
 859 static pko typecheck_env_syms;
 860 /* Caches */
 861 static pko print_lookup_unwraps;
 862 static pko print_lookup_to_xary;
 863
 864 /*_ , Body */
 865 /*_  . Low-level treating T-types */
 866 /*_   , Type itself */
 867 /*_    . _get_type */
 868 INLINE int
 869 _get_type (pko p)
 870 {
 871   WITH_BOX_TYPE(ptype,p);
 872   return *ptype & T_MASKTYPE;
 873 }
 874
 875 /*_    . is_type */
 876 INLINE int
 877 is_type (pko p, int T_index)
 878 {
 879   return _get_type (p) == T_index;
 880 }
 881 /*_    . type_err_string */
 882 const char *
 883 type_err_string(_kt_tag t_enum)
 884 {
 885   switch(t_enum)
 886     {
 887     case T_STRING:
 888       return "Must be a string";
 889     case T_NUMBER:
 890       return "Must be a number";
 891     case T_SYMBOL:
 892       return "Must be a symbol";
 893     case T_PAIR:
 894       return "Must be a pair";
 895     case T_CHARACTER:
 896       return "Must be a character";
 897     case T_PORT:
 898       return "Must be a port";
 899     case T_ENCAP:
 900       return "Must be an encapsulation";
 901     case T_CONTINUATION:
 902       return "Must be a continuation";
 903     case T_ENV_FRAME:
 904       return "Must be an environment";
 905     case T_RECURRENCES:
 906       return "Must be a recurrence table";
 907     case T_RECUR_TRACKER:
 908       return "Must be a recurrence tracker";
 909     case T_DESTR_RESULT:
 910       return "Must be a destructure result";
 911     default:
 912       /* Left out types that shouldn't be distinguished in Kernel. */
 913       return "Error message for this type needs to be coded";
 914     }
 915 }
 916 /*_    . assert_type */
 917 /* If sc is given, it's a assertion making a Kernel error, otherwise
 918    it's a C assertion. */
 919 INLINE void
 920 assert_type (sc_or_null sc, pko p, _kt_tag t_enum)
 921 {
 922   if(sc && (_get_type(p) != (t_enum)))
 923     {
 924       const char * err_msg = type_err_string(t_enum);
 925       _klink_error_1(sc,err_msg,p);
 926       return;                   /* NOTREACHED */
 927     }
 928   else
 929     { assert (_get_type(p) == (t_enum)); }
 930 }
 931
 932 /*_   , Mutability */
 933
 934 INTERFACE INLINE int
 935 is_immutable (pko p)
 936 {
 937   WITH_BOX_TYPE(ptype,p);
 938   return *ptype & T_IMMUTABLE;
 939 }
 940
 941 INTERFACE INLINE void
 942 setimmutable (pko p)
 943 {
 944   WITH_BOX_TYPE(ptype,p);
 945   *ptype |= T_IMMUTABLE;
 946 }
 947
 948 /* If sc is given, it's a assertion making a Kernel error, otherwise
 949    it's a C assertion. */
 950 INLINE void
 951 assert_mutable (sc_or_null sc, pko p)
 952 {
 953   WITH_BOX_TYPE(ptype,p);
 954   if(sc && (*ptype & T_IMMUTABLE))
 955     {
 956       _klink_error_1(sc,"Attempt to mutate immutable object",p);
 957       return;
 958     }
 959   else
 960     { assert(!(*ptype & T_IMMUTABLE)); }
 961 }
 962
 963 #define DEBUG_assert_mutable assert_mutable
 964
 965 /*_   , No-call-Kernel */
 966 inline int
 967 no_call_k(pko p)
 968 {
 969   WITH_BOX_TYPE(ptype,p);
 970   return *ptype & T_NO_K;
 971 }
 972 /*_   , eq? */
 973 SIG_CHKARRAY(eqp) = { K_ANY, K_ANY, };
 974 DEF_SIMPLE_APPLICATIVE(p00a2,eqp,T_NO_K,ground,"eq?")
 975 {
 976   WITH_2_ARGS(a,b);
 977   return kernel_bool(a == b);
 978 }
 979 /*_  . Low-level object types */
 980 /*_   , vec2 (Low lists) */
 981 /*_    . Struct */
 982 typedef struct
 983 {
 984   pko _car;
 985   pko _cdr;
 986 } kt_vec2;
 987 typedef BOX_OF(kt_vec2) boxed_vec2;
 988
 989 /*_    . Type assert */
 990 /* $$IMPROVE ME  Disable this if DEBUG_LEVEL is low */
 991 void assert_T_is_v2(_kt_tag t_enum)
 992 {
 993   t_enum &= T_MASKTYPE;
 994   assert(
 995          t_enum == T_PAIR
 996          || t_enum == T_ENV_PAIR
 997          || t_enum == T_ENV_FRAME
 998          || t_enum == T_PROMISE
 999          || t_enum == T_DESTR_RESULT
1000          );
1001 }
1002
1003 /*_    . Create */
1004 pko
1005 v2cons (_kt_tag t_enum, pko a, pko b)
1006 {
1007   ALLOC_BOX_PRESUME (kt_vec2, t_enum);
1008   pbox->data._car = a;
1009   pbox->data._cdr = b;
1010   return PTR2PKO(pbox);
1011 }
1012
1013 /*_    . Unsafe operations (Typechecks can be disabled) */
1014 INLINE pko
1015 unsafe_v2car (pko p)
1016 {
1017   assert_T_is_v2(_get_type(p));
1018   WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1019   return pdata->_car;
1020 }
1021
1022 INLINE pko
1023 unsafe_v2cdr (pko p)
1024 {
1025   assert_T_is_v2(_get_type(p));
1026   WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1027   return pdata->_cdr;
1028 }
1029
1030 INLINE void
1031 unsafe_v2set_car (pko p, pko q)
1032 {
1033   assert_T_is_v2(_get_type(p));
1034   DEBUG_assert_mutable(0,p);
1035   WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1036   pdata->_car = q;
1037   return;
1038 }
1039
1040 INLINE void
1041 unsafe_v2set_cdr (pko p, pko q)
1042 {
1043   assert_T_is_v2(_get_type(p));
1044   DEBUG_assert_mutable(0,p);
1045   WITH_UNBOXED_UNSAFE(pdata,kt_vec2,p);
1046   pdata->_cdr = q;
1047   return;
1048 }
1049
1050 /*_    . Checked operations */
1051 pko
1052 v2car (sc_or_null err_reporter, _kt_tag t_enum, pko p)
1053 {
1054   assert_type(err_reporter,p,t_enum);
1055   return unsafe_v2car(p);
1056 }
1057
1058 pko
1059 v2cdr (sc_or_null err_reporter, _kt_tag t_enum, pko p)
1060 {
1061   assert_type(err_reporter,p,t_enum);
1062   return unsafe_v2cdr(p);
1063 }
1064
1065 void
1066 v2set_car (sc_or_null err_reporter, _kt_tag t_enum, pko p, pko q)
1067 {
1068   assert_type(err_reporter,p,t_enum);
1069   assert_mutable(err_reporter,p);
1070   unsafe_v2set_car(p,q);
1071   return;
1072 }
1073
1074 void
1075 v2set_cdr (sc_or_null err_reporter, _kt_tag t_enum, pko p, pko q)
1076 {
1077   assert_type(err_reporter,p,t_enum);
1078   assert_mutable(err_reporter,p);
1079   unsafe_v2set_cdr(p,q);
1080   return;
1081 }
1082
1083 /*_    . "Psychic" macros */
1084 #define WITH_V2(T_ENUM)                         \
1085   _kt_tag _t_enum = T_ENUM;             \
1086   assert_T_is_v2(_t_enum)
1087
1088 /*  These expect WITH_REPORTER and WITH_V2 to be used in scope. */
1089 #define PSYC_v2cons(A,B) v2cons (_t_enum, (A), (B))
1090 #define PSYC_v2car(X) v2car (_err_reporter, _t_enum, (X))
1091 #define PSYC_v2cdr(X) v2cdr (_err_reporter, _t_enum, (X))
1092 #define PSYC_v2set_car(A,B) v2set_car (_err_reporter, _t_enum, (A), (B))
1093 #define PSYC_v2set_cdr(A,B) v2set_cdr (_err_reporter, _t_enum, (A), (B))
1094
1095 /*_    . Container macros */
1096
1097 /* This expects _EXPLORE_FUNC to be defined as a macro taking OBJ,
1098    inspecting it but not mutating it. */
1099 #define EXPLORE_v2(OBJ)                         \
1100   {                                             \
1101     WITH_UNBOXED_UNSAFE(pdata,kt_vec2,OBJ);     \
1102     _EXPLORE_FUNC(pdata->_car);                 \
1103     _EXPLORE_FUNC(pdata->_cdr);                 \
1104   }
1105
1106 /* #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data) */
1107
1108 /*_    . Low list operations */
1109 /*_     , v2list_star */
1110 pko v2list_star(sc_or_null sc, pko d, _kt_tag t_enum)
1111 {
1112   WITH_REPORTER(sc);
1113   WITH_V2(t_enum);
1114   pko p, q;
1115   pko cdr_d = PSYC_v2cdr (d);
1116   if (cdr_d == K_NIL)
1117     {
1118       return PSYC_v2car (d);
1119     }
1120   p = PSYC_v2cons (PSYC_v2car (d), cdr_d);
1121   q = p;
1122
1123   while (PSYC_v2cdr (PSYC_v2cdr (p)) != K_NIL)
1124     {
1125       pko cdr_p = PSYC_v2cdr (p);
1126       d = PSYC_v2cons (PSYC_v2car (p), cdr_p);
1127       if (PSYC_v2cdr (cdr_p) != K_NIL)
1128         {
1129           p = PSYC_v2cdr (d);
1130         }
1131     }
1132   PSYC_v2set_cdr (p, PSYC_v2car (PSYC_v2cdr (p)));
1133   return q;
1134 }
1135
1136 /*_     , reverse list -- produce new list */
1137 pko v2reverse(pko a, _kt_tag t_enum)
1138 {
1139   WITH_V2(t_enum);
1140   pko p = K_NIL;
1141   for (; is_type (a, t_enum); a = unsafe_v2cdr (a))
1142     {
1143       p = v2cons (t_enum, unsafe_v2car (a), p);
1144     }
1145   return (p);
1146 }
1147
1148 /*_     , reverse list -- in-place (Not typechecked) */
1149 /* last_cdr will be the tail of the resulting list.  It is usually
1150    K_NIL.
1151
1152    list is the list to be reversed.  Caller guarantees that list is a
1153    proper list, each link being either some type of vec2 or K_NIL.
1154 */
1155 static pko
1156 unsafe_v2reverse_in_place (pko last_cdr, pko list)
1157 {
1158   pko p = list, result = last_cdr;
1159   while (p != K_NIL)
1160     {
1161       pko scratch = unsafe_v2cdr (p);
1162       unsafe_v2set_cdr (p, result);
1163       result = p;
1164       p = scratch;
1165     }
1166   return (result);
1167 }
1168 /*_     , append list -- produce new list */
1169 pko v2append(sc_or_null err_reporter, pko a, pko b, _kt_tag t_enum)
1170 {
1171   WITH_V2(t_enum);
1172   if (a == K_NIL)
1173     { return b; }
1174   else
1175     {
1176       a = v2reverse (a, t_enum);
1177       /* Correct even if b is nil or a non-list. */
1178       return unsafe_v2reverse_in_place(b, a);
1179     }
1180 }
1181
1182
1183 /*_   , basvectors (Low vectors) */
1184 /*_    . Struct */
1185 /* Above so it can be visible to early typecheck declarations. */
1186 /*_    . Type assert */
1187 void assert_T_is_basvector(_kt_tag t_enum)
1188 {
1189   t_enum &= T_MASKTYPE;
1190   assert(
1191          t_enum == T_VECTOR ||
1192          t_enum == T_TYPECHECK ||
1193          t_enum == T_DESTRUCTURE
1194          );
1195 }
1196
1197 /*_    . Create */
1198 /*_     , alloc_basvector */
1199 static pko
1200 alloc_basvector (int len, _kt_tag t_enum)
1201 {
1202   assert_T_is_basvector(t_enum);
1203   ALLOC_BOX_PRESUME(kt_vector, t_enum);
1204   pbox->data.len = len;
1205   pbox->data.els = (pko *)GC_MALLOC ((sizeof (pko) * len));
1206   /* We don't fill this vector, we expect it to be filled later. */
1207   return PTR2PKO(pbox);
1208 }
1209 /*_     , mk_basvector_w_args */
1210 static pko
1211 mk_basvector_w_args(klink * sc, pko args, _kt_tag t_enum)
1212 {
1213   WITH_REPORTER(sc);
1214   assert_T_is_basvector(t_enum);
1215   int4 metrics;
1216   get_list_metrics_aux(args, metrics);
1217   if (metrics[lm_num_nils] != 1)
1218     {
1219       KERNEL_ERROR_1 (sc, "mk_basvector_w_args: not a proper list:", args);
1220     }
1221   int len = metrics[lm_acyc_len];
1222   pko vec = alloc_basvector(len, t_enum);
1223   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1224   int i;
1225   pko x;
1226   for (x = args, i = 0; is_pair (x); x = cdr (x), i++)
1227     {
1228       pdata->els[i] = car (x);
1229     }
1230   return vec;
1231 }
1232 /*_     , mk_filled_basvector */
1233 pko
1234 mk_filled_basvector(int len, pko fill, _kt_tag t_enum)
1235 {
1236   assert_T_is_basvector(t_enum);
1237   pko vec = alloc_basvector(len, t_enum);
1238   unsafe_basvector_fill (vec, fill);
1239   return vec;
1240 }
1241 /*_     , mk_basvector_from_array */
1242 pko
1243 mk_basvector_from_array(int len, pko * array, _kt_tag t_enum)
1244 {
1245   assert_T_is_basvector(t_enum);
1246   pko vec = alloc_basvector(len, t_enum);
1247   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1248   int i;
1249   for (i = 0; i < len; i++)
1250     {
1251       pdata->els [i] = array [i];
1252     }
1253   return vec;
1254 }
1255 /*_     , mk_foresliced_basvector */
1256 pko
1257 mk_foresliced_basvector (pko vec, int excess, _kt_tag t_enum)
1258 {
1259   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1260   const int len = pdata->len;
1261   assert (len >= excess);
1262   const int remnant_len = len - excess;
1263   return mk_basvector_from_array (remnant_len,
1264                                   pdata->els + excess,
1265                                   t_enum);
1266 }
1267 /*_    . Unsafe operations (Typechecks can be disabled) */
1268 /*_     , unsafe_basvector_fill */
1269 static void
1270 unsafe_basvector_fill (pko vec, pko obj)
1271 {
1272   assert_T_is_basvector(_get_type(vec));
1273   assert_mutable(0,vec);
1274   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1275   {
1276     int i;
1277     const int num = pdata->len;
1278
1279     for (i = 0; i < num; i++)
1280       { pdata->els[i] = obj; }
1281   }
1282 }
1283 /*_     , basvector_len */
1284 static int
1285 basvector_len (pko vec)
1286 {
1287   assert_T_is_basvector(_get_type(vec));
1288   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1289   return pdata->len;
1290 }
1291
1292 /*_     , basvector_elem */
1293 static pko
1294 basvector_elem (pko vec, int ielem)
1295 {
1296   assert_T_is_basvector(_get_type(vec));
1297   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1298   assert(ielem >= 0);
1299   assert(ielem <  pdata->len);
1300   return pdata->els[ielem];
1301 }
1302
1303 /*_     , basvector_set_elem */
1304 static void
1305 basvector_set_elem (pko vec, int ielem, pko a)
1306 {
1307   assert_T_is_basvector(_get_type(vec));
1308   assert_mutable(0,vec);
1309   WITH_UNBOXED_UNSAFE(pdata,kt_vector,vec);
1310   assert(ielem >= 0);
1311   assert(ielem <  pdata->len);
1312   pdata->els[ielem] = a;
1313   return;
1314 }
1315 /*_     , basvector_fill_array */
1316 static void
1317 basvector_fill_array(pko vec, int max_len, pko * array)
1318 {
1319   assert_T_is_basvector(_get_type(vec));
1320   WITH_UNBOXED_UNSAFE (p_vec, kt_vector, vec);
1321   int count = p_vec->len;
1322   assert (count <= max_len);
1323   int i;
1324   for (i = 0; i < count; i++)
1325     {
1326       array [i] = p_vec->els [i];
1327     }
1328   return;
1329 }
1330 /*_    . Checked operations */
1331 /*_   , Basic strings (Low strings) */
1332 /*_    . Struct kt_string */
1333
1334 typedef struct
1335 {
1336   char *_svalue;
1337   int _length;
1338 } kt_string;
1339
1340 /*_    . Get parts */
1341 INLINE char *
1342 bastring_value (sc_or_null sc, _kt_tag t_enum, pko p)
1343 {
1344   WITH_PSYC_UNBOXED(kt_string,p, t_enum, sc);
1345   return pdata->_svalue;
1346 }
1347
1348 INLINE int
1349 bastring_len (sc_or_null sc, _kt_tag t_enum, pko p)
1350 {
1351   WITH_PSYC_UNBOXED(kt_string,p, t_enum, sc);
1352   return pdata->_length;
1353 }
1354
1355 /*_    . Create */
1356
1357 static char *
1358 store_string (int len_str, const char *str, char fill)
1359 {
1360   char *q;
1361
1362   q = (char *) GC_MALLOC_ATOMIC (len_str + 1);
1363   if (str != 0)
1364     {
1365       snprintf (q, len_str + 1, "%s", str);
1366     }
1367   else
1368     {
1369       memset (q, fill, len_str);
1370       q[len_str] = 0;
1371     }
1372   return (q);
1373 }
1374
1375 INLINE pko
1376 mk_bastring (_kt_tag t_enum, const char *str, int len, char fill)
1377 {
1378   ALLOC_BOX_PRESUME (kt_string, t_enum);
1379   pbox->data._svalue = store_string(len, str, fill);
1380   pbox->data._length = len;
1381   return PTR2PKO(pbox);
1382 }
1383
1384 /*_    . Type assert */
1385 void assert_T_is_bastring(_kt_tag t_enum)
1386 {
1387   t_enum &= T_MASKTYPE;
1388   assert(
1389          t_enum == T_STRING ||
1390          t_enum == T_SYMBOL);
1391 }
1392
1393 /*_  . Individual object types */
1394 /*_   , Booleans */
1395
1396 BOX_OF_VOID (K_T);
1397 BOX_OF_VOID (K_F);
1398
1399 DEF_SIMPLE_PRED(is_bool,T_NO_K,ground, "boolean?/o1")
1400 {
1401   WITH_1_ARGS(p);
1402   return (p == K_T) || (p == K_F);
1403 }
1404 /*_    . Operations */
1405 SIG_CHKARRAY(not) = { REF_OPER(is_bool), };
1406 DEF_SIMPLE_APPLICATIVE(p00a1,not,T_NO_K,ground, "not?")
1407 {
1408   WITH_1_ARGS(p);
1409   if(p == K_T) { return K_F; }
1410   if(p == K_F) { return K_T; }
1411   errx(6, "not: Argument must be boolean");
1412 }
1413
1414 /*_   , Numbers */
1415 /*_    . Number constants */
1416 #if 0
1417 /* We would use these for "folding" operations like cumulative addition. */
1418 static num num_zero = { 1, {0}, };
1419 static num num_one  = { 1, {1}, };
1420 #endif
1421 /*_    . Macros */
1422 #define num_ivalue(n)       (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)
1423 #define num_rvalue(n)       (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)
1424
1425 /*_    . Making them */
1426
1427 INTERFACE pko
1428 mk_integer (long num)
1429 {
1430   ALLOC_BOX_PRESUME (struct num, T_NUMBER);
1431   pbox->data.value.ivalue = num;
1432   pbox->data.is_fixnum = 1;
1433   return PTR2PKO(pbox);
1434 }
1435
1436 INTERFACE pko
1437 mk_real (double n)
1438 {
1439   ALLOC_BOX_PRESUME (num, T_NUMBER);
1440   pbox->data.value.rvalue = n;
1441   pbox->data.is_fixnum = 0;
1442   return PTR2PKO(pbox);
1443 }
1444
1445 static pko
1446 mk_number (num n)
1447 {
1448   if (n.is_fixnum)
1449     {
1450       return mk_integer (n.value.ivalue);
1451     }
1452   else
1453     {
1454       return mk_real (n.value.rvalue);
1455     }
1456 }
1457
1458 /*_    . Checking them */
1459 static int is_zero_double (double x);
1460
1461 static INLINE int
1462 num_is_integer (pko p)
1463 {
1464   WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1465   return (pdata->is_fixnum);
1466 }
1467
1468 DEF_T_PRED (is_number,T_NUMBER,ground,"number?/o1");
1469
1470 DEF_SIMPLE_PRED (is_posint,T_NO_K,ground,"posint?/o1")
1471 {
1472   WITH_1_ARGS(p);
1473   return is_integer (p) && ivalue (p) >= 0;
1474 }
1475
1476 /* $$IMPROVE ME later Integer and real should be separate T_ types. */
1477 DEF_SIMPLE_PRED (is_integer,T_NO_K,ground, "integer?/o1")
1478 {
1479   WITH_1_ARGS(p);
1480   if(!is_number (p)) { return 0; }
1481   WITH_UNBOXED_UNSAFE(pdata,num,p);
1482   return (pdata->is_fixnum);
1483 }
1484
1485 DEF_SIMPLE_PRED (is_real,T_NO_K,ground, "real?/o1")
1486 {
1487   WITH_1_ARGS(p);
1488   if(!is_number (p)) { return 0; }
1489   WITH_UNBOXED_UNSAFE(pdata,num,p);
1490   return (!pdata->is_fixnum);
1491 }
1492 DEF_SIMPLE_PRED (is_zero,T_NO_K,ground, "zero?/o1")
1493 {
1494   WITH_1_ARGS(p);
1495   /* Behavior on non-numbers wasn't specified so I'm assuming the
1496      predicate just fails. */
1497   if(!is_number (p)) { return 0; }
1498   WITH_UNBOXED_UNSAFE(pdata,num,p);
1499   if(pdata->is_fixnum)
1500     {
1501       return (ivalue (p) == 0);
1502     }
1503   else
1504     {
1505       return is_zero_double(rvalue(p));
1506     }
1507 }
1508 /* $$WRITE ME positive? negative? odd? even? */
1509 /*_    . Getting their values */
1510 INLINE num
1511 nvalue (pko p)
1512 {
1513   WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1514   return ((*pdata));
1515 }
1516
1517 INTERFACE long
1518 ivalue (pko p)
1519 {
1520   WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1521   return (num_is_integer (p) ? pdata->value.ivalue : (long) pdata->
1522           value.rvalue);
1523 }
1524
1525 INTERFACE double
1526 rvalue (pko p)
1527 {
1528   WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1529   return (!num_is_integer (p)
1530           ? pdata->value.rvalue : (double) pdata->value.ivalue);
1531 }
1532
1533 INTERFACE void
1534 set_ivalue (pko p, long i)
1535 {
1536   assert_mutable(0,p);
1537   WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1538   assert (num_is_integer (p));
1539   pdata->value.ivalue = i;
1540   return;
1541 }
1542
1543 INTERFACE void
1544 add_to_ivalue (pko p, long i)
1545 {
1546   assert_mutable(0,p);
1547   WITH_PSYC_UNBOXED(num,p,T_NUMBER,0);
1548   assert (num_is_integer (p));
1549   pdata->value.ivalue += i;
1550   return;
1551 }
1552
1553 /*_    . Operating on numbers */
1554 static num
1555 num_add (num a, num b)
1556 {
1557   num ret;
1558   ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1559   if (ret.is_fixnum)
1560     {
1561       ret.value.ivalue = a.value.ivalue + b.value.ivalue;
1562     }
1563   else
1564     {
1565       ret.value.rvalue = num_rvalue (a) + num_rvalue (b);
1566     }
1567   return ret;
1568 }
1569
1570 static num
1571 num_mul (num a, num b)
1572 {
1573   num ret;
1574   ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1575   if (ret.is_fixnum)
1576     {
1577       ret.value.ivalue = a.value.ivalue * b.value.ivalue;
1578     }
1579   else
1580     {
1581       ret.value.rvalue = num_rvalue (a) * num_rvalue (b);
1582     }
1583   return ret;
1584 }
1585
1586 static num
1587 num_div (num a, num b)
1588 {
1589   num ret;
1590   ret.is_fixnum = a.is_fixnum && b.is_fixnum
1591     && a.value.ivalue % b.value.ivalue == 0;
1592   if (ret.is_fixnum)
1593     {
1594       ret.value.ivalue = a.value.ivalue / b.value.ivalue;
1595     }
1596   else
1597     {
1598       ret.value.rvalue = num_rvalue (a) / num_rvalue (b);
1599     }
1600   return ret;
1601 }
1602
1603 static num
1604 num_intdiv (num a, num b)
1605 {
1606   num ret;
1607   ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1608   if (ret.is_fixnum)
1609     {
1610       ret.value.ivalue = a.value.ivalue / b.value.ivalue;
1611     }
1612   else
1613     {
1614       ret.value.rvalue = num_rvalue (a) / num_rvalue (b);
1615     }
1616   return ret;
1617 }
1618
1619 static num
1620 num_sub (num a, num b)
1621 {
1622   num ret;
1623   ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1624   if (ret.is_fixnum)
1625     {
1626       ret.value.ivalue = a.value.ivalue - b.value.ivalue;
1627     }
1628   else
1629     {
1630       ret.value.rvalue = num_rvalue (a) - num_rvalue (b);
1631     }
1632   return ret;
1633 }
1634
1635 static num
1636 num_rem (num a, num b)
1637 {
1638   num ret;
1639   long e1, e2, res;
1640   ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1641   e1 = num_ivalue (a);
1642   e2 = num_ivalue (b);
1643   res = e1 % e2;
1644   /* modulo should have same sign as second operand */
1645   if (res > 0)
1646     {
1647       if (e1 < 0)
1648         {
1649           res -= labs (e2);
1650         }
1651     }
1652   else if (res < 0)
1653     {
1654       if (e1 > 0)
1655         {
1656           res += labs (e2);
1657         }
1658     }
1659   ret.value.ivalue = res;
1660   return ret;
1661 }
1662
1663 static num
1664 num_mod (num a, num b)
1665 {
1666   num ret;
1667   long e1, e2, res;
1668   ret.is_fixnum = a.is_fixnum && b.is_fixnum;
1669   e1 = num_ivalue (a);
1670   e2 = num_ivalue (b);
1671   res = e1 % e2;
1672   if (res * e2 < 0)
1673     {                           /* modulo should have same sign as second operand */
1674       e2 = labs (e2);
1675       if (res > 0)
1676         {
1677           res -= e2;
1678         }
1679       else
1680         {
1681           res += e2;
1682         }
1683     }
1684   ret.value.ivalue = res;
1685   return ret;
1686 }
1687
1688 static int
1689 num_eq (num a, num b)
1690 {
1691   int ret;
1692   int is_fixnum = a.is_fixnum && b.is_fixnum;
1693   if (is_fixnum)
1694     {
1695       ret = a.value.ivalue == b.value.ivalue;
1696     }
1697   else
1698     {
1699       ret = num_rvalue (a) == num_rvalue (b);
1700     }
1701   return ret;
1702 }
1703
1704
1705 static int
1706 num_gt (num a, num b)
1707 {
1708   int ret;
1709   int is_fixnum = a.is_fixnum && b.is_fixnum;
1710   if (is_fixnum)
1711     {
1712       ret = a.value.ivalue > b.value.ivalue;
1713     }
1714   else
1715     {
1716       ret = num_rvalue (a) > num_rvalue (b);
1717     }
1718   return ret;
1719 }
1720
1721 static int
1722 num_ge (num a, num b)
1723 {
1724   return !num_lt (a, b);
1725 }
1726
1727 static int
1728 num_lt (num a, num b)
1729 {
1730   int ret;
1731   int is_fixnum = a.is_fixnum && b.is_fixnum;
1732   if (is_fixnum)
1733     {
1734       ret = a.value.ivalue < b.value.ivalue;
1735     }
1736   else
1737     {
1738       ret = num_rvalue (a) < num_rvalue (b);
1739     }
1740   return ret;
1741 }
1742
1743 static int
1744 num_le (num a, num b)
1745 {
1746   return !num_gt (a, b);
1747 }
1748
1749 #if USE_MATH
1750 /* Round to nearest. Round to even if midway */
1751 static double
1752 round_per_R5RS (double x)
1753 {
1754   double fl = floor (x);
1755   double ce = ceil (x);
1756   double dfl = x - fl;
1757   double dce = ce - x;
1758   if (dfl > dce)
1759     {
1760       return ce;
1761     }
1762   else if (dfl < dce)
1763     {
1764       return fl;
1765     }
1766   else
1767     {
1768       if (fmod (fl, 2.0) == 0.0)
1769         {                       /* I imagine this holds */
1770           return fl;
1771         }
1772       else
1773         {
1774           return ce;
1775         }
1776     }
1777 }
1778 #endif
1779
1780 static int
1781 is_zero_double (double x)
1782 {
1783   return x < DBL_MIN && x > -DBL_MIN;
1784 }
1785
1786 static long
1787 binary_decode (const char *s)
1788 {
1789   long x = 0;
1790
1791   while (*s != 0 && (*s == '1' || *s == '0'))
1792     {
1793       x <<= 1;
1794       x += *s - '0';
1795       s++;
1796     }
1797
1798   return x;
1799 }
1800 /*_     , Macros */
1801 /* "Psychically" defines a and b.  */
1802 #define WITH_PSYC_AB_ARGS(A_TYPE,B_TYPE)          \
1803   WITH_UNBOXED_UNSAFE(a,A_TYPE,arg1); \
1804   WITH_UNBOXED_UNSAFE(b,B_TYPE,arg2)
1805
1806
1807 /*_     , Interface */
1808 /*_      . Binary operations */
1809 SIG_CHKARRAY(num_binop) = { REF_OPER(is_number), REF_OPER(is_number), };
1810 DEF_SIMPLE_DESTR(num_binop);
1811
1812 DEF_APPLICATIVE_W_DESTR(ps0a2,k_add,REF_DESTR(num_binop),0,ground, "add")
1813 {
1814   WITH_PSYC_AB_ARGS(num,num);
1815   ALLOC_BOX_PRESUME(num,T_NUMBER);
1816   *pdata = num_add (*a, *b);
1817   return PTR2PKO(pbox);
1818 }
1819
1820 DEF_APPLICATIVE_W_DESTR(ps0a2,k_sub,REF_DESTR(num_binop),0,ground, "sub")
1821 {
1822   WITH_PSYC_AB_ARGS(num,num);
1823   ALLOC_BOX_PRESUME(num,T_NUMBER);
1824   *pdata = num_sub (*a, *b);
1825   return PTR2PKO(pbox);
1826 }
1827
1828 DEF_APPLICATIVE_W_DESTR(ps0a2,k_mul,REF_DESTR(num_binop),0,ground, "mul")
1829 {
1830   WITH_PSYC_AB_ARGS(num,num);
1831   ALLOC_BOX_PRESUME(num,T_NUMBER);
1832   *pdata = num_mul (*a, *b);
1833   return PTR2PKO(pbox);
1834 }
1835
1836 DEF_APPLICATIVE_W_DESTR(ps0a2,k_div,REF_DESTR(num_binop),0,ground, "div")
1837 {
1838   WITH_PSYC_AB_ARGS(num,num);
1839   ALLOC_BOX_PRESUME(num,T_NUMBER);
1840   *pdata = num_div (*a, *b);
1841   return PTR2PKO(pbox);
1842 }
1843
1844 DEF_APPLICATIVE_W_DESTR(ps0a2,k_mod,REF_DESTR(num_binop),0,ground, "mod")
1845 {
1846   WITH_PSYC_AB_ARGS(num,num);
1847   ALLOC_BOX_PRESUME(num,T_NUMBER);
1848   *pdata = num_mod (*a, *b);
1849   return PTR2PKO(pbox);
1850 }
1851 /*_      . Binary predicates */
1852 DEF_APPLICATIVE_W_DESTR(bs0a2,k_gt,REF_DESTR(num_binop),0,ground, ">?/2")
1853 {
1854   WITH_PSYC_AB_ARGS(num,num);
1855   ALLOC_BOX_PRESUME(num,T_NUMBER);
1856   return num_gt (*a, *b);
1857 }
1858
1859 DEF_APPLICATIVE_W_DESTR(bs0a2,k_eq,REF_DESTR(num_binop),0,simple, "equal?/2-num-num")
1860 {
1861   WITH_PSYC_AB_ARGS(num,num);
1862   ALLOC_BOX_PRESUME(num,T_NUMBER);
1863   return num_eq (*a, *b);
1864 }
1865
1866
1867 /*_   , Characters */
1868 DEF_T_PRED (is_character,T_CHARACTER,ground, "character?/o1");
1869
1870 INTERFACE long
1871 charvalue (pko p)
1872 {
1873   WITH_PSYC_UNBOXED(long,p,T_CHARACTER,0);
1874   return *pdata;
1875 }
1876
1877 INTERFACE pko
1878 mk_character (int c)
1879 {
1880   ALLOC_BOX_PRESUME (long, T_CHARACTER);
1881   pbox->data = c;
1882   return PTR2PKO(pbox);
1883 }
1884
1885 /*_    . Classifying characters */
1886 #if USE_CHAR_CLASSIFIERS
1887 static INLINE int
1888 Cisalpha (int c)
1889 {
1890   return isascii (c) && isalpha (c);
1891 }
1892
1893 static INLINE int
1894 Cisdigit (int c)
1895 {
1896   return isascii (c) && isdigit (c);
1897 }
1898
1899 static INLINE int
1900 Cisspace (int c)
1901 {
1902   return isascii (c) && isspace (c);
1903 }
1904
1905 static INLINE int
1906 Cisupper (int c)
1907 {
1908   return isascii (c) && isupper (c);
1909 }
1910
1911 static INLINE int
1912 Cislower (int c)
1913 {
1914   return isascii (c) && islower (c);
1915 }
1916 #endif
1917 /*_    . Character names */
1918 #if USE_ASCII_NAMES
1919 static const char *charnames[32] = {
1920   "nul",
1921   "soh",
1922   "stx",
1923   "etx",
1924   "eot",
1925   "enq",
1926   "ack",
1927   "bel",
1928   "bs",
1929   "ht",
1930   "lf",
1931   "vt",
1932   "ff",
1933   "cr",
1934   "so",
1935   "si",
1936   "dle",
1937   "dc1",
1938   "dc2",
1939   "dc3",
1940   "dc4",
1941   "nak",
1942   "syn",
1943   "etb",
1944   "can",
1945   "em",
1946   "sub",
1947   "esc",
1948   "fs",
1949   "gs",
1950   "rs",
1951   "us"
1952 };
1953
1954 static int
1955 is_ascii_name (const char *name, int *pc)
1956 {
1957   int i;
1958   for (i = 0; i < 32; i++)
1959     {
1960       if (stricmp (name, charnames[i]) == 0)
1961         {
1962           *pc = i;
1963           return 1;
1964         }
1965     }
1966   if (stricmp (name, "del") == 0)
1967     {
1968       *pc = 127;
1969       return 1;
1970     }
1971   return 0;
1972 }
1973
1974 #endif
1975
1976 /*_   , Void objects */
1977 /*_    . is_key */
1978 DEF_T_PRED (is_key, T_KEY,no,"");
1979
1980
1981 /*_    . Others */
1982 BOX_OF_VOID (K_NIL);
1983 BOX_OF_VOID (K_EOF);
1984 BOX_OF_VOID (K_INERT);
1985 BOX_OF_VOID (K_IGNORE);
1986 /*_    . "Secret" objects for built-in keyed dynamic bindings */
1987 BOX_OF_VOID (K_PRINT_FLAG);
1988 BOX_OF_VOID (K_TRACING);
1989 BOX_OF_VOID (K_INPORT);
1990 BOX_OF_VOID (K_OUTPORT);
1991 BOX_OF_VOID (K_NEST_DEPTH);
1992 /*_    . Keys for typecheck */
1993 BOX_OF_VOID (K_TYCH_DOT);
1994 BOX_OF_VOID (K_TYCH_REPEAT);
1995 BOX_OF_VOID (K_TYCH_OPTIONAL);
1996 BOX_OF_VOID (K_TYCH_IMP_REPEAT);
1997 BOX_OF_VOID (K_TYCH_NO_TYPE);
1998
1999 /*_    . Making them dynamically */
2000 DEF_CFUNC(p00a0, mk_void, K_NO_TYPE,T_NO_K)
2001 {
2002   ALLOC_BOX(pbox,T_KEY,kt_boxed_void);
2003   return PTR2PKO(pbox);
2004 }
2005 /*_    . Type */
2006 DEF_SIMPLE_PRED(is_null,T_NO_K,ground, "null?/o1")
2007 {
2008   WITH_1_ARGS(p);
2009   return p == K_NIL;
2010 }
2011 DEF_SIMPLE_PRED(is_inert,T_NO_K,ground, "inert?/o1")
2012 {
2013   WITH_1_ARGS(p);
2014   return p == K_INERT;
2015 }
2016 DEF_SIMPLE_PRED(is_ignore,T_NO_K,ground, "ignore?/o1")
2017 {
2018   WITH_1_ARGS(p);
2019   return p == K_IGNORE;
2020 }
2021
2022
2023 /*_   , Typecheck & destructure objects */
2024 /*_    . Structures */
2025 /* _car is vector component, _cdr is list component. */
2026 typedef kt_vec2 kt_destr_result;
2027 /* $$OBSOLETE UNUSED */
2028 typedef struct
2029 {
2030   pko remaining;                /* Remaining arglist.  0 if we're to
2031                                    use the value as entire object */
2032   pko typespec;                 /* Would prefer to can splice vector */
2033   int index;                    /* Index into vector, if typespec is a
2034                                    vector. */
2035 } kt_destr_state;
2036 /*_    . Enumeration */
2037 typedef enum
2038 {
2039   destr_success,
2040   destr_err,
2041   destr_must_call_k,
2042 } kt_destr_outcome;
2043 /*_    . Checks */
2044 DEF_T_PRED (is_destr_result, T_DESTR_RESULT, no, "");
2045 /*_    . Building them */
2046 /*_     , can_be_trivpred */
2047 /* Return true if the object can be used as a trivial predicate: An
2048    xary operative that does not call Kernel and returns a boolean as
2049    an int. */
2050 DEF_SIMPLE_PRED(can_be_trivpred,T_NO_K,unsafe,"trivpred?/o1")
2051 {
2052   WITH_1_ARGS(p);
2053   if(!no_call_k(p)) { return 0; }
2054   switch(_get_type(p))
2055     {
2056     case T_CFUNC:
2057       {
2058         WITH_UNBOXED_UNSAFE(pdata,kt_cfunc,p);
2059         switch(pdata->type)
2060           {
2061           case klink_ftype_b00a1:
2062             { return 1; }
2063           default:
2064             { return 0; }
2065           }
2066       }
2067       /* NOTREACHED */
2068
2069     case T_DESTRUCTURE:
2070       { return 1; }
2071       /* NOTREACHED */
2072
2073     case T_TYPECHECK:
2074       { return 1; }
2075       /* NOTREACHED */
2076     case T_TYPEP:
2077       { return 1; }
2078       /* NOTREACHED */
2079     default: return 0;
2080     }
2081 }
2082
2083 /*_     , k_to_trivpred */
2084 /* Convert a unary or nary function to xary.  If not possible, return
2085    nil. */
2086 /* $$OBSOLESCENT  Only used in print lookup, which will change */
2087 pko
2088 k_to_trivpred(pko p)
2089 {
2090   if(is_applicative(p))
2091     { p = unwrap_all(p); }
2092
2093   if(can_be_trivpred(p))
2094     { return p; }
2095   return K_NIL;
2096 }
2097
2098 /*_     , type-keys environment */
2099 RGSTR(type-keys, "cyclic-repeat",   REF_KEY(K_TYCH_IMP_REPEAT) )
2100 RGSTR(type-keys, "optional",        REF_KEY(K_TYCH_OPTIONAL)   )
2101 RGSTR(type-keys, "repeat",          REF_KEY(K_TYCH_REPEAT)     )
2102 RGSTR(type-keys, "dot",             REF_KEY(K_TYCH_DOT)        )
2103 /*_     , any_k */
2104 int any_k (kt_vector * p_vec_guts)
2105 {
2106   int i;
2107   for (i = 0; i < p_vec_guts->len; i++)
2108     {
2109       pko obj = p_vec_guts->els [i];
2110       WITH_BOX_TYPE(tag,obj);
2111       if (*tag | ~(T_NO_K)) { return 1; }
2112     }
2113   return 0;
2114 }
2115
2116 /*_     , Typecheck */
2117 DEF_APPLICATIVE_W_DESTR (ps0a1, mk_typecheck, REF_OPER(is_finite_list),T_NO_K,unsafe, "listtype/N-trivpred")
2118 {
2119   pko vec = mk_basvector_w_args(sc, arg1, T_TYPECHECK | T_IMMUTABLE);
2120   /* If everything is T_NO_K, then give flag T_NO_K. */
2121   WITH_UNBOXED_UNSAFE (pdata, kt_vector, vec);
2122   if (!any_k (pdata))
2123     {
2124       WITH_BOX_TYPE(tag,vec);
2125       *tag |= T_NO_K;
2126     }
2127   return vec;
2128 }
2129 /*_     , Destructurer */
2130 /* $$RETHINK ME Maybe add a count field to the struct. */
2131 DEF_APPLICATIVE_W_DESTR (ps0a1, mk_destructurer, REF_OPER(is_finite_list),T_NO_K,unsafe, "destructure-list/N-trivpred")
2132 {
2133   pko vec = mk_basvector_w_args(sc, arg1, T_DESTRUCTURE | T_IMMUTABLE);
2134   /* If everything is T_NO_K, then give flag T_NO_K. */
2135   WITH_UNBOXED_UNSAFE (pdata, kt_vector, vec);
2136   if (!any_k (pdata))
2137     {
2138       WITH_BOX_TYPE(tag,vec);
2139       *tag |= T_NO_K;
2140     }
2141   return vec;
2142 }
2143 /*_     , Destructurer Result state */
2144 /* Really a mixed vector/list */
2145 /*_      . mk_destr_result */
2146 pko
2147 mk_destr_result
2148 (int len, pko * array, pko more_vals)
2149 {
2150   pko vec = mk_basvector_from_array(len, array, T_VECTOR);
2151   return v2cons (T_DESTR_RESULT, vec, more_vals);
2152 }
2153 /*_      . mk_destr_result_add */
2154 pko
2155 mk_destr_result_add
2156 (pko old, int len, pko * array)
2157 {
2158   pko val_list = unsafe_v2cdr (old);
2159   int i;
2160   for (i = 0; i < len; i++)
2161     {
2162       val_list = cons ( array [i], val_list);
2163     }
2164   return v2cons (T_DESTR_RESULT,
2165                  unsafe_v2car (old),
2166                  val_list);
2167 }
2168 /*_      . destr_result_fill_array */
2169 void
2170 destr_result_fill_array (pko dr, int max_len, pko * array)
2171 {
2172   /* Assume errors are due to C code. */
2173   WITH_REPORTER (0);
2174   WITH_PSYC_UNBOXED (kt_destr_result, dr, T_DESTR_RESULT, 0)
2175   int vec_len =
2176     basvector_len (pdata->_car);
2177   basvector_fill_array(pdata->_car, vec_len, array);
2178   /* We get args earliest lowest, so insert them in reverse order. */
2179   int list_len = list_length (pdata->_cdr);
2180   int i = vec_len + list_len - 1;
2181   assert (i < max_len);
2182   pko args;
2183   for (args = pdata->_cdr; args != K_NIL; args = cdr (args), i--)
2184     {
2185       array [i] = car (args);
2186     }
2187 }
2188
2189 /*_     , destr_result_to_vec */
2190 SIG_CHKARRAY (destr_result_to_vec) =
2191 {
2192   REF_OPER (is_destr_result),
2193 };
2194
2195 DEF_SIMPLE_CFUNC (p00a1, destr_result_to_vec, T_NO_K)
2196 {
2197   WITH_1_ARGS (destr_result);
2198   WITH_UNBOXED_UNSAFE (p_destr_result, kt_destr_result, destr_result);
2199   int len =
2200     basvector_len (p_destr_result->_car) +
2201     list_length (p_destr_result->_cdr);
2202   pko vec = mk_vector (len, K_NIL);
2203   WITH_UNBOXED_UNSAFE (p_vec, kt_vector, vec);
2204   destr_result_fill_array (destr_result, len, p_vec->els);
2205   return vec;
2206 }
2207
2208 /*_    . Particular typechecks */
2209 /*_     , Any singleton */
2210 pko _K_ARRAY_any_singleton[] = { K_ANY, };
2211 DEF_DESTR(_K_any_singleton,_K_ARRAY_any_singleton);
2212 /*_     , Typespec itself */
2213 #define K_TY_TYPESPEC K_ANY
2214 /*_     , Destructure spec itself */
2215 #define K_TY_DESTRSPEC K_ANY
2216 /*_     , Top type (Always succeeds) */
2217 RGSTR(ground, "true/o1", REF_OPER(is_any))
2218 DEF_CFUNC(b00a1,is_any,K_ANY_SINGLETON,T_NO_K)
2219 { return 1; }
2220 /*_     , true? */
2221 /* Not entirely redundant; Used internally to check scheduled returns. */
2222 DEF_CFUNC(b00a1,is_true,K_ANY_SINGLETON,T_NO_K)
2223 {
2224   WITH_1_ARGS (p);
2225   return p == K_T;
2226 }
2227
2228 /*_    . Internal signatures */
2229 static int
2230 typecheck_repeat
2231 (klink *sc, pko argobject, pko * ar_typespec, int count, int style);
2232 static pko
2233 where_typemiss_repeat
2234 (klink *sc, pko argobject, pko * ar_typespec, int count, int style);
2235 pko
2236 static where_typemiss_do_spec
2237 (klink * sc, pko argobject, pko * ar_typespec, int left);
2238
2239 /*_    . Typecheck operations */
2240 inline int
2241 call_T_typecheck(pko T, pko obj)
2242 {
2243   WITH_PSYC_UNBOXED(typep_t,T,T_TYPEP,0);
2244   return is_type(obj,pdata->T_tag);
2245 }
2246 /*_     , typecheck */
2247 /* This is an optimization under-the-hood for running
2248    possibly-compound predicates.  Ultimately it will not be exposed.
2249    Later it may have a Kernel "safe counterpart" that is optimized to
2250    it when possible.
2251
2252    It should not call anything that calls Kernel.  All its
2253    "components" should be trivpreds (xary operatives that don't use
2254    eval loop), satisfying can_be_trivpred, generally specified
2255    natively in C.  */
2256 /* We don't have a typecheck typecheck predicate yet, so accept
2257    anything for arg2. */
2258 SIG_CHKARRAY(typecheck) = { K_ANY, K_ANY, };
2259 DEF_SIMPLE_APPLICATIVE (bs0a2, typecheck,T_NO_K,unsafe,"type?")
2260 {
2261   WITH_2_ARGS(argobject,typespec);
2262   assert(no_call_k(typespec));
2263   switch(_get_type(typespec))
2264     {
2265     case T_CFUNC:
2266       {
2267         WITH_UNBOXED_UNSAFE(pdata,kt_cfunc,typespec);
2268         switch(pdata->type)
2269           {
2270           case klink_ftype_b00a1:
2271             {
2272               return pdata->func.f_b00a1(argobject);
2273             }
2274           default:
2275             errx(7, "typecheck: Object is not a typespec");
2276           }
2277       }
2278       break; /* NOTREACHED */
2279     case T_TYPEP:
2280       return call_T_typecheck(typespec, argobject);
2281     case T_DESTRUCTURE:         /* Fallthru */
2282     case T_TYPECHECK:
2283       {
2284         WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2285         pko * ar_typespec = pdata->els;
2286         int left = pdata->len;
2287         int saw_optional = 0;
2288         for( ; left; ar_typespec++, left--)
2289           {
2290             pko tych = *ar_typespec;
2291             /**** Check for special keys ****/
2292             if(tych == REF_KEY(K_TYCH_DOT))
2293               {
2294                 if(left != 2)
2295                   {
2296                     KERNEL_ERROR_0 (sc, "typecheck: After dot there must "
2297                                     "be exactly one typespec");
2298                   }
2299                 else
2300                   { return typecheck(sc, argobject, ar_typespec[1]); }
2301               }
2302             if(tych == REF_KEY(K_TYCH_OPTIONAL))
2303               {
2304                 if(saw_optional)
2305                   {
2306                     KERNEL_ERROR_0 (sc, "typecheck: Can't have two optionals");
2307                   }
2308                 else
2309                   {
2310                     saw_optional = 1;
2311                     continue;
2312                   }
2313               }
2314             if(tych == REF_KEY(K_TYCH_REPEAT))
2315               {
2316                 return
2317                 typecheck_repeat(sc,argobject,
2318                                  ar_typespec + 1,
2319                                  left - 1,
2320                                  0);
2321               }
2322             if(tych == REF_KEY(K_TYCH_IMP_REPEAT))
2323               {
2324                 return
2325                 typecheck_repeat(sc,argobject,
2326                                  ar_typespec + 1,
2327                                  left - 1,
2328                                  1);
2329               }
2330
2331             /*** Manage stepping ***/
2332             if(!is_pair(argobject))
2333               {
2334                 if(!saw_optional)
2335                   { return 0; }
2336                 else
2337                   { return 1; }
2338               }
2339             else
2340               {
2341                 /* Advance */
2342                 pko c = pair_car(0,argobject);
2343                 argobject = pair_cdr(0,argobject);
2344
2345                 /*** Do the check ***/
2346                 if (!typecheck(sc, c, tych)) { return 0; }
2347               }
2348           }
2349         if(argobject != K_NIL)
2350           { return 0; }
2351         return 1;
2352       }
2353       break;
2354
2355     default:
2356       errx(7, "typecheck: Object is not a typespec");
2357     }
2358   return 0; /* NOTREACHED */
2359 }
2360 /*_     , typecheck_repeat */
2361 static int
2362 typecheck_repeat
2363 (klink *sc, pko argobject, pko * ar_typespec, int count, int style)
2364 {
2365   int4 metrics;
2366   get_list_metrics_aux(argobject, metrics);
2367   /* Dotted lists don't satisfy repeat */
2368   if(!metrics[lm_num_nils]) { return 0; }
2369   if(metrics[lm_cyc_len])
2370     {
2371       /* STYLE may not allow cycles. */
2372       if(!style)
2373         { return 0; }
2374       /* If there's a cycle and count doesn't fit into it exactly,
2375          call that a mismatch. */
2376       if(count % metrics[lm_cyc_len])
2377         { return 0; }
2378     }
2379   /* Check the car of each pair. */
2380   int step;
2381   int i;
2382   for(step = 0, i = 0;
2383       step < metrics[lm_num_pairs];
2384       ++step,   ++i,   argobject = pair_cdr(0,argobject))
2385     {
2386       if(i == count) { i = 0; }
2387       assert(is_pair(argobject));
2388       pko tych = ar_typespec[i];
2389       pko c = pair_car(0,argobject);
2390       if (!typecheck(sc, c, tych)) { return 0; }
2391     }
2392   return 1;
2393 }
2394 /*_     , where_typemiss */
2395 /* This parallels typecheck, but where typecheck returned a boolean,
2396    this returns an object indicating where the type failed to match. */
2397 SIG_CHKARRAY(where_typemiss) = { K_ANY, K_ANY, };
2398 DEF_SIMPLE_APPLICATIVE (ps0a2, where_typemiss,T_NO_K,unsafe, "where-typemiss")
2399 {
2400   /* Return a list indicating how TYPESPEC failed to match
2401      ARGOBJECT */
2402   WITH_2_ARGS(argobject,typespec);
2403   assert(no_call_k(typespec));
2404   switch(_get_type(typespec))
2405     {
2406     case T_CFUNC:
2407       {
2408         WITH_UNBOXED_UNSAFE(pdata,kt_cfunc,typespec);
2409         switch(pdata->type)
2410           {
2411           case klink_ftype_b00a1:
2412             {
2413               if (pdata->func.f_b00a1(argobject))
2414                 {
2415                   return 0;
2416                 }
2417               else
2418                 { return LIST1(typespec); }
2419             }
2420           default:
2421             errx(7, "where_typemiss: Object is not a typespec");
2422             return 0;
2423           }
2424       }
2425       break; /* NOTREACHED */
2426     case T_TYPEP:
2427       {
2428         WITH_PSYC_UNBOXED(typep_t,typespec,T_TYPEP,0);
2429         if (call_T_typecheck(typespec, argobject))
2430           { return 0; }
2431         else
2432           { return LIST1(mk_string(type_err_string(pdata->T_tag))); }
2433       }
2434
2435     case T_TYPECHECK:
2436     case T_DESTRUCTURE:
2437       {
2438         WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2439         return where_typemiss_do_spec(sc, argobject, pdata->els, pdata->len);
2440       }
2441
2442     default:
2443       errx(7,"where_typemiss: Object is not a typespec");
2444       return 0;
2445     }
2446   return 0; /* NOTREACHED */
2447 }
2448 /*_     , where_typemiss_do_spec */
2449 pko
2450 where_typemiss_do_spec
2451 (klink * sc, pko argobject, pko * ar_typespec, int left)
2452 {
2453   int saw_optional = 0;
2454   int el_num = 0;
2455   for( ; left; ar_typespec++, left--)
2456     {
2457       pko tych = *ar_typespec;
2458       /**** Check for special keys ****/
2459       if(tych == REF_KEY(K_TYCH_DOT))
2460         {
2461           if(left != 2)
2462             {
2463               KERNEL_ERROR_0 (sc, "where_typemiss: After dot there must "
2464                               "be exactly one typespec");
2465             }
2466           else
2467             {
2468               pko result =
2469                 where_typemiss(sc, argobject, ar_typespec[1]);
2470               if(result)
2471                 {
2472                   return
2473                     LISTSTAR3(mk_integer(el_num),
2474                               mk_symbol("dot"),
2475                               result);
2476                 }
2477               else
2478                 { return 0; }
2479             }
2480         }
2481       if(tych == REF_KEY(K_TYCH_OPTIONAL))
2482         {
2483           if(saw_optional)
2484             {
2485               KERNEL_ERROR_0 (sc, "where_typemiss: Can't have two optionals");
2486             }
2487           else
2488             {
2489               saw_optional = 1;
2490               continue;
2491             }
2492         }
2493       if(tych == REF_KEY(K_TYCH_REPEAT))
2494         {
2495           pko result =
2496             where_typemiss_repeat(sc,argobject,
2497                                   ar_typespec + 1,
2498                                   left - 1,
2499                                   0);
2500           if(result)
2501             { return LISTSTAR3(mk_integer(el_num),mk_symbol("repeat"), result); }
2502           else
2503             { return 0; }
2504         }
2505       if(tych == REF_KEY(K_TYCH_IMP_REPEAT))
2506         {
2507           pko result =
2508             where_typemiss_repeat(sc,argobject,
2509                                   ar_typespec + 1,
2510                                   left - 1,
2511                                   1);
2512           if(result)
2513             { return LISTSTAR3(mk_integer(el_num),mk_symbol("improper-repeat"),result); }
2514           else
2515             { return 0; }
2516         }
2517
2518       /*** Manage stepping ***/
2519       if(!is_pair(argobject))
2520         {
2521           if(!saw_optional)
2522             {
2523               return LIST2(mk_integer(el_num), mk_symbol("too-few"));
2524             }
2525           else
2526             { return 0; }
2527         }
2528       else
2529         {
2530           /* Advance */
2531           pko c = pair_car(0,argobject);
2532           argobject = pair_cdr(0,argobject);
2533           el_num++;
2534
2535           /*** Do the check ***/
2536           pko result = where_typemiss(sc, c, tych);
2537           if (result)
2538             { return LISTSTAR2(mk_integer(el_num),result); }
2539         }
2540     }
2541   if(argobject != K_NIL)
2542     { return LIST2(mk_integer(el_num), mk_symbol("too-many")); }
2543   return 0;
2544 }
2545
2546 /*_     , where_typemiss_repeat */
2547 static pko
2548 where_typemiss_repeat
2549 (klink *sc, pko argobject, pko * ar_typespec, int count, int style)
2550 {
2551   int4 metrics;
2552   get_list_metrics_aux(argobject, metrics);
2553   /* Dotted lists don't satisfy repeat */
2554   if(!metrics[lm_num_nils]) { return LIST1(mk_symbol("dotted")); }
2555   if(metrics[lm_cyc_len])
2556     {
2557       /* STYLE may not allow cycles. */
2558       if(!style)
2559         { return LIST1(mk_symbol("circular")); }
2560       /* If there's a cycle and count doesn't fit into it exactly,
2561          call that a mismatch. */
2562       if(count % metrics[lm_cyc_len])
2563         { return LIST1(mk_symbol("misaligned-end")); }
2564     }
2565   /* Check the car of each pair. */
2566   int step;
2567   int i;
2568   for(step = 0, i = 0;
2569       step < metrics[lm_num_pairs];
2570       ++step,   ++i,   argobject = pair_cdr(0,argobject))
2571     {
2572       if(i == count) { i = 0; }
2573       assert(is_pair(argobject));
2574       pko tych = ar_typespec[i];
2575       pko c = pair_car(0,argobject);
2576       pko result = where_typemiss(sc, c, tych);
2577       if (result)
2578         { return LISTSTAR2(mk_integer(step),result); }
2579     }
2580   return 0;
2581 }
2582
2583 /*_    . Destructuring operations */
2584 /*_     , destructure_by_bool */
2585 /* Just for calling back after a freeform predicate */
2586 SIG_CHKARRAY (destructure_by_bool) =
2587 {
2588   REF_OPER (is_destr_result),
2589   K_ANY,
2590   REF_OPER (is_bool),
2591 };
2592 DEF_SIMPLE_CFUNC (ps0a3, destructure_by_bool, 0)
2593 {
2594   WITH_3_ARGS (destr_result, argobject, satisfied);
2595   if (satisfied == K_T)
2596     {
2597       return
2598         mk_destr_result_add (destr_result, 1, &argobject);
2599     }
2600   else if (satisfied != K_F)
2601     {
2602       KERNEL_ERROR_0 (sc, "Predicate should return a boolean");
2603     }
2604   else
2605     {
2606       KERNEL_ERROR_0 (sc, "type mismatch on non-C predicate");
2607     }
2608 }
2609
2610 /*_     , destructure_how_many */
2611 int
2612 destructure_how_many (pko typespec)
2613 {
2614   switch (_get_type(typespec))
2615     {
2616     case T_DESTRUCTURE:
2617       {
2618         int count = 0;
2619         WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2620         pko * ar_typespec = pdata->els;
2621         int left = pdata->len;
2622         for( ; left; ar_typespec++, left--)
2623           {
2624             pko tych = *ar_typespec;
2625             count += destructure_how_many (tych);
2626           }
2627         return count;
2628       }
2629     case T_KEY:
2630       return 0;
2631     default:
2632       return 1;
2633     }
2634 }
2635 /*_     , destructure_make_ops */
2636 pko
2637 destructure_make_ops
2638 (pko argobject, pko typespec, int saw_optional)
2639 {
2640   return
2641     /* Operations to run, in reverse order. */
2642     LIST6(
2643           /* ^V= result-so-far */
2644           REF_OPER (destructure_resume),
2645           /* V= (result-so-far argobject spec optional?) */
2646           mk_load (LIST4 (mk_load_ix (1, 0),
2647                           mk_load_ix (0, 0),
2648                           typespec,
2649                           kernel_bool (saw_optional))),
2650           mk_store (K_ANY, 1),
2651           /* V= forced-argobject */
2652           REF_OPER (force),
2653           /* ^V= (argobject) */
2654           mk_load (LIST1 (argobject)),
2655           mk_store (K_ANY, 4)
2656           /* ^V= result-so-far */
2657           );
2658 }
2659 /*_     , destructure_make_ops_to_bool */
2660 pko
2661 destructure_make_ops_to_bool
2662 (pko argobject, pko op_on_argobject)
2663 {
2664   assert (is_combiner (op_on_argobject));
2665   return
2666     /* Operations to run, in reverse order. */
2667     LIST6(
2668           /* ^V= result-so-far */
2669           REF_OPER (destructure_by_bool),
2670           /* V= (result-so-far bool spec optional?) */
2671           mk_load (LIST3 (mk_load_ix (1, 0),
2672                           argobject,
2673                           mk_load_ix (0, 0))),
2674           mk_store (K_ANY, 1),
2675           /* V= bool */
2676           op_on_argobject,
2677           /* ^V= (argobject) */
2678           mk_load (LIST1 (argobject)),
2679           mk_store (K_ANY, 4)
2680           /* ^V= result-so-far */
2681           );
2682 }
2683 /*_     , destructure */
2684 /* Callers: past_end should point into the same array as *outarray.
2685    It will indicate the maximum number number of elements we may
2686    write.  The return value is the remainder of the outarray if
2687    successful, otherwise NULL.
2688    The meaning of extra_result depends on the return value:
2689    * On success, it's unused.
2690    * On destr_err, it's unused (but will later hold an error object)
2691    * On destr_must_call_k, it holds a list of operations.
2692 */
2693 kt_destr_outcome
2694 destructure
2695 (klink * sc, pko argobject, pko typespec, pko ** outarray,
2696  pko * past_end, pko * extra_result, int saw_optional)
2697 {
2698   if(*outarray == past_end)
2699     {
2700       /* $$IMPROVE ME  Treat this error like other mismatches */
2701       KERNEL_ERROR_0 (sc, "destructure: past end of output array");
2702     }
2703   if(_get_type(typespec) == T_DESTRUCTURE)
2704     {
2705       WITH_UNBOXED_UNSAFE(pdata,kt_vector,typespec);
2706       pko * ar_typespec = pdata->els;
2707       int left = pdata->len;
2708       for( ; left; ar_typespec++, left--)
2709         {
2710           pko tych = *ar_typespec;
2711
2712           /**** Check for special keys ****/
2713           if(tych == REF_KEY(K_TYCH_DOT))
2714             {
2715               if(left != 2)
2716                 {
2717                   KERNEL_ERROR_0 (sc, "destructure: After dot there must "
2718                                   "be exactly one typespec");
2719                 }
2720               else
2721                 { return destructure(sc, argobject,
2722                                      ar_typespec[1],
2723                                      outarray,
2724                                      past_end,
2725                                      extra_result,
2726                                      0);
2727                 }
2728             }
2729           if(tych == REF_KEY(K_TYCH_OPTIONAL))
2730             {
2731               if(saw_optional)
2732                 {
2733                   KERNEL_ERROR_0 (sc, "destructure: Can't have two optionals");
2734                 }
2735               else
2736                 {
2737                   saw_optional = 1;
2738                   continue;
2739                 }
2740             }
2741           /*** Manage stepping ***/
2742           if(!is_pair(argobject))
2743             {
2744               if(saw_optional)
2745                 {
2746                   *outarray[0] = K_INERT;
2747                   ++*outarray;
2748                 }
2749               else
2750                 if (is_promise (argobject))
2751                   {
2752                     WITH_BOX_TYPE(tag,typespec);
2753                     pko new_typespec =
2754                       mk_foresliced_basvector (typespec,
2755                                                pdata->len - left,
2756                                                *tag);
2757                     *extra_result =
2758                       destructure_make_ops (argobject,
2759                                             new_typespec,
2760                                             saw_optional);
2761                     return destr_must_call_k;
2762                   }
2763               else
2764                 {
2765                   return destr_err;
2766                 }
2767             }
2768           else
2769             {
2770               pko c = pair_car(0,argobject);
2771               argobject = pair_cdr(0,argobject);
2772               int outcome =
2773                 destructure (sc,
2774                              c,
2775                              tych,
2776                              outarray,
2777                              past_end,
2778                              extra_result,
2779                              0);
2780               switch (outcome)
2781                 {
2782                   /* Success keeps exploring */
2783                 case destr_success:
2784                   break;
2785                   /* Simple error just ends exploration */
2786                 case destr_err:
2787                   return destr_err;
2788                 case destr_must_call_k:
2789                   {
2790                     WITH_BOX_TYPE(tag,typespec);
2791                     /* $$IMPROVE ME If length = 0, this is just
2792                        REF_OPER (is_null) */
2793                     pko new_typespec =
2794                       mk_foresliced_basvector (typespec,
2795                                                pdata->len - left + 1,
2796                                                *tag);
2797                     pko raw_oplist = *extra_result;
2798                     *extra_result =
2799                       LISTSTAR4 (
2800                                  REF_OPER (destructure_resume),
2801                                  /* ^V= (result-so-far argobject spec
2802                                     optional?) */
2803                                  mk_load (LIST4 (mk_load_ix (0, 0),
2804                                                  argobject,
2805                                                  new_typespec,
2806                                                  kernel_bool (saw_optional))),
2807                                  mk_store (K_ANY, 1),
2808                                  /* ^V= result-so-far */
2809                                  raw_oplist);
2810                     return outcome;
2811                   }
2812                 default:
2813                   errx (7, "Unrecognized enumeration");
2814                 }
2815             }
2816         }
2817       if(argobject == K_NIL)
2818         { return destr_success; }
2819       else if (is_promise (argobject))
2820         {
2821           pko new_typespec = REF_OPER (is_null);
2822           *extra_result =
2823             destructure_make_ops (argobject,
2824                                   new_typespec,
2825                                   saw_optional);
2826           return destr_must_call_k;
2827         }
2828       else
2829         { return destr_err; }
2830
2831     }
2832   else if (!no_call_k(typespec))
2833     {
2834       if (!is_combiner (typespec))
2835         {
2836           KERNEL_ERROR_0 (sc, "spec must be a combiner");
2837           /* NOTREACHED */
2838         }
2839
2840       /* $$LIKELY BUG This somehow arranges to look at a typespec that
2841          is just a key, length 0 when interacting with nested. */
2842       *extra_result =
2843         destructure_make_ops_to_bool (argobject, typespec);
2844       return destr_must_call_k;
2845     }
2846   else if(typecheck(sc, argobject, typespec))
2847     {
2848       *outarray[0] = argobject;
2849       ++*outarray;
2850       return destr_success;
2851     }
2852   else if (is_promise (argobject))
2853     {
2854       *extra_result =
2855         destructure_make_ops (argobject,
2856                               typespec,
2857                               0);
2858       return destr_must_call_k;
2859     }
2860   else
2861     {
2862       return destr_err;
2863     }
2864 }
2865 /*_     , destructure_to_array */
2866 void
2867 destructure_to_array
2868 (klink * sc,
2869  pko obj,                      /* Object to extract values from */
2870  pko type,                     /* Type spec */
2871  pko * array,                  /* Array to be filled */
2872  size_t length,                /* Maximum length of that array */
2873  pko resume_op,             /* Combiner to schedule if we resume */
2874  pko resume_data            /* Extra data to the resume op */
2875  )
2876 {
2877   if (type == K_NO_TYPE)
2878     { return; }
2879   pko * orig_array = array;
2880   pko extra_result = 0;
2881   kt_destr_outcome outcome =
2882     destructure (sc, obj, type, &array, array + length, &extra_result, 0);
2883   switch (outcome)
2884     {
2885     case destr_success:
2886       return;
2887       /* NOTREACHED */
2888     case destr_err:
2889       {
2890         pko err = where_typemiss (sc, obj, type);
2891         extra_result = err ? err : mk_string("Couldn't find the typemiss");
2892         _klink_error_1 (sc, "type mismatch:",
2893                         LIST2(resume_data, extra_result));
2894         return;
2895       }
2896       /* NOTREACHED */
2897
2898     case destr_must_call_k:
2899       {
2900         /* Arrange for a resume. */
2901         int read_len = array - orig_array;
2902         pko result_so_far = mk_destr_result (read_len, orig_array, K_NIL);
2903         assert (is_combiner (resume_op));
2904         CONTIN_0_RAW (resume_op, sc);
2905         /* ^^^V= (final-destr_result . resume_data) */
2906         CONTIN_0_RAW (mk_load (LISTSTAR2 (mk_load_ix (0, 0),
2907                                           resume_data)),
2908                       sc);
2909         CONTIN_0_RAW (mk_store (K_ANY, 1), sc);
2910         /* ^^^V= final-destr_result */
2911         schedule_rv_list (sc, extra_result);
2912         /* ^^^V= current-destr_result */
2913         /* $$ENCAPSULATE ME */
2914         sc->value = result_so_far;
2915         longjmp (sc->pseudocontinuation, 1);
2916       /* NOTREACHED */
2917         return;
2918       }
2919       /* NOTREACHED */
2920
2921     default:
2922       errx (7, "Unrecognized enumeration");
2923     }
2924 }
2925
2926 /*_     , destructure_resume */
2927 SIG_CHKARRAY (destructure_resume) =
2928 {
2929   REF_OPER (is_destr_result),
2930   K_ANY,
2931   K_TY_DESTRSPEC,
2932   REF_OPER (is_bool),
2933 };
2934 DEF_SIMPLE_CFUNC (ps0a4, destructure_resume, 0)
2935 {
2936   WITH_4_ARGS (destr_result, argobject, typespec, opt_p);
2937   const int max_args = 5;
2938   pko arg_array [max_args];
2939   pko * outarray = arg_array;
2940   pko extra_result;
2941   kt_destr_outcome outcome =
2942     destructure (sc,
2943                  argobject,
2944                  typespec,
2945                  &outarray,
2946                  arg_array + max_args,
2947                  &extra_result,
2948                  (opt_p == K_T));
2949   switch (outcome)
2950     {
2951     case destr_success:
2952       {
2953         int new_len = outarray - arg_array;
2954         return
2955           mk_destr_result_add (destr_result, new_len, arg_array);
2956       }
2957       /* NOTREACHED */
2958     case destr_err:
2959       KERNEL_ERROR_1 (sc, "type mismatch:", extra_result);
2960       /* NOTREACHED */
2961
2962     case destr_must_call_k:
2963       {
2964         /* Arrange for another force+resume. This will feed whatever
2965            was there before. */
2966         int read_len = outarray - arg_array;
2967         pko result_so_far =
2968           mk_destr_result_add (destr_result,
2969                                read_len,
2970                                arg_array);
2971         schedule_rv_list (sc, extra_result);
2972         return result_so_far;
2973       }
2974       /* NOTREACHED */
2975
2976     default:
2977       errx (7, "Unrecognized enumeration");
2978       /* NOTREACHED */
2979     }
2980 }
2981 /*_     , do-destructure */
2982 /* We don't have a typecheck typecheck predicate yet, so accept
2983    anything for arg2. Really it can be what typecheck accepts or
2984    T_DESTRUCTURE, checked recursively.  */
2985 SIG_CHKARRAY (do_destructure) = { K_ANY, K_ANY, };
2986 DEF_SIMPLE_APPLICATIVE (ps0a2, do_destructure,T_NO_K,unsafe,"do-destructure")
2987 {
2988   WITH_2_ARGS (argobject,typespec);
2989   int len = destructure_how_many (typespec);
2990   pko vec = mk_vector (len, K_NIL);
2991   WITH_UNBOXED_UNSAFE (pdata,kt_vector,vec);
2992   destructure_to_array
2993     (sc,
2994      argobject,
2995      typespec,
2996      pdata->els,
2997      len,
2998      REF_OPER (destr_result_to_vec),
2999      K_NIL);
3000
3001   return vec;
3002 }
3003
3004 /*_   , C functions as objects */
3005 /*_    . Structs */
3006 /*_     , store */
3007 typedef struct kt_opstore
3008 {
3009   pko destr;                    /* Often a T_DESTRUCTURE */
3010   int frame_depth;
3011 } kt_opstore;
3012
3013 /*_    . cfunc */
3014 DEF_T_PRED (is_cfunc, T_CFUNC,no,"");
3015
3016 #if 0
3017 /* For external use, if some code ever wants to make these objects
3018    dynamically. */
3019 /* $$MAKE ME SAFE Set type-check fields */
3020 pko
3021 mk_cfunc (const kt_cfunc * f)
3022 {
3023   typedef kt_boxed_cfunc TT;
3024   errx(4, "Don't use mk_cfunc yet")
3025   TT *pbox = GC_MALLOC (sizeof (TT));
3026   pbox->type = T_CFUNC;
3027   pbox->data = *f;
3028   return PTR2PKO(pbox);
3029 }
3030 #endif
3031
3032 INLINE const kt_cfunc *
3033 get_cfunc_func (pko p)
3034 {
3035   WITH_PSYC_UNBOXED(kt_cfunc,p,T_CFUNC,0)
3036   return pdata;
3037 }
3038 /*_    . cfunc_resume */
3039 /*_     , Create */
3040 /*_      . mk_cfunc_resume */
3041 pko
3042 mk_cfunc_resume (pko cfunc)
3043 {
3044   ALLOC_BOX_PRESUME (kt_cfunc, T_CFUNC_RESUME);
3045   pbox->data = *get_cfunc_func (cfunc);
3046   return PTR2PKO(pbox);
3047 }
3048
3049 /*_    . Curried functions */
3050 /*_     , About objects */
3051 static INLINE int
3052 is_curried (pko p)
3053 { return is_type (p, T_CURRIED); }
3054
3055 INLINE pko
3056 mk_curried (decurrier_f decurrier, pko args, pko next)
3057 {
3058   ALLOC_BOX(pbox,T_CURRIED,kt_boxed_curried);
3059   pbox->data.decurrier = decurrier;
3060   pbox->data.args      = args;
3061   pbox->data.next      = next;
3062   pbox->data.argcheck  = 0;
3063   return PTR2PKO(pbox);
3064 }
3065 /*_     , Operations */
3066 /*_      . call_curried */
3067 pko
3068 call_curried(klink * sc, pko curried, pko value)
3069 {
3070   WITH_PSYC_UNBOXED(kt_curried,curried,T_CURRIED,sc);
3071
3072   /* First schedule the next one if there is any */
3073   if(pdata->next)
3074     {
3075       klink_push_cont(sc, pdata->next);
3076     }
3077
3078   /* Then call the decurrier with the data field and the value,
3079      returning its result. */
3080   return pdata->decurrier (sc, pdata->args, value);
3081 }
3082
3083 /*_    . Chains */
3084 /*_     , Struct */
3085 typedef kt_vector kt_chain;
3086
3087 /*_     , Creating */
3088 /*_      . Statically */
3089 #define SIG_CHAIN(C_NAME) pko CHAIN_NAME(C_NAME)[]
3090 #define DEF_CHAIN(NAME, ARRAY_NAME)                     \
3091   DEF_VEC(T_CHAIN | T_IMMUTABLE, NAME, ARRAY_NAME)
3092
3093 #define DEF_SIMPLE_CHAIN(C_NAME)                        \
3094   RGSTR(all-builtins,"C-" #C_NAME, REF_OPER (C_NAME))   \
3095   DEF_CHAIN(OPER(C_NAME), CHAIN_NAME(C_NAME))
3096
3097
3098 /*_     , Operations */
3099 void
3100 schedule_chain(klink * sc, const kt_vector * chain)
3101 {
3102   _kt_spagstack dump = sc->dump;
3103   int i;
3104   for(i = chain->len - 1; i >= 0; i--)
3105     {
3106       pko comb = chain->els[i];
3107       /* If frame_depth is unassigned, assign it. */
3108       if(_get_type(comb) == T_STORE)
3109         {
3110           WITH_UNBOXED_UNSAFE( pdata, kt_opstore, comb );
3111           if(pdata->frame_depth < 0)
3112             { pdata->frame_depth = chain->len - 1 - i; }
3113         }
3114       /* Push it as a combiner */
3115       dump = klink_push_cont_aux(dump, comb, sc->envir);
3116     }
3117   sc->dump = dump;
3118 }
3119
3120 /*_      . eval_chain */
3121 pko
3122 eval_chain( klink * sc, pko functor, pko value )
3123 {
3124   WITH_PSYC_UNBOXED( kt_vector, functor, T_CHAIN, 0 );
3125   schedule_chain( sc, pdata);
3126   return value;
3127 }
3128 /*_      . schedule_rv_list */
3129 void
3130 schedule_rv_list (klink * sc, pko list)
3131 {
3132   WITH_REPORTER (sc);
3133   _kt_spagstack dump = sc->dump;
3134   for(; list != K_NIL; list = cdr (list))
3135     {
3136       pko comb = car (list);
3137       /* $$PUNT If frame_depth is unassigned, assign it. */
3138
3139       /* Push it as a combiner */
3140       dump = klink_push_cont_aux(dump, comb, sc->envir);
3141     }
3142   sc->dump = dump;
3143 }
3144 /*_    . No-trace */
3145 /*_     , Create */
3146 inline static pko
3147 mk_notrace( pko combiner )
3148 {
3149   ALLOC_BOX_PRESUME( pko, T_NOTRACE );
3150   *pdata = combiner;
3151   return PTR2PKO(pbox);
3152 }
3153
3154 /*_     , Parts */
3155 inline static pko
3156 notrace_comb( pko p )
3157 {
3158   WITH_PSYC_UNBOXED( pko, p, T_NOTRACE, 0 );
3159   return *pdata;
3160 }
3161 /*_    . Store */
3162 /*_     , Create */
3163 /*_      . statically */
3164 #define STORE_DEF(DATA)                         \
3165   { T_STORE | T_IMMUTABLE, { DATA, -1, }, }
3166
3167 #define ANON_STORE(DATA)                        \
3168   ANON_REF (kt_opstore, STORE_DEF(DATA))
3169
3170 /*_      . dynamically */
3171 pko
3172 mk_store (pko data, int depth)
3173 {
3174   ALLOC_BOX_PRESUME(kt_opstore, T_STORE | T_IMMUTABLE);
3175   pdata->destr       = data;
3176   pdata->frame_depth = depth;
3177   return PTR2PKO(pbox);
3178 }
3179
3180 /*_    . Load */
3181 /*_     , Struct */
3182 typedef pko kt_opload;
3183
3184 /*_     , Create */
3185 /*_      . statically */
3186 #define LOAD_DEF( DATA )                        \
3187   { T_LOAD | T_IMMUTABLE, DATA, }
3188
3189 #define ANON_LOAD( DATA )                       \
3190   ANON_REF( pko, LOAD_DEF( DATA ))
3191
3192 #define ANON_LOAD_IX( X, Y )             \
3193   ANON_PAIR(ANON_REF(num, INT_DEF( X )), \
3194             ANON_REF(num, INT_DEF( Y )))
3195 /*_      . dynamically */
3196 /*_       , mk_load_ix */
3197 pko
3198 mk_load_ix (int x, int y)
3199 {
3200   return cons (mk_integer (x), mk_integer (y));
3201 }
3202 /*_       , mk_load */
3203 pko
3204 mk_load (pko data)
3205 {
3206   ALLOC_BOX_PRESUME(kt_opload, T_LOAD | T_IMMUTABLE);
3207   *pdata = data;
3208   return PTR2PKO(pbox);
3209 }
3210
3211 /*_   , pairs proper */
3212 /*_    . Type */
3213 DEF_T_PRED (is_pair, T_PAIR,ground, "pair?/o1");
3214
3215 /*_    . Create */
3216 SIG_CHKARRAY(Xcons) = { K_ANY, K_ANY, };
3217 DEF_SIMPLE_DESTR(Xcons);
3218 DEF_APPLICATIVE_W_DESTR(p00a2,mk_pair, REF_DESTR(Xcons),T_NO_K,ground, "cons")
3219 {
3220   WITH_2_ARGS(a,b);
3221   return cons (a, b);
3222 }
3223
3224 DEF_APPLICATIVE_W_DESTR(p00a2,mk_mutable_pair, REF_DESTR(Xcons),T_NO_K,ground, "mcons")
3225 {
3226   WITH_2_ARGS(a,b);
3227   return mcons (a, b);
3228 }
3229
3230 /*_    . Parts and operations */
3231
3232 SIG_CHKARRAY(pair_cxr) = { REF_OPER(is_pair), };
3233 DEF_SIMPLE_DESTR(pair_cxr);
3234 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_car, REF_DESTR(pair_cxr),T_NO_K,ground, "car")
3235 {
3236   WITH_1_ARGS(p);
3237   return v2car(sc,T_PAIR,p);
3238 }
3239
3240 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_cdr, REF_DESTR(pair_cxr),T_NO_K,ground, "cdr")
3241 {
3242   WITH_1_ARGS(p);
3243   return v2cdr(sc,T_PAIR,p);
3244 }
3245
3246 SIG_CHKARRAY(pair_set_cxr) = { REF_OPER(is_pair),  K_ANY, };
3247 DEF_SIMPLE_DESTR(pair_set_cxr);
3248 DEF_APPLICATIVE_W_DESTR(ps0a2,set_car, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-car!")
3249 {
3250   WITH_2_ARGS(p,q);
3251   v2set_car(sc,T_PAIR,p,q);
3252   return K_INERT;
3253 }
3254
3255 DEF_APPLICATIVE_W_DESTR(ps0a2,set_cdr, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-cdr!")
3256 {
3257   WITH_2_ARGS(p,q);
3258   v2set_cdr(sc,T_PAIR,p,q);
3259   return K_INERT;
3260 }
3261
3262
3263 /*_   , Strings */
3264 /*_    . Type */
3265 DEF_T_PRED (is_string, T_STRING,ground,"string?/o1");
3266 /*_    . Create */
3267
3268 INTERFACE INLINE pko
3269 mk_string (const char *str)
3270 {
3271   return mk_bastring (T_STRING, str, strlen (str), 0);
3272 }
3273
3274 INTERFACE INLINE pko
3275 mk_counted_string (const char *str, int len)
3276 {
3277   return mk_bastring (T_STRING, str, len, 0);
3278 }
3279
3280 INTERFACE INLINE pko
3281 mk_empty_string (int len, char fill)
3282 {
3283   return mk_bastring (T_STRING, 0, len, fill);
3284 }
3285 /*_    . Create static */
3286 /* $$WRITE ME  As for k_print_terminate_list macros */
3287
3288 /*_    . Accessors */
3289 INTERFACE INLINE char *
3290 string_value (pko p)
3291 {
3292   return bastring_value(0,T_STRING,p);
3293 }
3294
3295 INTERFACE INLINE int
3296 string_len (pko p)
3297 {
3298   return bastring_len(0,T_STRING,p);
3299 }
3300
3301 /*_   , Symbols */
3302 /*_    . Type */
3303 DEF_T_PRED(is_symbol, T_SYMBOL,ground,"symbol?/o1");
3304 /*_    . Create */
3305 static pko
3306 mk_symbol_obj (const char *name)
3307 {
3308   return mk_bastring (T_SYMBOL | T_IMMUTABLE, name, strlen (name), 0);
3309 }
3310
3311 /* We want symbol objects to be unique per name, so check an oblist of
3312    unique symbols. */
3313 INTERFACE pko
3314 mk_symbol (const char *name)
3315 {
3316   /* first check oblist */
3317   pko x = oblist_find_by_name (name);
3318   if (x != K_NIL)
3319     {
3320       return x;
3321     }
3322   else
3323     {
3324       x = oblist_add_by_name (name);
3325       return x;
3326     }
3327 }
3328 /*_    . oblist implementation */
3329 /*_     , Global object */
3330 static pko oblist = 0;
3331 /*_     , Oblist as hash table */
3332 #ifndef USE_OBJECT_LIST
3333
3334 static int hash_fn (const char *key, int table_size);
3335
3336 static pko
3337 oblist_initial_value ()
3338 {
3339   return mk_vector (461, K_NIL);
3340 }
3341
3342 /* returns the new symbol */
3343 static pko
3344 oblist_add_by_name (const char *name)
3345 {
3346   pko x = mk_symbol_obj (name);
3347   int location = hash_fn (name, vector_len (oblist));
3348   set_vector_elem (oblist, location,
3349                    cons (x, vector_elem (oblist, location)));
3350   return x;
3351 }
3352
3353 static INLINE pko
3354 oblist_find_by_name (const char *name)
3355 {
3356   int location;
3357   pko x;
3358   char *s;
3359   WITH_REPORTER(0);
3360
3361   location = hash_fn (name, vector_len (oblist));
3362   for (x = vector_elem (oblist, location); x != K_NIL; x = cdr (x))
3363     {
3364       s = symname (0,car (x));
3365       /* case-insensitive, per R5RS section 2. */
3366       if (stricmp (name, s) == 0)
3367         {
3368           return car (x);
3369         }
3370     }
3371   return K_NIL;
3372 }
3373
3374 static pko
3375 oblist_all_symbols (void)
3376 {
3377   int i;
3378   pko x;
3379   pko ob_list = K_NIL;
3380
3381   for (i = 0; i < vector_len (oblist); i++)
3382     {
3383       for (x = vector_elem (oblist, i); x != K_NIL; x = cdr (x))
3384         {
3385           ob_list = mcons (x, ob_list);
3386         }
3387     }
3388   return ob_list;
3389 }
3390
3391 /*_     , Oblist as list */
3392 #else
3393
3394 static pko
3395 oblist_initial_value ()
3396 {
3397   return K_NIL;
3398 }
3399
3400 static INLINE pko
3401 oblist_find_by_name (const char *name)
3402 {
3403   pko x;
3404   char *s;
3405   WITH_REPORTER(0);
3406   for (x = oblist; x != K_NIL; x = cdr (x))
3407     {
3408       s = symname (0,car (x));
3409       /* case-insensitive, per R5RS section 2. */
3410       if (stricmp (name, s) == 0)
3411         {
3412           return car (x);
3413         }
3414     }
3415   return K_NIL;
3416 }
3417
3418 /* returns the new symbol */
3419 static pko
3420 oblist_add_by_name (const char *name)
3421 {
3422   pko x = mk_symbol_obj (name);
3423   oblist = cons (x, oblist);
3424   return x;
3425 }
3426
3427 static pko
3428 oblist_all_symbols (void)
3429 {
3430   return oblist;
3431 }
3432
3433 #endif
3434
3435
3436 /*_    . Parts and operations */
3437 SIG_CHKARRAY(string_to_symbol) = { REF_OPER(is_string), };
3438 DEF_SIMPLE_APPLICATIVE(ps0a1,string_to_symbol,T_NO_K,ground, "string->symbol")
3439 {
3440   return mk_symbol(string_value(arg1));
3441 }
3442
3443 INTERFACE INLINE char *
3444 symname (sc_or_null sc, pko p)
3445 {
3446   return bastring_value (sc,T_SYMBOL, p);
3447 }
3448
3449
3450 /*_   , Vectors */
3451
3452 /*_    . Type */
3453 DEF_T_PRED (is_vector, T_VECTOR,unsafe,"vector?/o1");
3454
3455 /*_    . Create */
3456 /*_     , mk_vector (T_ level) */
3457 INTERFACE static pko
3458 mk_vector (int len, pko fill)
3459 { return mk_filled_basvector(len, fill, T_VECTOR); }
3460
3461 /*_     , k_mk_vector (K level) */
3462 /* $$RETHINK ME  This may not be wanted. */
3463 SIG_CHKARRAY(k_mk_vector) = { REF_OPER(is_integer), REF_KEY(K_TYCH_OPTIONAL), K_ANY, };
3464 DEF_SIMPLE_APPLICATIVE (ps0a2, k_mk_vector,T_NO_K,unsafe,"make-vector")
3465 {
3466   WITH_2_ARGS(k_len, fill);
3467
3468   int len = ivalue (k_len);
3469   if (fill == K_INERT)
3470     { fill = K_NIL; }
3471   return mk_vector (len, fill);
3472 }
3473
3474 /*_     , vector */
3475 /* K_ANY instead of REF_OPER(is_finite_list) because
3476    mk_basvector_w_args checks list-ness internally */
3477 DEF_APPLICATIVE_W_DESTR(ps0a1, vector, K_ANY,T_NO_K,unsafe,"vector")
3478 {
3479   WITH_1_ARGS(p);
3480   return mk_basvector_w_args(sc,p,T_VECTOR);
3481 }
3482
3483 /*_    . Operations (T_ level) */
3484 /*_     , fill_vector */
3485
3486 INTERFACE static void
3487 fill_vector (pko vec, pko obj)
3488 {
3489   assert(_get_type(vec) == T_VECTOR);
3490   unsafe_basvector_fill(vec,obj);
3491 }
3492
3493 /*_    . Parts of vectors (T_ level) */
3494
3495 INTERFACE static int
3496 vector_len (pko vec)
3497 {
3498   assert(_get_type(vec) == T_VECTOR);
3499   return basvector_len(vec);
3500 }
3501
3502 INTERFACE static pko
3503 vector_elem (pko vec, int ielem)
3504 {
3505   assert(_get_type(vec) == T_VECTOR);
3506   return basvector_elem(vec, ielem);
3507 }
3508
3509 INTERFACE static void
3510 set_vector_elem (pko vec, int ielem, pko a)
3511 {
3512   assert(_get_type(vec) == T_VECTOR);
3513   basvector_set_elem(vec, ielem, a);
3514   return;
3515 }
3516
3517 /*_   , Promises */
3518 /* T_PROMISE is essentially a handle, pointing to a pair of either
3519    (expression env) or (value #f).  We use #f, not nil, because nil is
3520    a possible environment. */
3521
3522 /*_    . Create */
3523 /*_     , $lazy */
3524 RGSTR(ground,"$lazy", REF_OPER(mk_promise_lazy))
3525 DEF_CFUNC(ps0a1, mk_promise_lazy, K_ANY_SINGLETON, T_NO_K)
3526 {
3527   WITH_1_ARGS(p);
3528   pko guts = mcons(p, mcons(sc->envir, mk_continuation(sc->dump)));
3529   return v2cons (T_PROMISE, guts, K_NIL);
3530 }
3531 /*_     , memoize */
3532 /* $$CHECK ME Is K_ANY correct?  Or K_ANY_SINGLETON?  */
3533 DEF_APPLICATIVE_W_DESTR(p00a1,mk_promise_memo,K_ANY,T_NO_K,ground,"memoize")
3534 {
3535   WITH_1_ARGS(p);
3536   pko guts = mcons(p, K_F);
3537   return v2cons (T_PROMISE, guts, K_NIL);
3538 }
3539 /*_    . Type */
3540
3541 DEF_T_PRED (is_promise,T_PROMISE,ground,"promise?/o1");
3542 /*_    . Helpers */
3543 /*_     , promise_schedule_eval */
3544 inline pko
3545 promise_schedule_eval(klink * sc, pko p)
3546 {
3547   WITH_REPORTER(sc);
3548   pko guts = unsafe_v2car(p);
3549   pko env     = car(cdr(guts));
3550   pko dynxtnt = cdr(cdr(guts));
3551   /* Arrange to eval the expression and pass the result to
3552      handle_promise_result */
3553   CONTIN_1R(dcrry_2ALLVLL,handle_promise_result,sc,p);
3554   /* $$ENCAP ME  This deals with continuation guts, so should be
3555      encapped.  As a special continuation-maker? */
3556   _kt_spagstack new_dump =
3557     special_dynxtnt (cont_dump(dynxtnt), sc->dump, env);
3558   sc->dump = new_dump;
3559   CONTIN_2(dcrry_2dotALL, kernel_eval, sc, car(guts), env);
3560   return K_INERT;
3561 }
3562 /*_     , handle_promise_result */
3563 SIG_CHKARRAY(handle_promise_result) = { REF_OPER(is_promise), K_ANY };
3564 DEF_SIMPLE_CFUNC(ps0a2,handle_promise_result,0)
3565 {
3566   /* guts are only made by C code so if they're wrong it's a C
3567      error */
3568   WITH_REPORTER(0);
3569   WITH_2_ARGS(p,value);
3570   pko guts = unsafe_v2car(p);
3571
3572   /* if p already has a result, return it */
3573   if(cdr(guts) == K_F)
3574     { return car(guts); }
3575   /* If value is again a promise, set this promise's guts to that
3576      promise's guts and force it again, which will force both (This is
3577      why we need promises to be 2-layer) */
3578   else if(is_promise(value))
3579     {
3580       unsafe_v2set_car (p, unsafe_v2car(value));
3581       return promise_schedule_eval(sc, p);
3582     }
3583   /* Otherwise set the value and return it. */
3584   else
3585     {
3586       unsafe_v2set_car (guts, value);
3587       unsafe_v2set_cdr (guts, K_F);
3588       return value;
3589     }
3590 }
3591 /*_    . Operations */
3592 /*_     , force */
3593 DEF_APPLICATIVE_W_DESTR (ps0a1, force, K_ANY_SINGLETON,T_NO_K,ground,"force")
3594 {
3595   /* guts are only made by this C code here, so if they're wrong it's
3596      a C error */
3597   WITH_REPORTER(0);
3598   WITH_1_ARGS(p);
3599   if(!is_promise(p))
3600     { return p; }
3601
3602   pko guts = unsafe_v2car(p);
3603   if(cdr(guts) == K_F)
3604     { return car(guts); }
3605   else
3606     { return promise_schedule_eval(sc,p); }
3607 }
3608
3609 /*_   , Ports */
3610 /*_    . Creating */
3611
3612 /* $$IMPROVE ME Just directly contain the port structure.  Possibly
3613    split port into several T_ types.  */
3614 static pko
3615 mk_port (port * pt)
3616 {
3617   ALLOC_BOX_PRESUME (port *, T_PORT);
3618   pbox->data = pt;
3619   return PTR2PKO(pbox);
3620 }
3621
3622 static port *
3623 port_rep_from_filename (const char *fn, int prop)
3624 {
3625   FILE *f;
3626   char *rw;
3627   port *pt;
3628   if (prop == (port_input | port_output))
3629     {
3630       rw = "a+";
3631     }
3632   else if (prop == port_output)
3633     {
3634       rw = "w";
3635     }
3636   else
3637     {
3638       rw = "r";
3639     }
3640   f = fopen (fn, rw);
3641   if (f == 0)
3642     {
3643       return 0;
3644     }
3645   pt = port_rep_from_file (f, prop);
3646   pt->rep.stdio.closeit = 1;
3647
3648 #if SHOW_ERROR_LINE
3649   if (fn)
3650     { pt->rep.stdio.filename = store_string (strlen (fn), fn, 0); }
3651
3652   pt->rep.stdio.curr_line = 0;
3653 #endif
3654   return pt;
3655 }
3656
3657 static pko
3658 port_from_filename (const char *fn, int prop)
3659 {
3660   port *pt;
3661   pt = port_rep_from_filename (fn, prop);
3662   if (pt == 0)
3663     {
3664       return K_NIL;
3665     }
3666   return mk_port (pt);
3667 }
3668
3669 static port *
3670 port_rep_from_file (FILE * f, int prop)
3671 {
3672   port *pt;
3673   pt = (port *) GC_MALLOC_ATOMIC (sizeof *pt);
3674   if (pt == NULL)
3675     {
3676       return NULL;
3677     }
3678   /* Don't care what goes in these but GC really wants to provide it
3679      so here are dummy objects to put it in. */
3680   GC_finalization_proc ofn;
3681   GC_PTR               ocd;
3682   GC_register_finalizer(pt, port_finalize_file, 0, &ofn, &ocd);
3683   pt->kind = port_file | prop;
3684   pt->rep.stdio.file = f;
3685   pt->rep.stdio.closeit = 0;
3686   return pt;
3687 }
3688
3689 static pko
3690 port_from_file (FILE * f, int prop)
3691 {
3692   port *pt;
3693   pt = port_rep_from_file (f, prop);
3694   if (pt == 0)
3695     {
3696       return K_NIL;
3697     }
3698   return mk_port (pt);
3699 }
3700
3701 static port *
3702 port_rep_from_string (char *start, char *past_the_end, int prop)
3703 {
3704   port *pt;
3705   pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3706   if (pt == 0)
3707     {
3708       return 0;
3709     }
3710   pt->kind = port_string | prop;
3711   pt->rep.string.start = start;
3712   pt->rep.string.curr = start;
3713   pt->rep.string.past_the_end = past_the_end;
3714   return pt;
3715 }
3716
3717 static pko
3718 port_from_string (char *start, char *past_the_end, int prop)
3719 {
3720   port *pt;
3721   pt = port_rep_from_string (start, past_the_end, prop);
3722   if (pt == 0)
3723     {
3724       return K_NIL;
3725     }
3726   return mk_port (pt);
3727 }
3728
3729 #define BLOCK_SIZE 256
3730
3731 static int
3732 realloc_port_string (port * p)
3733 {
3734   /* $$IMPROVE ME  Just use REALLOC. */
3735   char *start = p->rep.string.start;
3736   size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
3737   char *str = GC_MALLOC_ATOMIC (new_size);
3738   if (str)
3739     {
3740       memset (str, ' ', new_size - 1);
3741       str[new_size - 1] = '\0';
3742       strcpy (str, start);
3743       p->rep.string.start = str;
3744       p->rep.string.past_the_end = str + new_size - 1;
3745       p->rep.string.curr -= start - str;
3746       return 1;
3747     }
3748   else
3749     {
3750       return 0;
3751     }
3752 }
3753
3754
3755 static port *
3756 port_rep_from_scratch (void)
3757 {
3758   port *pt;
3759   char *start;
3760   pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3761   if (pt == 0)
3762     {
3763       return 0;
3764     }
3765   start = GC_MALLOC_ATOMIC (BLOCK_SIZE);
3766   if (start == 0)
3767     {
3768       return 0;
3769     }
3770   memset (start, ' ', BLOCK_SIZE - 1);
3771   start[BLOCK_SIZE - 1] = '\0';
3772   pt->kind = port_string | port_output | port_srfi6;
3773   pt->rep.string.start = start;
3774   pt->rep.string.curr = start;
3775   pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
3776   return pt;
3777 }
3778
3779 static pko
3780 port_from_scratch (void)
3781 {
3782   port *pt;
3783   pt = port_rep_from_scratch ();
3784   if (pt == 0)
3785     {
3786       return K_NIL;
3787     }
3788   return mk_port (pt);
3789 }
3790 /*_     , Interface */
3791 /*_      . open-input-file */
3792 SIG_CHKARRAY(k_open_input_file) =
3793   { REF_OPER(is_string), };
3794 DEF_SIMPLE_APPLICATIVE(ps0a1,k_open_input_file,0,ground, "open-input-file")
3795 {
3796   WITH_1_ARGS(filename);
3797   return port_from_filename (string_value(filename), port_file | port_input);
3798 }
3799
3800
3801 /*_    . Testing */
3802
3803 DEF_T_PRED (is_port, T_PORT,ground,"port?/o1");
3804
3805 DEF_SIMPLE_PRED (is_inport,T_NO_K,ground,"input-port?/o1")
3806 {
3807   WITH_1_ARGS(p);
3808   return is_port (p) && portvalue (p)->kind & port_input;
3809 }
3810
3811 DEF_SIMPLE_PRED (is_outport,T_NO_K,ground,"output-port?/o1")
3812 {
3813   WITH_1_ARGS(p);
3814   return is_port (p) && portvalue (p)->kind & port_output;
3815 }
3816
3817 /*_    . Values */
3818 INLINE port *
3819 portvalue (pko p)
3820 {
3821   WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3822   return *pdata;
3823 }
3824
3825 INLINE void
3826 set_portvalue (pko p, port * newport)
3827 {
3828   assert_mutable(0,p);
3829   WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3830   *pdata = newport;
3831   return;
3832 }
3833
3834 /*_    . reading from ports */
3835 static int
3836 inchar (port *pt)
3837 {
3838   int c;
3839
3840   if (pt->kind & port_saw_EOF)
3841     { return EOF; }
3842   c = basic_inchar (pt);
3843   if (c == EOF)
3844     { pt->kind |= port_saw_EOF; }
3845 #if SHOW_ERROR_LINE
3846   else if (c == '\n')
3847     {
3848       if (pt->kind & port_file)
3849         { pt->rep.stdio.curr_line++; }
3850     }
3851 #endif
3852
3853   return c;
3854 }
3855
3856 static int
3857 basic_inchar (port * pt)
3858 {
3859   if (pt->kind & port_file)
3860     {
3861       return fgetc (pt->rep.stdio.file);
3862     }
3863   else
3864     {
3865       if (*pt->rep.string.curr == 0 ||
3866           pt->rep.string.curr == pt->rep.string.past_the_end)
3867         {
3868           return EOF;
3869         }
3870       else
3871         {
3872           return *pt->rep.string.curr++;
3873         }
3874     }
3875 }
3876
3877 /* back character to input buffer */
3878 static void
3879 backchar (port * pt, int c)
3880 {
3881   if (c == EOF)
3882     { return; }
3883
3884   if (pt->kind & port_file)
3885     {
3886       ungetc (c, pt->rep.stdio.file);
3887 #if SHOW_ERROR_LINE
3888       if (c == '\n')
3889         {
3890           pt->rep.stdio.curr_line--;
3891         }
3892 #endif
3893     }
3894   else
3895     {
3896       if (pt->rep.string.curr != pt->rep.string.start)
3897         {
3898           --pt->rep.string.curr;
3899         }
3900     }
3901 }
3902
3903 /*_     , Interface */
3904
3905 /*_      . (get-char textual-input-port) */
3906 SIG_CHKARRAY(get_char) = { REF_OPER(is_inport), };
3907 DEF_SIMPLE_APPLICATIVE(p00a1,get_char,T_NO_K,ground, "get-char")
3908 {
3909   WITH_1_ARGS(port);
3910   assert(is_inport(port));
3911   int c = inchar(portvalue(port));
3912   if(c == EOF)
3913     { return K_EOF; }
3914   else
3915     { return mk_character(c); }
3916 }
3917
3918 /*_    . Finalization */
3919 static void
3920 port_finalize_file(GC_PTR obj, GC_PTR client_data)
3921 {
3922   port *pt = obj;
3923   if ((pt->kind & port_file) && pt->rep.stdio.closeit)
3924     { port_close_port (pt, port_input | port_output); }
3925 }
3926
3927 static void
3928 port_close (pko p, int flag)
3929 {
3930   assert(is_port(p));
3931   port_close_port(portvalue (p), flag);
3932 }
3933
3934 static void
3935 port_close_port (port * pt, int flag)
3936 {
3937   pt->kind &= ~flag;
3938   if ((pt->kind & (port_input | port_output)) == 0)
3939     {
3940       if (pt->kind & port_file)
3941         {
3942 #if SHOW_ERROR_LINE
3943           /* Cleanup is here so (close-*-port) functions could work too */
3944           pt->rep.stdio.curr_line = 0;
3945
3946 #endif
3947
3948           fclose (pt->rep.stdio.file);
3949         }
3950       pt->kind = port_free;
3951     }
3952 }
3953
3954
3955 /*_   , Encapsulation type */
3956
3957 SIG_CHKARRAY(is_encap) = { REF_OPER(is_key), K_ANY };
3958 DEF_SIMPLE_CFUNC(b00a2, is_encap,T_NO_K)
3959 {
3960   WITH_2_ARGS(type, p);
3961   if (is_type (p, T_ENCAP))
3962     {
3963       WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
3964       return (pdata->type == type);
3965     }
3966   else
3967     {
3968       return 0;
3969     }
3970 }
3971
3972 /* NOT directly part of the interface. */
3973 SIG_CHKARRAY(unencap) = { REF_OPER(is_key),  K_ANY};
3974 DEF_SIMPLE_CFUNC(ps0a2, unencap,T_NO_K)
3975 {
3976   WITH_2_ARGS(type, p);
3977   if (is_encap (type, p))
3978     {
3979       WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
3980       return pdata->value;
3981     }
3982   else
3983     {
3984       /* We have no type-name to give to the error message. */
3985       KERNEL_ERROR_0 (sc, "unencap: wrong type");
3986     }
3987 }
3988
3989 /* NOT directly part of the interface. */
3990 SIG_CHKARRAY(mk_encap) = { REF_OPER(is_key),  K_ANY};
3991 DEF_SIMPLE_CFUNC(p00a2, mk_encap,T_NO_K)
3992 {
3993   WITH_2_ARGS(type, value);
3994   ALLOC_BOX_PRESUME (kt_encap, T_ENCAP);
3995   pbox->data.type = type;
3996   pbox->data.value = value;
3997   return PTR2PKO(pbox);
3998 }
3999
4000 DEF_APPLICATIVE_W_DESTR (p00a0, mk_encapsulation_type, K_NO_TYPE,T_NO_K,ground, "make-encapsulation-type/raw")
4001 {
4002   /* A unique cell representing a type */
4003   pko type = mk_void();
4004   /* $$IMPROVE ME make typespecs for the curried objs.  trivpred is
4005      effectively that spec object.  */
4006   pko e   = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (mk_encap)));
4007   pko trivpred = mk_curried (dcrry_2ALLV01, type, REF_OPER (is_encap));
4008   pko d   = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (unencap)));
4009   return LIST3 (e, trivpred, d);
4010 }
4011 /*_   , Listloop types */
4012 /*_    . Forward declarations */
4013 struct kt_listloop;
4014 /*_    . Enumerations */
4015 /*_     , Next-style */
4016 /* How to turn the current list into current value and next list. */
4017 typedef enum
4018 {
4019   lls_1list,
4020   lls_many,
4021   lls_neighbors,
4022   lls_max,
4023 } kt_loopstyle_step;
4024 typedef enum
4025 {
4026   lls_combiner,
4027   lls_count,
4028   lls_top_count,
4029   lls_stop_on,
4030   lls_num_args,
4031 } kt_loopstyle_argix;
4032
4033 /*_    . Function signatures. */
4034 typedef pko (* kt_listloop_mk_val)(pko value,  struct kt_listloop * pll);
4035 /*_    . Struct */
4036 typedef struct kt_listloop_style
4037 {
4038   pko                combiner;  /* Default combiner or NULL. */
4039   int                collect_p; /* Whether to collect a (reversed)
4040                                    list of the returns. */
4041   kt_loopstyle_step  step;
4042   kt_listloop_mk_val mk_val; /* From returned value+state -> passed value. */
4043   pko                destructurer; /* A destructurer contents */
4044   /* Selection of args.  Each entry correspond to one arg in "full
4045      args", and indexes something in the array of actual args that the
4046      destructurer retrieves. */
4047   int                arg_select[lls_num_args];
4048 } kt_listloop_style;
4049 typedef struct kt_listloop
4050 {
4051   pko combiner;                 /* The combiner to use repeatedly. */
4052   pko list;                     /* The list to loop over */
4053   int top_length;               /* Length of top element, for lls_many. */
4054   int countdown;                /* Num elements left, or negative if unused. */
4055   int countup;                  /* Upwards count from 0. */
4056   pko stop_on;                  /* Stop if return value is this. Can
4057                                    be 0 for unused. */
4058   kt_listloop_style * style;    /* Non-NULL pointer to style. */
4059 } kt_listloop;
4060 /*_     , Internal signatures */
4061 pko
4062 listloop_aux (klink * sc,
4063               kt_listloop_style * style_v,
4064               pko list,
4065               pko style_args[lls_num_args]);
4066 FORWARD_DECL_CFUNC (static, ps0a3, listloop_resume);
4067
4068 /*_    . Creating */
4069 /*_     , Listloop styles */
4070 /* Unused */
4071 pko
4072 mk_listloop_style
4073 (pko combiner,
4074  int collect_p,
4075  kt_loopstyle_step step,
4076  kt_listloop_mk_val mk_val)
4077 {
4078   ALLOC_BOX_PRESUME(kt_listloop_style,T_LISTLOOP_STYLE);
4079   pdata->combiner   = combiner;
4080   pdata->collect_p  = collect_p;
4081   pdata->step       = step;
4082   pdata->mk_val     = mk_val;
4083   return PTR2PKO(pbox);
4084 }
4085 /*_     , Listloops */
4086 pko
4087 mk_listloop
4088 (pko combiner,
4089  pko list,
4090  int top_length,
4091  int count,
4092  pko stop_on,
4093  kt_listloop_style * style)
4094 {
4095   ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
4096   pdata->combiner   = combiner;
4097   pdata->list       = list;
4098   pdata->top_length = top_length;
4099   pdata->countdown  = count;
4100   pdata->countup    = -1;
4101   pdata->stop_on    = stop_on;
4102   pdata->style      = style;
4103   return PTR2PKO(pbox);
4104 }
4105 /*_     , Copying */
4106 pko
4107 copy_listloop(const kt_listloop * orig)
4108 {
4109   ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
4110   memcpy (pdata, orig, sizeof(kt_listloop));
4111   return PTR2PKO(pbox);
4112 }
4113 /*_    . Testing */
4114 /* Unused so far */
4115 DEF_T_PRED(is_listloop,       T_LISTLOOP,       no, "");
4116 DEF_T_PRED(is_listloop_style, T_LISTLOOP_STYLE, no, "");
4117 /*_    . Val-makers */
4118 /*_    . Pre-existing style objects */
4119 /*_     , listloop-style-sequence */
4120 RGSTR(simple,"listloop-style-sequence",REF_OBJ(sequence_style))
4121 static BOX_OF(kt_listloop_style) sequence_style =
4122 {
4123   T_LISTLOOP_STYLE,
4124   {
4125     REF_OPER(kernel_eval),
4126     0,
4127     lls_1list,
4128     0,
4129     K_NO_TYPE,                  /* No args contemplated */
4130     { [0 ... lls_num_args - 1] = -1, }
4131   }
4132 };
4133 /*_     , listloop-style-neighbors */
4134 RGSTR(simple,"listloop-style-neighbors",REF_OBJ(neighbor_style))
4135 SIG_CHKARRAY(neighbor_style) =
4136   {
4137     REF_OPER(is_integer),
4138   };
4139 DEF_SIMPLE_DESTR(neighbor_style);
4140 static BOX_OF(kt_listloop_style) neighbor_style =
4141 {
4142   T_LISTLOOP_STYLE,
4143   {
4144     REF_OPER(val2val),
4145     1,
4146     lls_neighbors,
4147     0,
4148     REF_DESTR(neighbor_style),
4149     /* See http://gcc.gnu.org/onlinedocs/gcc/Designated-Inits.html. */
4150     { [0 ... lls_num_args - 1] = -1, [lls_count] = 0, },
4151   }
4152 };
4153 /*_    . Operations */
4154 /*_     , listloop */
4155 /* Create a listloop object. */
4156 /* $$IMPROVE ME This may become what style operative T_ type calls.
4157    Rename it eval_listloop_style. */
4158 SIG_CHKARRAY(listloop) =
4159 {
4160   REF_OPER(is_listloop_style),
4161   REF_OPER(is_countable_list),
4162   REF_KEY(K_TYCH_DOT),
4163   K_ANY,
4164 };
4165
4166 DEF_SIMPLE_APPLICATIVE(ps0a3, listloop,0,ground, "listloop")
4167 {
4168   WITH_3_ARGS(style, list, args);
4169
4170   WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
4171   pko style_args[lls_num_args];
4172   /* Destructure the args by style */
4173   destructure_to_array(sc,
4174                        args,
4175                        style_v->destructurer,
4176                        style_args,
4177                        lls_num_args,
4178                        REF_OPER (listloop_resume),
4179                        LIST2 (style, list));
4180   return listloop_aux (sc, style_v, list, style_args);
4181 }
4182 /*_     , listloop_resume */
4183 SIG_CHKARRAY (listloop_resume) =
4184 {
4185   REF_OPER (is_destr_result),
4186   REF_OPER(is_listloop_style),
4187   REF_OPER(is_countable_list),
4188 };
4189 DEF_SIMPLE_CFUNC(ps0a3, listloop_resume, 0)
4190 {
4191   WITH_3_ARGS (destr_result, style, list);
4192   pko style_args[lls_num_args];
4193   destr_result_fill_array (destr_result, lls_num_args, style_args);
4194   WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
4195   return listloop_aux (sc, style_v, list, style_args);
4196 }
4197 /*_     , listloop_aux */
4198 pko
4199 listloop_aux
4200 (klink * sc, kt_listloop_style * style_v, pko list, pko style_args[lls_num_args])
4201 {
4202   /*** Get the actual arg objects ***/
4203 #define GET_OBJ(_INDEX) \
4204   ((style_v->arg_select[_INDEX] < 0) ? K_INERT : style_args[style_v->arg_select[_INDEX]])
4205
4206   pko count      = GET_OBJ(lls_count);
4207   pko combiner   = GET_OBJ(lls_combiner);
4208   pko top_length = GET_OBJ(lls_top_count);
4209 #undef GET_OBJ
4210
4211   /*** Extract values from the objects, using defaults as needed ***/
4212   int countv      = (count      == K_INERT) ? -1L : ivalue(count);
4213   int top_lengthv = (top_length == K_INERT) ? 1 : ivalue(top_length);
4214   if(combiner == K_INERT)
4215     {
4216       combiner = style_v->combiner;
4217     }
4218
4219   /*** Make the loop object itself ***/
4220   pko ll = mk_listloop( combiner, list, top_lengthv, countv, 0, style_v );
4221   return ll;
4222 }
4223 /*_     , Evaluating one iteration */
4224 pko
4225 eval_listloop(klink * sc, pko functor, pko value)
4226 {
4227   WITH_REPORTER(sc);
4228   WITH_PSYC_UNBOXED(kt_listloop, functor, T_LISTLOOP, sc);
4229
4230   /*** Test whether done, maybe return current value. ***/
4231   /* If we're not checking, value will be NULL so this won't
4232      trigger.  pdata->countup is 0 for the first element. */
4233   if((pdata->countup >= 0) && (value == pdata->stop_on))
4234     {
4235       /* $$IMPROVE ME  This will ct an "abnormal return" value from
4236          this and the other data.  */
4237       return value;
4238     }
4239   /* If we're not counting down, value will be negative so this won't
4240      trigger.  */
4241   if(pdata->countdown == 0)
4242     {
4243       return value;
4244     }
4245   /* And if we run out of elements, we have to stop regardless. */
4246   if(pdata->list == K_NIL)
4247     {
4248       /* $$IMPROVE ME Error if we're counting down (ie, if count
4249          is positive). */
4250       return value;
4251     }
4252
4253   /*** Step list, getting new value ***/
4254   pko new_list, new_value;
4255
4256   switch(pdata->style->step)
4257     {
4258     case lls_1list:
4259       new_list  = cdr( pdata->list );
4260       /* We assume the common case of val as list. */
4261       new_value = LIST1(car( pdata->list ));
4262       break;
4263
4264     case lls_neighbors:
4265       /* $$IMPROVE ME Also test that next item (new_list) is non-empty */
4266       new_list  = cdr( pdata->list );
4267       new_value = LIST2(car( pdata->list ), car(new_list));
4268       break;
4269     case lls_many:
4270       new_list  = k_counted_map_cdr(sc, pdata->top_length, pdata->list, T_PAIR);
4271       new_value = k_counted_map_car(sc, pdata->top_length, pdata->list, T_PAIR);
4272       break;
4273     default:
4274       KERNEL_ERROR_0(sc,"I know nut-ting about that case");
4275     }
4276
4277   /* Convert it if applicable. */
4278   if(pdata->style->mk_val)
4279     {
4280       new_value = pdata->style->mk_val(new_value, pdata);
4281     }
4282
4283   /*** Arrange a new iteration. ***/
4284   /* We don't have to re-setup the final chain, if any, because it's
4285      still there from the earlier call.  Just the combiner (if any)
4286      and a fresh listloop operative.  */
4287   pko new_listloop = copy_listloop(pdata);
4288   {
4289     WITH_UNBOXED_UNSAFE(new_pdata,kt_listloop,new_listloop);
4290     new_pdata->list = new_list;
4291     if(new_pdata->countdown > 0)
4292       { new_pdata->countdown--; }
4293     new_pdata->countup++;
4294   }
4295
4296   if(pdata->style->collect_p)
4297     {
4298       CONTIN_0_RAW (mk_curried(dcrry_NVLLdotALL, value, new_listloop), sc);
4299     }
4300   else
4301     {
4302       CONTIN_0_RAW(new_listloop, sc);
4303     }
4304
4305   CONTIN_0_RAW(pdata->combiner, sc);
4306   return new_value;
4307 }
4308
4309 /*_  . Handling lists */
4310 /*_   , list* */
4311 DEF_APPLICATIVE_W_DESTR (ps0a1, list_star, REF_OPER(is_finite_list),T_NO_K,ground, "list*")
4312 {
4313   return v2list_star(sc, arg1, T_PAIR);
4314 }
4315 /*_   , reverse */
4316 SIG_CHKARRAY(reverse) = { REF_OPER(is_finite_list), };
4317 DEF_SIMPLE_APPLICATIVE (ps0a1, reverse,T_NO_K,ground, "reverse")
4318 {
4319   WITH_1_ARGS(a);
4320   return v2reverse(a,T_PAIR);
4321 }
4322 /*_    . reverse list -- in-place */
4323 /* Don't just use unsafe_v2reverse_in_place, it checks nothing.  This
4324    may be reserved for optimization only. */
4325
4326 /*_    . append list -- produce new list */
4327 /* $$IMPROVE ME  This defines append/2 but we'll want append/N.  Do
4328    that in init. */
4329 SIG_CHKARRAY(append) = { REF_OPER(is_finite_list), K_ANY, };
4330 DEF_SIMPLE_APPLICATIVE (ps0a2, append,T_NO_K,simple, "append")
4331 {
4332   WITH_2_ARGS(a,b);
4333   return v2append(sc,a,b,T_PAIR);
4334 }
4335 /*_   , is_finite_list */
4336 DEF_SIMPLE_PRED (is_finite_list,T_NO_K,ground, "finite-list?/o1")
4337 {
4338   WITH_1_ARGS(p);
4339   int4 metrics;
4340   get_list_metrics_aux(p, metrics);
4341   return (metrics[lm_num_nils] == 1);
4342 }
4343 /*_   , is_countable_list */
4344 DEF_SIMPLE_PRED (is_countable_list,T_NO_K,ground, "countable-list?/o1")
4345 {
4346   WITH_1_ARGS(p);
4347   int4 metrics;
4348   get_list_metrics_aux(p, metrics);
4349   return (metrics[lm_num_nils] || metrics[lm_cyc_len]);
4350 }
4351 /*_   , list_length */
4352 /* Result is:
4353    proper list: length
4354    circular list: -1
4355    not even a pair: -2
4356    dotted list: -2 minus length before dot
4357
4358    The extra meanings will change since callers can use
4359    get_list_metrics_aux now.  Return lm_acyc_len even for dotted
4360    lists, return positive infinity for circular lists.
4361 */
4362 /* $$OBSOLESCENT */
4363 int
4364 list_length (pko p)
4365 {
4366   int4 metrics;
4367   get_list_metrics_aux(p, metrics);
4368   /* A proper list */
4369   if(metrics[lm_num_nils] == 1)
4370     { return metrics[lm_acyc_len]; }
4371   /* A circular list */
4372   /* $$IMPROVE ME Return +oo.  First make a type and object for +oo  */
4373   if(metrics[lm_cyc_len] != 0)
4374     { return -1; }
4375   /* $$IMPROVE ME Return lm_acyc_len again, merge with the other
4376      case. */
4377   /* Otherwise it's dotted */
4378   return 2 - metrics[lm_acyc_len];
4379 }
4380 /*_   , list_length_k */
4381 DEF_APPLICATIVE_W_DESTR(p00a1, list_length_k, K_ANY_SINGLETON,T_NO_K,ground, "length")
4382 {
4383   WITH_1_ARGS(p);
4384   return mk_integer(list_length(p));
4385 }
4386
4387 /*_   , get_list_metrics */
4388 DEF_APPLICATIVE_W_DESTR(p00a1, get_list_metrics, K_ANY_SINGLETON,T_NO_K,ground, "get-list-metrics")
4389 {
4390   WITH_1_ARGS(p);
4391   int4 metrics;
4392   get_list_metrics_aux(p, metrics);
4393   return LIST4(mk_integer(metrics[0]),
4394                mk_integer(metrics[1]),
4395                mk_integer(metrics[2]),
4396                mk_integer(metrics[3]));
4397 }
4398 /*_   , get_list_metrics_aux */
4399 /* RESULTS must be an int4 (an array of 4 integers).  get_list_metrics_aux
4400    will fill it with (See enum lm_index):
4401
4402    * the number of pairs in a
4403    * the number of nil objects in a
4404    * the acyclic prefix length of a
4405    * the cycle length of a
4406 */
4407
4408 /* $$IMPROVE ME Take a flag so we can skip work such as finding
4409    prefix-length when we don't need to do it.  This will cause some
4410    result positions to be interpreted differently: when it's cycling,
4411    lm_acyc_len and lm_num_pairs may both overshoot (but never
4412    undershoot).
4413 */
4414
4415 void
4416 get_list_metrics_aux (pko a, int4 presults)
4417 {
4418   int * results = presults;     /* Make it easier to index. */
4419   int steps = 0;
4420   int power = 1;
4421   int loop_len = 1;
4422   pko slow, fast;
4423   WITH_REPORTER(0);
4424
4425   /* Use Brent's Algorithm, but we have to check for nil and non-pair
4426      too, so I rearranged the loop.  We also count steps, because in
4427      some cases we use number of steps directly. */
4428   slow = fast = a;
4429   while (1)
4430     {
4431       if (fast == K_NIL)
4432         {
4433           results[lm_num_pairs] = steps;
4434           results[lm_num_nils]  = 1;
4435           results[lm_acyc_len]  = steps;
4436           results[lm_cyc_len]   = 0;
4437           return;
4438         }
4439       if (!is_pair (fast))
4440         {
4441           results[lm_num_pairs] = steps;
4442           results[lm_num_nils]  = 0;
4443           results[lm_acyc_len]  = steps;
4444           results[lm_cyc_len]   = 0;
4445           return;
4446         }
4447       fast = cdr (fast);
4448       if (fast == slow)
4449         {
4450           /* The fast cursor has caught up with the slow cursor so the
4451              structure is circular and loop_len is the cycle length.
4452              We still need to find prefix length.
4453           */
4454           int prefix_len = 0;
4455           int i = 0;
4456           /* Restart the turtle from the beginning */
4457           slow = a;
4458           /* Restart the hare from position LOOP_LEN */
4459           for(i = 0, fast = a; i < loop_len; i++)
4460             { fast = cdr (fast); }
4461           /* Since hare has exactly a loop_len head start, when it
4462              goes around the loop exactly once it will be in the same
4463              position as turtle, so turtle will have only walked the
4464              acyclic prefix. */
4465           while(fast != slow)
4466             {
4467               fast = cdr (fast);
4468               slow = cdr (slow);
4469               prefix_len++;
4470             }
4471
4472           results[lm_num_pairs] = prefix_len + loop_len;
4473           results[lm_num_nils]  = 0;
4474           results[lm_acyc_len]  = prefix_len;
4475           results[lm_cyc_len]   = loop_len;
4476           return;
4477         }
4478       if(power == loop_len)
4479         {
4480           /* Re-plant the slow cursor */
4481           slow = fast;
4482           loop_len = 0;
4483           power *= 2;
4484         }
4485       ++loop_len;
4486       ++steps;
4487     }
4488 }
4489 /*_  . Handling trees */
4490 /*_   , copy_es_immutable */
4491 DEF_APPLICATIVE_W_DESTR (ps0a1, copy_es_immutable, K_ANY_SINGLETON,T_NO_K,ground, "copy-es-immutable")
4492 {
4493   WITH_1_ARGS(object);
4494   WITH_REPORTER(sc);
4495   if (is_pair (object))
4496     {
4497       /* If it's already immutable, can we assume it's immutable
4498        * all the way down and just return it? */
4499       return cons
4500         (copy_es_immutable (sc, car (object)),
4501          copy_es_immutable (sc, cdr (object)));
4502     }
4503   else
4504     {
4505       return object;
4506     }
4507 }
4508 /*_   , Get tree cycles */
4509 /*_    . Structs */
4510 /*_     , kt_recurrence_table */
4511 /* Really just a specialized resizeable lookup table from object to
4512    count.  Internals may change.  */
4513 /* $$IMPROVE ME Look up more efficiently.  Current GC is not
4514    compacting, so we can hash or sort addresses meaningfully.  */
4515 typedef struct
4516 {
4517   pko * objs;
4518   int     * counts;
4519   int table_size;
4520   int alloced_size;
4521 }
4522 kt_recurrence_table;
4523 /*_     , recur_entry */
4524 typedef struct
4525 {
4526   /* $$IMPROVE ME  These two fields may become one enumerated field */
4527   int count;
4528   int seen_in_walk;
4529   int index_in_walk;
4530 } recur_entry;
4531 /*_     , kt_recur_tracker */
4532 typedef struct
4533 {
4534   pko     * objs;
4535   recur_entry * entries;
4536   int table_size;
4537   int current_index;
4538 } kt_recur_tracker;
4539 /*_    . is_recurrence_table */
4540 DEF_T_PRED(is_recurrence_table,T_RECURRENCES,ground, "recurrence-table?/o1");
4541
4542 /*_    . is_recur_tracker */
4543 DEF_SIMPLE_PRED(is_recur_tracker,T_NO_K,ground, "recur-tracker?/o1")
4544 {
4545   WITH_1_ARGS(p);
4546   return (p == K_NIL) || is_type (p, T_RECUR_TRACKER);
4547 }
4548 /*_    . recurrences_to_recur_tracker */
4549 SIG_CHKARRAY(recurrences_to_recur_tracker) =
4550 { REF_OPER(is_recurrence_table), };
4551 DEF_SIMPLE_APPLICATIVE(p00a1,recurrences_to_recur_tracker,T_NO_K,ground, "recurrences->tracker")
4552 {
4553   WITH_1_ARGS(recurrences);
4554   assert_type(0,recurrences,T_RECURRENCES);
4555
4556   WITH_UNBOXED_UNSAFE(ptable, kt_recurrence_table,recurrences);
4557   /* $$IMPROVE ME Scan for counts > 1, and if there are none,
4558      return K_NIL. */
4559   if(ptable->table_size == 0)
4560     { return K_NIL; }
4561   {
4562     ALLOC_BOX_PRESUME(kt_recur_tracker,T_RECUR_TRACKER);
4563     /* $$MAKE ME SAFE This assumes that sharing is OK, recurrences
4564        won't mutate the LUT.  When we have COW or similar, make it
4565        safe.  At least check for immutability.  */
4566     pdata->objs       = ptable->objs;
4567     pdata->table_size = ptable->table_size;
4568     pdata->current_index = 0;
4569     pdata->entries =
4570       GC_MALLOC_ATOMIC(sizeof(recur_entry) * ptable->table_size);
4571     int i;
4572     for(i = 0; i < ptable->table_size; i++)
4573       {
4574         recur_entry * p_entry = &pdata->entries[i];
4575         p_entry->count = ptable->counts[i];
4576         p_entry->index_in_walk = 0;
4577         p_entry->seen_in_walk  = 0;
4578       }
4579     return PTR2PKO(pbox);
4580   }
4581 }
4582 /*_    . recurrences_list_objects */
4583 /* $$WRITE ME  Get a list of all objects and their recurrence counts */
4584 /*_    . objtable_get_index */
4585 int
4586 objtable_get_index
4587 (pko * objs, int table_size, pko obj)
4588 {
4589   int i;
4590   for(i = 0; i < table_size; i++)
4591     {
4592       if(obj == objs[i])
4593         { return i; }
4594     }
4595   return -1;
4596 }
4597 /*_    . recurrences_get_seen_count */
4598 /* Return the number of times OBJ has been seen before.  If "add" is
4599    non-zero, increment the count too (but return its previous
4600    value).  */
4601 int
4602 recurrences_get_seen_count
4603 (kt_recurrence_table * p_cycles_data, pko obj, int add)
4604 {
4605   int index = objtable_get_index(p_cycles_data->objs,
4606                                  p_cycles_data->table_size,
4607                                  obj);
4608   if(index >= 0)
4609     {
4610       int count = p_cycles_data->counts[index];
4611       /* Maybe record another sighting of this object. */
4612       if(add)
4613         { p_cycles_data->counts[index]++; }
4614       /* We've found our return value. */
4615       return count;
4616     }
4617
4618   /* We only get here if search didn't find anything. */
4619   /* Make sure we have enough space for this object. */
4620   if(add)
4621     {
4622       if(p_cycles_data->table_size == p_cycles_data->alloced_size)
4623         {
4624           p_cycles_data->alloced_size *= 2;
4625           p_cycles_data->counts = GC_REALLOC(p_cycles_data->counts, sizeof(int) * p_cycles_data->alloced_size);
4626           p_cycles_data->objs = GC_REALLOC(p_cycles_data->objs, sizeof(pko) * p_cycles_data->alloced_size);
4627         }
4628       int index = p_cycles_data->table_size;
4629       /* Record what it was */
4630       p_cycles_data->objs[index] = obj;
4631       /* We have now seen it once. */
4632       p_cycles_data->counts[index] = 1;
4633       p_cycles_data->table_size++;
4634     }
4635   return 0;
4636 }
4637 /*_    . recurrences_get_object_count */
4638 /* Given an object, list its count */
4639 SIG_CHKARRAY(recurrences_get_object_count) =
4640 { REF_OPER(is_recurrence_table), K_ANY, };
4641 DEF_SIMPLE_APPLICATIVE(p00a2, recurrences_get_object_count,T_NO_K,ground, "recurrences-get-object-count")
4642 {
4643   WITH_2_ARGS(table, obj);
4644   WITH_PSYC_UNBOXED(kt_recurrence_table,table, T_RECURRENCES, 0);
4645   int seen_count = recurrences_get_seen_count(pdata, obj, 0);
4646   return mk_integer(seen_count);
4647 }
4648 /*_    . init_recurrence_table */
4649 void
4650 init_recurrence_table(kt_recurrence_table * p_cycles_data, int initial_size)
4651 {
4652   p_cycles_data->objs   = initial_size ?
4653     GC_MALLOC(sizeof(pko) * initial_size) : 0;
4654   p_cycles_data->counts = initial_size ?
4655     GC_MALLOC(sizeof(int) * initial_size)     : 0;
4656   p_cycles_data->alloced_size = initial_size;
4657   p_cycles_data->table_size = 0;
4658 }
4659 /*_    . trace_tree_cycles */
4660 static void
4661 trace_tree_cycles
4662 (pko tree, kt_recurrence_table * p_cycles_data)
4663 {
4664   /* Special case for the "empty container", not because it's just a
4665      key but because "exploring" it does nothing. */
4666   if (tree == K_NIL)
4667     { return; }
4668   /* Maybe skip this object entirely */
4669   /* $$IMPROVE ME Parameterize this */
4670   switch(_get_type(tree))
4671     {
4672     case T_SYMBOL:
4673     case T_NUMBER:
4674       return;
4675     default:
4676       break;
4677     }
4678   if(recurrences_get_seen_count(p_cycles_data,tree, 1) != 0)
4679     { return; }
4680
4681   /* Switch on tree type */
4682   switch(_get_type(tree))
4683     {
4684     case T_PAIR:
4685       {
4686 #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data)
4687         EXPLORE_v2(tree);
4688 #undef _EXPLORE_FUNC
4689         break;
4690       }
4691     default:
4692       break;
4693       /* Done this exploration */
4694     }
4695   return;
4696 }
4697
4698 /*_    . get_recurrences */
4699 SIG_CHKARRAY(get_recurrences) = { K_ANY, };
4700 DEF_SIMPLE_APPLICATIVE (ps0a1, get_recurrences,T_NO_K,ground, "get-recurrences")
4701 {
4702   WITH_1_ARGS(tree);
4703   /* No reason to even start exploring non-containers */
4704   /* $$IMPROVE ME  Allow containers other than pairs */
4705   int explore_p = (_get_type(tree) == T_PAIR);
4706   ALLOC_BOX_PRESUME(kt_recurrence_table, T_RECURRENCES);
4707   init_recurrence_table(pdata, explore_p ? 8 : 0);
4708   if(explore_p)
4709     { trace_tree_cycles(tree,pdata); }
4710   return PTR2PKO(pbox);
4711 }
4712
4713 /*_  . Reading */
4714
4715 /*_   , Making result objects */
4716
4717 /* make symbol or number atom from string */
4718 static pko
4719 mk_atom (klink * sc, char *q)
4720 {
4721   char c, *p;
4722   int has_dec_point = 0;
4723   int has_fp_exp = 0;
4724
4725 #if USE_COLON_HOOK
4726   if ((p = strstr (q, "::")) != 0)
4727     {
4728       *p = 0;
4729       return mcons (sc->COLON_HOOK,
4730                    mcons (mcons (sc->QUOTE,
4731                                mcons (mk_atom (sc, p + 2), K_NIL)),
4732                          mcons (mk_symbol (strlwr (q)), K_NIL)));
4733     }
4734 #endif
4735
4736   p = q;
4737   c = *p++;
4738   if ((c == '+') || (c == '-'))
4739     {
4740       c = *p++;
4741       if (c == '.')
4742         {
4743           has_dec_point = 1;
4744           c = *p++;
4745         }
4746       if (!isdigit (c))
4747         {
4748           return (mk_symbol (strlwr (q)));
4749         }
4750     }
4751   else if (c == '.')
4752     {
4753       has_dec_point = 1;
4754       c = *p++;
4755       if (!isdigit (c))
4756         {
4757           return (mk_symbol (strlwr (q)));
4758         }
4759     }
4760   else if (!isdigit (c))
4761     {
4762       return (mk_symbol (strlwr (q)));
4763     }
4764
4765   for (; (c = *p) != 0; ++p)
4766     {
4767       if (!isdigit (c))
4768         {
4769           if (c == '.')
4770             {
4771               if (!has_dec_point)
4772                 {
4773                   has_dec_point = 1;
4774                   continue;
4775                 }
4776             }
4777           else if ((c == 'e') || (c == 'E'))
4778             {
4779               if (!has_fp_exp)
4780                 {
4781                   has_dec_point = 1;    /* decimal point illegal
4782                                            from now on */
4783                   p++;
4784                   if ((*p == '-') || (*p == '+') || isdigit (*p))
4785                     {
4786                       continue;
4787                     }
4788                 }
4789             }
4790           return (mk_symbol (strlwr (q)));
4791         }
4792     }
4793   if (has_dec_point)
4794     {
4795       return mk_real (atof (q));
4796     }
4797   return (mk_integer (atol (q)));
4798 }
4799
4800 /* make constant */
4801 static pko
4802 mk_sharp_const (char *name)
4803 {
4804   long x;
4805   char tmp[STRBUFFSIZE];
4806
4807   if (!strcmp (name, "t"))
4808     return (K_T);
4809   else if (!strcmp (name, "f"))
4810     return (K_F);
4811   else if (!strcmp (name, "ignore"))
4812     return (K_IGNORE);
4813   else if (!strcmp (name, "inert"))
4814     return (K_INERT);
4815   else if (*name == 'o')
4816     {                           /* #o (octal) */
4817       snprintf (tmp, STRBUFFSIZE, "0%s", name + 1);
4818       sscanf (tmp, "%lo", &x);
4819       return (mk_integer (x));
4820     }
4821   else if (*name == 'd')
4822     {                           /* #d (decimal) */
4823       sscanf (name + 1, "%ld", &x);
4824       return (mk_integer (x));
4825     }
4826   else if (*name == 'x')
4827     {                           /* #x (hex) */
4828       snprintf (tmp, STRBUFFSIZE, "0x%s", name + 1);
4829       sscanf (tmp, "%lx", &x);
4830       return (mk_integer (x));
4831     }
4832   else if (*name == 'b')
4833     {                           /* #b (binary) */
4834       x = binary_decode (name + 1);
4835       return (mk_integer (x));
4836     }
4837   else if (*name == '\\')
4838     {                           /* #\w (character) */
4839       int c = 0;
4840       if (stricmp (name + 1, "space") == 0)
4841         {
4842           c = ' ';
4843         }
4844       else if (stricmp (name + 1, "newline") == 0)
4845         {
4846           c = '\n';
4847         }
4848       else if (stricmp (name + 1, "return") == 0)
4849         {
4850           c = '\r';
4851         }
4852       else if (stricmp (name + 1, "tab") == 0)
4853         {
4854           c = '\t';
4855         }
4856       else if (name[1] == 'x' && name[2] != 0)
4857         {
4858           int c1 = 0;
4859           if (sscanf (name + 2, "%x", &c1) == 1 && c1 < UCHAR_MAX)
4860             {
4861               c = c1;
4862             }
4863           else
4864             {
4865               return K_NIL;
4866             }
4867 #if USE_ASCII_NAMES
4868         }
4869       else if (is_ascii_name (name + 1, &c))
4870         {
4871           /* nothing */
4872 #endif
4873         }
4874       else if (name[2] == 0)
4875         {
4876           c = name[1];
4877         }
4878       else
4879         {
4880           return K_NIL;
4881         }
4882       return mk_character (c);
4883     }
4884   else
4885     return (K_NIL);
4886 }
4887
4888 /*_   , Reading strings */
4889 /* read characters up to delimiter, but cater to character constants */
4890 static char *
4891 readstr_upto (klink * sc, char *delim)
4892 {
4893   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4894
4895   char *p = sc->strbuff;
4896
4897   while ((p - sc->strbuff < sizeof (sc->strbuff)) &&
4898          !is_one_of (delim, (*p++ = inchar (pt))));
4899
4900   if (p == sc->strbuff + 2 && p[-2] == '\\')
4901     {
4902       *p = 0;
4903     }
4904   else
4905     {
4906       backchar (pt, p[-1]);
4907       *--p = '\0';
4908     }
4909   return sc->strbuff;
4910 }
4911
4912 /* skip white characters */
4913 static INLINE int
4914 skipspace (klink * sc)
4915 {
4916   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4917   int c = 0;
4918
4919   do
4920     { c = inchar (pt); }
4921   while (isspace (c));
4922   if (c != EOF)
4923     {
4924       backchar (pt, c);
4925       return 1;
4926     }
4927   else
4928     { return EOF; }
4929 }
4930
4931 /*_   , Utilities */
4932 /* check c is in chars */
4933 static INLINE int
4934 is_one_of (char *s, int c)
4935 {
4936   if (c == EOF)
4937     return 1;
4938   while (*s)
4939     if (*s++ == c)
4940       return (1);
4941   return (0);
4942 }
4943
4944 /*_   , Reading expressions */
4945 /* read string expression "xxx...xxx" */
4946 static pko
4947 readstrexp (klink * sc)
4948 {
4949   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
4950   char *p = sc->strbuff;
4951   int c;
4952   int c1 = 0;
4953   enum
4954   { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
4955
4956   for (;;)
4957     {
4958       c = inchar (pt);
4959       if (c == EOF || p - sc->strbuff > sizeof (sc->strbuff) - 1)
4960         {
4961           return K_F;
4962         }
4963       switch (state)
4964         {
4965         case st_ok:
4966           switch (c)
4967             {
4968             case '\\':
4969               state = st_bsl;
4970               break;
4971             case '"':
4972               *p = 0;
4973               return mk_counted_string (sc->strbuff, p - sc->strbuff);
4974             default:
4975               *p++ = c;
4976               break;
4977             }
4978           break;
4979         case st_bsl:
4980           switch (c)
4981             {
4982             case '0':
4983             case '1':
4984             case '2':
4985             case '3':
4986             case '4':
4987             case '5':
4988             case '6':
4989             case '7':
4990               state = st_oct1;
4991               c1 = c - '0';
4992               break;
4993             case 'x':
4994             case 'X':
4995               state = st_x1;
4996               c1 = 0;
4997               break;
4998             case 'n':
4999               *p++ = '\n';
5000               state = st_ok;
5001               break;
5002             case 't':
5003               *p++ = '\t';
5004               state = st_ok;
5005               break;
5006             case 'r':
5007               *p++ = '\r';
5008               state = st_ok;
5009               break;
5010             case '"':
5011               *p++ = '"';
5012               state = st_ok;
5013               break;
5014             default:
5015               *p++ = c;
5016               state = st_ok;
5017               break;
5018             }
5019           break;
5020         case st_x1:
5021         case st_x2:
5022           c = toupper (c);
5023           if (c >= '0' && c <= 'F')
5024             {
5025               if (c <= '9')
5026                 {
5027                   c1 = (c1 << 4) + c - '0';
5028                 }
5029               else
5030                 {
5031                   c1 = (c1 << 4) + c - 'A' + 10;
5032                 }
5033               if (state == st_x1)
5034                 {
5035                   state = st_x2;
5036                 }
5037               else
5038                 {
5039                   *p++ = c1;
5040                   state = st_ok;
5041                 }
5042             }
5043           else
5044             {
5045               return K_F;
5046             }
5047           break;
5048         case st_oct1:
5049         case st_oct2:
5050           if (c < '0' || c > '7')
5051             {
5052               *p++ = c1;
5053               backchar (pt, c);
5054               state = st_ok;
5055             }
5056           else
5057             {
5058               if (state == st_oct2 && c1 >= 32)
5059                 return K_F;
5060
5061               c1 = (c1 << 3) + (c - '0');
5062
5063               if (state == st_oct1)
5064                 state = st_oct2;
5065               else
5066                 {
5067                   *p++ = c1;
5068                   state = st_ok;
5069                 }
5070             }
5071           break;
5072
5073         }
5074     }
5075 }
5076
5077
5078 /* get token */
5079 static int
5080 token (klink * sc)
5081 {
5082   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5083   int c;
5084   c = skipspace (sc);
5085   if (c == EOF)
5086     {
5087       return (TOK_EOF);
5088     }
5089   switch (c = inchar (pt))
5090     {
5091     case EOF:
5092       return (TOK_EOF);
5093     case '(':
5094       return (TOK_LPAREN);
5095     case ')':
5096       return (TOK_RPAREN);
5097     case '.':
5098       c = inchar (pt);
5099       if (is_one_of (" \n\t", c))
5100         {
5101           return (TOK_DOT);
5102         }
5103       else
5104         {
5105           backchar (pt, c);
5106           backchar (pt, '.');
5107           return TOK_ATOM;
5108         }
5109     case '\'':
5110       return (TOK_QUOTE);
5111     case ';':
5112       while ((c = inchar (pt)) != '\n' && c != EOF)
5113         {}
5114
5115       if (c == EOF)
5116         {
5117           return (TOK_EOF);
5118         }
5119       else
5120         {
5121           return (token (sc));
5122         }
5123     case '"':
5124       return (TOK_DQUOTE);
5125     case '`':
5126       return (TOK_BQUOTE);
5127     case ',':
5128       if ((c = inchar (pt)) == '@')
5129         {
5130           return (TOK_ATMARK);
5131         }
5132       else
5133         {
5134           backchar (pt, c);
5135           return (TOK_COMMA);
5136         }
5137     case '#':
5138       c = inchar (pt);
5139       if (c == '(')
5140         {
5141           return (TOK_VEC);
5142         }
5143       else if (c == '!')
5144         {
5145           while ((c = inchar (pt)) != '\n' && c != EOF)
5146             {}
5147
5148           if (c == EOF)
5149             {
5150               return (TOK_EOF);
5151             }
5152           else
5153             {
5154               return (token (sc));
5155             }
5156         }
5157       else
5158         {
5159           backchar (pt, c);
5160           /* $$UNHACKIFY ME!  This is a horrible hack. */
5161           if (is_one_of (" itfodxb\\", c))
5162             {
5163               return TOK_SHARP_CONST;
5164             }
5165           else
5166             {
5167               return (TOK_SHARP);
5168             }
5169         }
5170     default:
5171       backchar (pt, c);
5172       return (TOK_ATOM);
5173     }
5174 }
5175 /*_   , Nesting check */
5176 /*_    . create_nesting_check */
5177 void create_nesting_check(klink * sc)
5178 { klink_push_dyn_binding(sc,K_NEST_DEPTH,mk_integer(0)); }
5179 /*_    . nest_depth_ok_p */
5180 int nest_depth_ok_p(klink * sc)
5181 {
5182   pko nesting =
5183     klink_find_dyn_binding(sc,K_NEST_DEPTH);
5184   if(!nesting)
5185     { return 1; }
5186   return ivalue(nesting) == 0;
5187 }
5188 /*_    . change_nesting_depth */
5189 void change_nesting_depth(klink * sc, signed int change)
5190 {
5191   pko nesting =
5192     klink_find_dyn_binding(sc,K_NEST_DEPTH);
5193   add_to_ivalue(nesting,change);
5194 }
5195 /*_   , C-style entry points */
5196
5197 /*_    . kernel_read_internal */
5198 /* The only reason that this is separate from kernel_read_sexp is that
5199    it gets a token, which kernel_read_sexp does almost always, except
5200    once when a caller tricks it with TOK_LPAREN, and once when
5201    kernel_read_list effectively puts back a token it didn't decode.  */
5202 static
5203 DEF_APPLICATIVE_W_DESTR (ps0a0, kernel_read_internal, K_NO_TYPE,0,ground, "read")
5204 {
5205   token_t tok = token (sc);
5206   if (tok == TOK_EOF)
5207     {
5208       return K_EOF;
5209     }
5210   sc->tok = tok;
5211   create_nesting_check(sc);
5212   return kernel_read_sexp (sc);
5213 }
5214
5215 /*_    . kernel_read_sexp */
5216 DEF_CFUNC (ps0a0, kernel_read_sexp, K_NO_TYPE,0)
5217 {
5218   switch (sc->tok)
5219     {
5220     case TOK_EOF:
5221       return K_EOF;
5222       /* NOTREACHED */
5223     case TOK_VEC:
5224       CONTIN_0 (vector, sc);
5225
5226       /* fall through */
5227     case TOK_LPAREN:
5228       sc->tok = token (sc);
5229       if (sc->tok == TOK_RPAREN)
5230         {
5231           return K_NIL;
5232         }
5233       else if (sc->tok == TOK_DOT)
5234         {
5235           KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5236         }
5237       else
5238         {
5239           change_nesting_depth(sc, 1);
5240           CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, K_NIL);
5241           CONTIN_0 (kernel_read_sexp, sc);
5242           return K_INERT;
5243         }
5244     case TOK_QUOTE:
5245       {
5246         pko pquote = REF_OPER(arg1);
5247         CONTIN_1 (dcrry_2A01VLL, val2val, sc, pquote);
5248       }
5249       sc->tok = token (sc);
5250       CONTIN_0 (kernel_read_sexp, sc);
5251       return K_INERT;
5252
5253     case TOK_BQUOTE:
5254       sc->tok = token (sc);
5255       if (sc->tok == TOK_VEC)
5256         {
5257           /* $$CLEAN ME Do this more cleanly than by changing tokens
5258              to trick it.  Maybe factor the TOK_LPAREN treatment so we
5259              can schedule it. */
5260           klink_push_cont (sc, REF_OPER (kernel_treat_qquoted_vec));
5261           sc->tok = TOK_LPAREN;
5262           /* $$CLEANUP Seems like this could be combined with the part
5263              afterwards */
5264           CONTIN_0 (kernel_read_sexp, sc);
5265           return K_INERT;
5266         }
5267       else
5268         {
5269           /* Punt for now: Give quoted symbols rather than actual
5270              operators. ,Similarly sc->UNQUOTE, sc->UNQUOTESP */
5271           CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->QQUOTE);
5272         }
5273
5274       CONTIN_0 (kernel_read_sexp, sc);
5275       return K_INERT;
5276
5277     case TOK_COMMA:
5278       CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTE);
5279       sc->tok = token (sc);
5280       CONTIN_0 (kernel_read_sexp, sc);
5281       return K_INERT;
5282     case TOK_ATMARK:
5283       CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTESP);
5284       sc->tok = token (sc);
5285       CONTIN_0 (kernel_read_sexp, sc);
5286       return K_INERT;
5287     case TOK_ATOM:
5288       return mk_atom (sc, readstr_upto (sc, "();\t\n\r "));
5289     case TOK_DQUOTE:
5290       {
5291         pko x = readstrexp (sc);
5292         if (x == K_F)
5293           {
5294             KERNEL_ERROR_0 (sc, "Error reading string");
5295           }
5296         setimmutable (x);
5297         return x;
5298       }
5299     case TOK_SHARP:
5300       {
5301         pko sharp_hook = sc->SHARP_HOOK;
5302         pko f =
5303           is_symbol(sharp_hook)
5304           ? find_slot_in_env (sc->envir, sharp_hook, 1)
5305           : K_NIL;
5306         if (f == 0)
5307           {
5308             KERNEL_ERROR_0 (sc, "undefined sharp expression");
5309           }
5310         else
5311           {
5312             pko form = mcons (slot_value_in_env (f), K_NIL);
5313             return kernel_eval (sc, form, sc->envir);
5314           }
5315       }
5316     case TOK_SHARP_CONST:
5317       {
5318         pko x = mk_sharp_const (readstr_upto (sc, "();\t\n\r "));
5319         if (x == K_NIL)
5320           {
5321             KERNEL_ERROR_0 (sc, "undefined sharp expression");
5322           }
5323         else
5324           {
5325             return x;
5326           }
5327       }
5328     default:
5329       KERNEL_ERROR_0 (sc, "syntax error: illegal token");
5330     }
5331 }
5332
5333 /*_    . Read list */
5334 /* $$IMPROVE ME  Use currying ops instead of accumulating by hand */
5335 SIG_CHKARRAY(kernel_read_list) = { REF_OPER(is_finite_list),  K_ANY, };
5336 DEF_SIMPLE_CFUNC (ps0a2, kernel_read_list,0)
5337 {
5338   WITH_2_ARGS (old_accum,value);
5339   pko accum = mcons (value, old_accum);
5340   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5341   sc->tok = token (sc);
5342   if (sc->tok == TOK_EOF)
5343     {
5344       return (K_EOF);
5345     }
5346   else if (sc->tok == TOK_RPAREN)
5347     {
5348       /* $$RECONSIDER ME Why is this done?  To accept CR from user? */
5349       int c = inchar (pt);
5350       if (c != '\n')
5351         {
5352           backchar (pt, c);
5353         }
5354       change_nesting_depth(sc, -1);
5355       return (unsafe_v2reverse_in_place (K_NIL, accum));
5356     }
5357   else if (sc->tok == TOK_DOT)
5358     {
5359       CONTIN_1 (dcrry_2A01VLL, kernel_treat_dotted_list, sc, accum);
5360       sc->tok = token (sc);
5361       CONTIN_0 (kernel_read_sexp, sc);
5362       return K_INERT;
5363     }
5364   else
5365     {
5366       CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, accum);
5367       CONTIN_0 (kernel_read_sexp, sc);
5368       return K_INERT;
5369     }
5370 }
5371
5372 /*_    . Treat end of dotted list */
5373 static
5374 DEF_CFUNC (ps0a2, kernel_treat_dotted_list, REF_DESTR(kernel_read_list),T_NO_K)
5375 {
5376   WITH_2_ARGS(args,value);
5377
5378   if (token (sc) != TOK_RPAREN)
5379     {
5380       KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5381     }
5382   else
5383     {
5384       change_nesting_depth(sc, -1);
5385       return (unsafe_v2reverse_in_place (value, args));
5386     }
5387 }
5388
5389 /*_    . Treat quasiquoted vector */
5390 static
5391 DEF_CFUNC (ps0a1, kernel_treat_qquoted_vec, K_ANY,T_NO_K)
5392 {
5393   pko value = arg1;
5394   /* $$IMPROVE ME Include vector applicative directly, not by applying
5395      symbol.  This does need to apply, though, so that backquote (now
5396      seeing a list) can be run on "value" first*/
5397   return (mcons (mk_symbol ("apply"),
5398                 mcons (mk_symbol ("vector"),
5399                       mcons (mcons (sc->QQUOTE, mcons (value, K_NIL)),
5400                             K_NIL))));
5401 }
5402 /*_   , Loading files */
5403 /*_    . load_from_port */
5404 /* $$RETHINK ME  This soon need no longer be a cfunc */
5405 SIG_CHKARRAY(load_from_port) = { REF_OPER(is_inport), REF_OPER(is_environment)};
5406 DEF_SIMPLE_CFUNC(ps0a2,load_from_port,0)
5407 {
5408   WITH_2_ARGS(inport,env);
5409   assert (is_port(inport));
5410   assert (is_environment(env));
5411   /* Print that we're loading (If there's an outport, and we may want
5412      to add a verbosity condition based on a dynamic variable) */
5413   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5414   if(the_outport && (the_outport != K_NIL))
5415     {
5416       port * pt = portvalue(inport);
5417       if(pt->kind & port_file)
5418         {
5419           const char *fname = pt->rep.stdio.filename;
5420           if (!fname)
5421             { fname = "<unknown>"; }
5422           putstr(sc,"Loading ");
5423           putstr(sc,fname);
5424           putstr(sc,"\n");
5425         }
5426     }
5427
5428   /* We will do the evals in ENV */
5429   sc->envir = env;
5430   klink_push_dyn_binding(sc,K_INPORT,inport);
5431   return kernel_rel(sc);
5432 }
5433 /*_    . load */
5434 /* $$OBSOLETE */
5435 SIG_CHKARRAY(k_load_file) = { REF_OPER(is_string), };
5436 DEF_SIMPLE_APPLICATIVE(ps0a1,k_load_file,0,ground, "load")
5437 {
5438   WITH_1_ARGS(filename_ob);
5439   const char * filename = string_value(filename_ob);
5440   pko p = port_from_filename (filename, port_file | port_input);
5441   if (p == K_NIL)
5442     {
5443       KERNEL_ERROR_1(sc,"unable to open", filename_ob);
5444     }
5445
5446   return load_from_port(sc,p,sc->envir);
5447 }
5448 /*_    . get-module-from-port */
5449 SIG_CHKARRAY(k_get_mod_fm_port) =
5450   { REF_OPER(is_port), REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5451 DEF_SIMPLE_APPLICATIVE(ps0a2,k_get_mod_fm_port,0,ground, "get-module-from-port")
5452 {
5453   WITH_2_ARGS(port, params);
5454   pko env = mk_std_environment();
5455   if(params != K_INERT)
5456     {
5457       assert(is_environment(params));
5458       kernel_define (env, mk_symbol ("module-parameters"), params);
5459     }
5460   /* Ultimately return that environment. */
5461   CONTIN_1R(dcrry_NdotALL,val2val,sc,env);
5462   return load_from_port(sc, port,env);
5463 }
5464
5465 /*_  . Printing */
5466 /*_   , Writing chars */
5467 INTERFACE void
5468 putstr (klink * sc, const char *s)
5469 {
5470   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5471   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5472
5473   if (pt->kind & port_file)
5474     {
5475       fputs (s, pt->rep.stdio.file);
5476     }
5477   else
5478     {
5479       for (; *s; s++)
5480         {
5481           if (pt->rep.string.curr != pt->rep.string.past_the_end)
5482             {
5483               *pt->rep.string.curr++ = *s;
5484             }
5485           else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5486             {
5487               *pt->rep.string.curr++ = *s;
5488             }
5489         }
5490     }
5491 }
5492
5493 static void
5494 putchars (klink * sc, const char *s, int len)
5495 {
5496   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5497   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5498
5499   if (pt->kind & port_file)
5500     {
5501       fwrite (s, 1, len, pt->rep.stdio.file);
5502     }
5503   else
5504     {
5505       for (; len; len--)
5506         {
5507           if (pt->rep.string.curr != pt->rep.string.past_the_end)
5508             {
5509               *pt->rep.string.curr++ = *s++;
5510             }
5511           else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5512             {
5513               *pt->rep.string.curr++ = *s++;
5514             }
5515         }
5516     }
5517 }
5518
5519 INTERFACE void
5520 putcharacter (klink * sc, int c)
5521 {
5522   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5523   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5524
5525   if (pt->kind & port_file)
5526     {
5527       fputc (c, pt->rep.stdio.file);
5528     }
5529   else
5530     {
5531       if (pt->rep.string.curr != pt->rep.string.past_the_end)
5532         {
5533           *pt->rep.string.curr++ = c;
5534         }
5535       else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5536         {
5537           *pt->rep.string.curr++ = c;
5538         }
5539     }
5540 }
5541
5542 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == K_NIL)
5543
5544 static void
5545 printslashstring (klink * sc, char *p, int len)
5546 {
5547   int i;
5548   unsigned char *s = (unsigned char *) p;
5549   putcharacter (sc, '"');
5550   for (i = 0; i < len; i++)
5551     {
5552       if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\')
5553         {
5554           putcharacter (sc, '\\');
5555           switch (*s)
5556             {
5557             case '"':
5558               putcharacter (sc, '"');
5559               break;
5560             case '\n':
5561               putcharacter (sc, 'n');
5562               break;
5563             case '\t':
5564               putcharacter (sc, 't');
5565               break;
5566             case '\r':
5567               putcharacter (sc, 'r');
5568               break;
5569             case '\\':
5570               putcharacter (sc, '\\');
5571               break;
5572             default:
5573               {
5574                 int d = *s / 16;
5575                 putcharacter (sc, 'x');
5576                 if (d < 10)
5577                   {
5578                     putcharacter (sc, d + '0');
5579                   }
5580                 else
5581                   {
5582                     putcharacter (sc, d - 10 + 'A');
5583                   }
5584                 d = *s % 16;
5585                 if (d < 10)
5586                   {
5587                     putcharacter (sc, d + '0');
5588                   }
5589                 else
5590                   {
5591                     putcharacter (sc, d - 10 + 'A');
5592                   }
5593               }
5594             }
5595         }
5596       else
5597         {
5598           putcharacter (sc, *s);
5599         }
5600       s++;
5601     }
5602   putcharacter (sc, '"');
5603 }
5604
5605 /*_   , Printing atoms */
5606 static void
5607 printatom (klink * sc, pko l)
5608 {
5609   char *p;
5610   int len;
5611   atom2str (sc, l, &p, &len);
5612   putchars (sc, p, len);
5613 }
5614
5615
5616 /* Uses internal buffer unless string pointer is already available */
5617 static void
5618 atom2str (klink * sc, pko l, char **pp, int *plen)
5619 {
5620   WITH_REPORTER(sc);
5621   char *p;
5622   pko p_escapes = klink_find_dyn_binding(sc,K_PRINT_FLAG);
5623   int escapes = (p_escapes == K_T) ? 1 : 0;
5624
5625   if (l == K_NIL)
5626     {
5627       p = "()";
5628     }
5629   else if (l == K_T)
5630     {
5631       p = "#t";
5632     }
5633   else if (l == K_F)
5634     {
5635       p = "#f";
5636     }
5637   else if (l == K_INERT)
5638     {
5639       p = "#inert";
5640     }
5641   else if (l == K_IGNORE)
5642     {
5643       p = "#ignore";
5644     }
5645   else if (l == K_EOF)
5646     {
5647       p = "#<EOF>";
5648     }
5649   else if (is_port (l))
5650     {
5651       p = sc->strbuff;
5652       snprintf (p, STRBUFFSIZE, "#<PORT>");
5653     }
5654   else if (is_number (l))
5655     {
5656       p = sc->strbuff;
5657       if (num_is_integer (l))
5658         {
5659           snprintf (p, STRBUFFSIZE, "%ld", ivalue (l));
5660         }
5661       else
5662         {
5663           snprintf (p, STRBUFFSIZE, "%.10g", rvalue (l));
5664         }
5665     }
5666   else if (is_string (l))
5667     {
5668       if (!escapes)
5669         {
5670           p = string_value (l);
5671         }
5672       else
5673         {                       /* Hack, uses the fact that printing is needed */
5674           *pp = sc->strbuff;
5675           *plen = 0;
5676           printslashstring (sc, string_value (l), string_len (l));
5677           return;
5678         }
5679     }
5680   else if (is_character (l))
5681     {
5682       int c = charvalue (l);
5683       p = sc->strbuff;
5684       if (!escapes)
5685         {
5686           p[0] = c;
5687           p[1] = 0;
5688         }
5689       else
5690         {
5691           switch (c)
5692             {
5693             case ' ':
5694               snprintf (p, STRBUFFSIZE, "#\\space");
5695               break;
5696             case '\n':
5697               snprintf (p, STRBUFFSIZE, "#\\newline");
5698               break;
5699             case '\r':
5700               snprintf (p, STRBUFFSIZE, "#\\return");
5701               break;
5702             case '\t':
5703               snprintf (p, STRBUFFSIZE, "#\\tab");
5704               break;
5705             default:
5706 #if USE_ASCII_NAMES
5707               if (c == 127)
5708                 {
5709                   snprintf (p, STRBUFFSIZE, "#\\del");
5710                   break;
5711                 }
5712               else if (c < 32)
5713                 {
5714                   snprintf (p, STRBUFFSIZE, "#\\%s", charnames[c]);
5715                   break;
5716                 }
5717 #else
5718               if (c < 32)
5719                 {
5720                   snprintf (p, STRBUFFSIZE, "#\\x%x", c);
5721                   break;
5722                   break;
5723                 }
5724 #endif
5725               snprintf (p, STRBUFFSIZE, "#\\%c", c);
5726               break;
5727               break;
5728             }
5729         }
5730     }
5731   else if (is_symbol (l))
5732     {
5733       p = symname (sc,l);
5734     }
5735
5736
5737   else if (is_environment (l))
5738     {
5739       p = "#<ENVIRONMENT>";
5740     }
5741   else if (is_continuation (l))
5742     {
5743       p = "#<CONTINUATION>";
5744     }
5745   else if (is_operative (l)
5746            /* $$TRANSITIONAL  When these can be launched by
5747               themselves, this check will be folded into is_operative */
5748            || is_type (l, T_DESTRUCTURE)
5749            || is_type (l, T_TYPECHECK)
5750            || is_type (l, T_TYPEP))
5751     {
5752       /* $$TRANSITIONAL  This logic will move, probably into
5753          k_print_special_and_balk_p, and become more general. */
5754       pko slot =
5755         print_lookup_unwraps ?
5756         reverse_find_slot_in_env_aux(print_lookup_unwraps,l) :
5757         0;
5758       if(slot)
5759         {
5760           p = sc->strbuff;
5761           snprintf (p, STRBUFFSIZE, ",(unwrap #,%s)", symname(0, car(slot)));
5762         }
5763       else
5764         {
5765           pko slot =
5766             print_lookup_to_xary ?
5767             reverse_find_slot_in_env_aux(print_lookup_to_xary,l) :
5768             0;
5769           if(slot)
5770             {
5771               /* We don't say it's the tree-ary version, because the
5772                  tree-ary conversion is not exposed. */
5773               p = symname(0, car(slot));
5774             }
5775           else
5776             {
5777               pko slot =
5778                 all_builtins_env ?
5779                 reverse_find_slot_in_env_aux(all_builtins_env, l) :
5780                 0;
5781               if(slot)
5782                 {
5783                   p = symname(0, car(slot));
5784                 }
5785               else
5786                 { p = "#<OPERATIVE>"; }}
5787         }
5788     }
5789   else if (is_promise (l))
5790     {
5791       p = "#<PROMISE>";
5792     }
5793   else if (is_applicative (l))
5794     {
5795       p = "#<APPLICATIVE>";
5796     }
5797   else if (is_type (l, T_ENCAP))
5798     {
5799       p = "#<ENCAPSULATION>";
5800     }
5801   else if (is_type (l, T_KEY))
5802     {
5803       p = "#<KEY>";
5804     }
5805   else if (is_type (l, T_RECUR_TRACKER))
5806     {
5807       p = "#<RECURRENCE TRACKER>";
5808     }
5809   else if (is_type (l, T_RECURRENCES))
5810     {
5811       p = "#<RECURRENCE TABLE>";
5812     }
5813   else
5814     {
5815       p = sc->strbuff;
5816       snprintf (p, STRBUFFSIZE, "#<ERROR %d>", _get_type(l));
5817     }
5818   *pp = p;
5819   *plen = strlen (p);
5820 }
5821
5822 /*_   , C-style entry points */
5823 /*_    . Print sexp */
5824 /*_     , kernel_print_sexp */
5825 SIG_CHKARRAY(kernel_print_sexp) =
5826 { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5827 static
5828 DEF_SIMPLE_CFUNC (ps0a2, kernel_print_sexp,0)
5829 {
5830   WITH_2_ARGS(sexp, lookup_env);
5831   pko recurrences = get_recurrences(sc, sexp);
5832   pko tracker = recurrences_to_recur_tracker(recurrences);
5833   /* $$IMPROVE ME Default to an environment that knows sharp
5834      constants */
5835   return kernel_print_sexp_aux
5836     (sc, sexp,
5837      tracker,
5838      ((lookup_env == K_INERT) ? ground_env : lookup_env));
5839 }
5840 /*_     , k_print_special_and_balk_p */
5841 /* Possibly print a replacement or prefix.  Return 1 if we should now
5842    skip printing sexp (Because it's shared), 0 otherwise. */
5843 static int
5844 k_print_special_and_balk_p
5845 (klink * sc, pko tracker, pko lookup_env, pko sexp)
5846 {
5847   WITH_REPORTER(0);
5848   /* If this object is directly known to printer, print its symbol. */
5849   if(lookup_env != K_NIL)
5850     {
5851       pko slot = reverse_find_slot_in_env_aux(lookup_env,sexp);
5852       if(slot)
5853         {
5854           putstr (sc, "#,");    /* Reader is to convert the symbol */
5855           printatom (sc, car(slot));
5856           return 1;
5857         }
5858     }
5859   if(tracker == K_NIL)
5860     { return 0; }
5861
5862   /* $$IMPROVE ME Parameterize this and share that parameterization
5863      with get_recurrences */
5864   switch(_get_type(sexp))
5865     {
5866     case T_SYMBOL:
5867     case T_NUMBER:
5868       return 0;
5869     default:
5870       break;
5871     }
5872
5873   WITH_PSYC_UNBOXED(kt_recur_tracker,tracker, T_RECUR_TRACKER, sc);
5874   int index = objtable_get_index(pdata->objs,pdata->table_size,sexp);
5875   if(index < 0) { return 0; }
5876   recur_entry * slot = &pdata->entries[index];
5877   if(slot->count <= 1) { return 0; }
5878
5879   if(slot->seen_in_walk)
5880     {
5881       char *p = sc->strbuff;
5882       snprintf (p, STRBUFFSIZE, "#%d", slot->index_in_walk);
5883       putchars (sc, p, strlen (p));
5884       return 1;         /* Skip printing the object */
5885     }
5886   else
5887     {
5888       slot->seen_in_walk = 1;
5889       slot->index_in_walk = pdata->current_index;
5890       pdata->current_index++;
5891       char *p = sc->strbuff;
5892       snprintf (p, STRBUFFSIZE, "#%d=", slot->index_in_walk);
5893       putchars (sc, p, strlen (p));
5894       return 0;         /* Still should print the object */
5895     }
5896 }
5897 /*_     , kernel_print_sexp_aux */
5898 SIG_CHKARRAY(kernel_print_sexp_aux) =
5899 { K_ANY, REF_OPER(is_recur_tracker), REF_OPER(is_environment), };
5900 static
5901 DEF_SIMPLE_CFUNC (ps0a3, kernel_print_sexp_aux,0)
5902 {
5903   WITH_3_ARGS(sexp, recur_tracker, lookup_env);
5904   WITH_REPORTER(0);
5905   if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
5906     { return K_INERT; }
5907   if (is_vector (sexp))
5908     {
5909       putstr (sc, "#(");
5910       CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, sexp,
5911                 mk_integer (0), recur_tracker, lookup_env);
5912       return K_INERT;
5913     }
5914   else if (!is_pair (sexp))
5915     {
5916       printatom (sc, sexp);
5917       return K_INERT;
5918     }
5919   /* $$FIX ME Recognize quote etc.
5920
5921      That is hard since the quote operative is not currently defined
5922      as such and we no longer have syntax.
5923    */
5924   else if (car (sexp) == sc->QUOTE && ok_abbrev (cdr (sexp)))
5925     {
5926       putstr (sc, "'");
5927       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5928     }
5929   else if (car (sexp) == sc->QQUOTE && ok_abbrev (cdr (sexp)))
5930     {
5931       putstr (sc, "`");
5932       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5933     }
5934   else if (car (sexp) == sc->UNQUOTE && ok_abbrev (cdr (sexp)))
5935     {
5936       putstr (sc, ",");
5937       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5938     }
5939   else if (car (sexp) == sc->UNQUOTESP && ok_abbrev (cdr (sexp)))
5940     {
5941       putstr (sc, ",@");
5942       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
5943     }
5944   else
5945     {
5946       putstr (sc, "(");
5947       CONTIN_0_RAW(REF_OBJ(k_print_terminate_list), sc);
5948       CONTIN_3 (dcrry_2dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
5949       return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
5950     }
5951 }
5952 /*_     , print_value */
5953 DEF_BOXED_CURRIED(print_value,
5954                   dcrry_1VLL,
5955                   REF_KEY(K_NIL),
5956                   REF_OPER (kernel_print_sexp));
5957 /*_    . k_print_string */
5958 SIG_CHKARRAY(k_print_string) = { REF_OPER(is_string), };
5959 static
5960 DEF_SIMPLE_CFUNC (ps0a1, k_print_string,T_NO_K)
5961 {
5962   WITH_1_ARGS(str);
5963   putstr (sc, string_value(str));
5964   return K_INERT;
5965 }
5966 /*_    . k_print_terminate_list */
5967 /* $$RETHINK ME  This may be the long way to do it. */
5968 static
5969 BOX_OF(kt_string) _k_string_rpar =
5970 { T_STRING | T_IMMUTABLE,
5971   { ")", sizeof(")"), },
5972 };
5973 static
5974 BOX_OF(kt_vec2) _k_list_string_rpar =
5975 { T_PAIR | T_IMMUTABLE,
5976   { REF_OBJ(_k_string_rpar), REF_KEY(K_NIL)}
5977 };
5978 static
5979 DEF_BOXED_CURRIED(k_print_terminate_list,
5980                   dcrry_1dotALL,
5981                   REF_OBJ(_k_list_string_rpar),
5982                   REF_OPER(k_print_string));
5983 /*_    . k_newline */
5984 RGSTR(ground, "newline", REF_OBJ(k_newline))
5985 static
5986 BOX_OF(kt_string) _k_string_newline =
5987 { T_STRING | T_IMMUTABLE,
5988   { "\n", sizeof("\n"), }, };
5989 static
5990 BOX_OF(kt_vec2) _k_list_string_newline =
5991 { T_PAIR | T_IMMUTABLE,
5992   { REF_OBJ(_k_string_newline), REF_KEY(K_NIL)}
5993 };
5994 static
5995 DEF_BOXED_CURRIED(k_newline,
5996                   dcrry_1dotALL,
5997                   REF_OBJ(_k_list_string_newline),
5998                   REF_OPER(k_print_string));
5999
6000 /*_    .  kernel_print_list */
6001 static
6002 DEF_CFUNC (ps0a3, kernel_print_list, REF_DESTR(kernel_print_sexp_aux),0)
6003 {
6004   WITH_REPORTER(0);
6005   WITH_3_ARGS(sexp, recur_tracker, lookup_env);
6006   if(is_pair (sexp))  { putstr (sc, " "); }
6007   else if (sexp != K_NIL) { putstr (sc, " . "); }
6008   else { }
6009
6010   if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
6011     { return K_INERT; }
6012   if (is_pair (sexp))
6013     {
6014       CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
6015       return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
6016     }
6017   if (is_vector (sexp))
6018     {
6019       /* $$RETHINK ME What does this even print? */
6020       CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, K_NIL, recur_tracker, lookup_env);
6021       return kernel_print_sexp_aux (sc, sexp, recur_tracker, lookup_env);
6022     }
6023
6024   if (sexp != K_NIL)
6025     {
6026       printatom (sc, sexp);
6027     }
6028   return K_INERT;
6029 }
6030
6031
6032 /*_    .  kernel_print_vec_from */
6033 SIG_CHKARRAY(kernel_print_vec_from) =
6034 { K_ANY,
6035   REF_OPER(is_integer),
6036   REF_OPER(is_recur_tracker),
6037   REF_OPER(is_environment), };
6038 DEF_SIMPLE_CFUNC (ps0a4, kernel_print_vec_from,0)
6039 {
6040   WITH_4_ARGS(vec,k_i, recur_tracker, lookup_env);
6041   int i = ivalue (k_i);
6042   int len = vector_len (vec);
6043   if (i == len)
6044     {
6045       putstr (sc, ")");
6046       return K_INERT;
6047     }
6048   else
6049     {
6050       pko elem = vector_elem (vec, i);
6051       set_ivalue (k_i, i + 1);
6052       CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, vec, arg2, recur_tracker, lookup_env);
6053       putstr (sc, " ");
6054       return kernel_print_sexp_aux (sc, elem, recur_tracker, lookup_env);
6055     }
6056 }
6057 /*_   , Kernel entry points */
6058 /*_    . write */
6059 DEF_APPLICATIVE_W_DESTR(ps0a1,k_write,K_ANY_SINGLETON,0,ground, "write")
6060 {
6061   WITH_1_ARGS(p);
6062   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
6063   return kernel_print_sexp(sc,p,K_INERT);
6064 }
6065
6066 /*_    . display */
6067 DEF_APPLICATIVE_W_DESTR(ps0a1,k_display,K_ANY_SINGLETON,0,ground, "display")
6068 {
6069   WITH_1_ARGS(p);
6070   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_F);
6071   return kernel_print_sexp(sc,p,K_INERT);
6072 }
6073
6074 /*_   , Tracing */
6075 /*_    . tracing_say */
6076 /* $$TRANSITIONAL  Until we have actual trace hook */
6077 SIG_CHKARRAY(tracing_say) = { REF_OPER(is_string),  K_ANY, };
6078 DEF_SIMPLE_CFUNC (ps0a2, tracing_say,T_NO_K)
6079 {
6080   WITH_2_ARGS(k_string, value);
6081   if (sc->tracing)
6082     {
6083       putstr (sc, string_value(k_string));
6084     }
6085   return value;
6086 }
6087
6088
6089 /*_  . Equivalence */
6090 /*_   , Equivalence of atoms */
6091 SIG_CHKARRAY(eqv) = { K_ANY, K_ANY, };
6092 DEF_SIMPLE_APPLICATIVE(b00a2,eqv,T_NO_K,simple,"equal?/2-atom-atom")
6093 {
6094   WITH_2_ARGS(a,b);
6095
6096   if (is_string (a))
6097     {
6098       if (is_string (b))
6099         {
6100           const char * a_str = string_value (a);
6101           const char * b_str = string_value (b);
6102           if (a_str == b_str) { return 1; }
6103           return !strcmp(a_str, b_str);
6104         }
6105       else
6106         { return (0); }
6107     }
6108   else if (is_number (a))
6109     {
6110       if (is_number (b))
6111         {
6112           if (num_is_integer (a) == num_is_integer (b))
6113             return num_eq (nvalue (a), nvalue (b));
6114         }
6115       return (0);
6116     }
6117   else if (is_character (a))
6118     {
6119       if (is_character (b))
6120         return charvalue (a) == charvalue (b);
6121       else
6122         return (0);
6123     }
6124   else if (is_port (a))
6125     {
6126       if (is_port (b))
6127         return a == b;
6128       else
6129         return (0);
6130     }
6131   else
6132     {
6133       return (a == b);
6134     }
6135 }
6136 /*_   , Equivalence of containers */
6137
6138 /*_  . Hash function */
6139 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
6140
6141 static int
6142 hash_fn (const char *key, int table_size)
6143 {
6144   unsigned int hashed = 0;
6145   const char *c;
6146   int bits_per_int = sizeof (unsigned int) * 8;
6147
6148   for (c = key; *c; c++)
6149     {
6150       /* letters have about 5 bits in them */
6151       hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
6152       hashed ^= *c;
6153     }
6154   return hashed % table_size;
6155 }
6156 #endif
6157
6158 /* Quick and dirty hash function for pointers */
6159 static int
6160 ptr_hash_fn(void * ptr, int table_size)
6161 { return (long)ptr % table_size; }
6162
6163 /*_  . binder/accessor maker */
6164 pko make_keyed_variable(pko gen_binder, pko gen_accessor)
6165 {
6166   /* Make a unique key object */
6167   pko key = mk_void();
6168   pko binder = wrap (mk_curried
6169                          (dcrry_3A01dotVLL,
6170                           LIST1(key),
6171                           gen_binder));
6172   pko accessor = wrap (mk_curried
6173                            (dcrry_1A01,
6174                             LIST1(key),
6175                             gen_accessor));
6176   /* Curry and wrap the two things. */
6177   return LIST2 (binder, accessor);
6178 }
6179
6180 /*_  . Environment implementation */
6181 /*_   , New-style environment objects */
6182
6183 /*_    . Types */
6184
6185 /*   T_ENV_FRAME is a vec2 used as a pair in the env tree.  It
6186      indicates a frame boundary.
6187 */
6188 /*   T_ENV_PAIR is another vec2 used as a pair in the env tree.  It
6189      indicates no frame boundary.
6190 */
6191
6192 /* Other types are (hackishly) still shared with the vanilla types:
6193
6194    A vector is interpeted as a hash table vector that is "as if" it
6195    were a list of T_ENV_PAIR.  Each element is an alist of bindings.
6196    It can only hold symbol bindings, not keyed bindings, because we
6197    can't hash keyed bindings.
6198
6199    A pair is interpreted as a binding of something and value.  That
6200    something can be either a symbol or a key (void object).  It is
6201    held directly by an T_ENV_FRAME or T_ENV_PAIR (or "as if", by the
6202    alists of a hash table vector).
6203
6204  */
6205
6206 /*_    . Object functions */
6207
6208 DEF_T_PRED (is_environment, T_ENV_FRAME,ground,"environment?/o1");
6209
6210 /*_   , New environment implementation */
6211
6212 #ifndef USE_ALIST_ENV
6213 static pko
6214 find_slot_in_env_vector (pko eobj, pko hdl)
6215 {
6216   for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
6217     {
6218       assert (is_pair (eobj));
6219       pko slot = unsafe_v2car (eobj);
6220       assert (is_pair (slot));
6221       if (unsafe_v2car (slot) == hdl)
6222         {
6223           return slot;
6224         }
6225     }
6226   return 0;
6227 }
6228
6229 static pko
6230 reverse_find_slot_in_env_vector (pko eobj, pko value)
6231 {
6232   for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
6233     {
6234       assert (is_pair (eobj));
6235       pko slot = unsafe_v2car (eobj);
6236       assert (is_pair (slot));
6237       if (unsafe_v2cdr (slot) == value)
6238         {
6239           return slot;
6240         }
6241     }
6242   return 0;
6243 }
6244 #endif
6245
6246 /*
6247  * If we're using vectors, each frame of the environment may be a hash
6248  * table: a vector of alists hashed by variable name.  In practice, we
6249  * use a vector only for the initial frame; subsequent frames are too
6250  * small and transient for the lookup speed to out-weigh the cost of
6251  * making a new vector.
6252  */
6253 static INLINE pko
6254 make_new_frame(pko old_env)
6255 {
6256   pko new_frame;
6257 #ifndef USE_ALIST_ENV
6258   /* $$IMPROVE ME  Make a better test for whether to make vector. */
6259   /* The interaction-environment has about 300 variables in it. */
6260   if (old_env == K_NIL)
6261     {
6262       new_frame = mk_vector (461, K_NIL);
6263     }
6264   else
6265 #endif
6266     {
6267       new_frame = K_NIL;
6268     }
6269
6270   return v2cons (T_ENV_FRAME, new_frame, old_env);
6271 }
6272
6273 static INLINE void
6274 new_slot_spec_in_env (pko env, pko variable, pko value)
6275 {
6276   assert(is_environment(env));
6277   assert(is_symbol(variable));
6278   pko slot = mcons (variable, value);
6279   pko car_env = unsafe_v2car (env);
6280 #ifndef USE_ALIST_ENV
6281   if (is_vector (car_env))
6282     {
6283       int location = hash_fn (symname (0,variable), vector_len (car_env));
6284
6285       set_vector_elem (car_env, location,
6286                        cons (slot,
6287                              vector_elem (car_env, location)));
6288     }
6289   else
6290 #endif
6291     {
6292       pko new_list = v2cons (T_ENV_PAIR, slot, car_env);
6293       unsafe_v2set_car (env, new_list);
6294     }
6295 }
6296
6297 enum env_frame_search_restriction
6298 {
6299   env_fsr_all,
6300   env_fsr_only_coming_frame,
6301   env_fsr_only_this_frame,
6302 };
6303
6304 /* This explores a tree of bindings, punctuated by frames past which
6305    we sometimes don't search. */
6306 static pko
6307 find_slot_in_env_aux (pko eobj, pko hdl, int restr)
6308 {
6309   if(eobj == K_NIL)
6310     { return 0; }
6311   _kt_tag type = _get_type (eobj);
6312   switch(type)
6313     {
6314       /* We have a slot (Which for now is just a pair) */
6315     case T_PAIR:
6316       if(unsafe_v2car (eobj) == hdl)
6317         { return eobj; }
6318       else
6319         { return 0; }
6320 #ifndef USE_ALIST_ENV
6321     case T_VECTOR:
6322       {
6323         /* Only for symbols. */
6324         if(!is_symbol (hdl)) { return 0; }
6325         int location = hash_fn (symname (0,hdl), vector_len (eobj));
6326         pko el = vector_elem (eobj, location);
6327         return find_slot_in_env_vector (el, hdl);
6328       }
6329 #endif
6330       /* We have some sort of env pair */
6331     case T_ENV_FRAME:
6332       /* Check whether we should keep looking. */
6333       switch(restr)
6334         {
6335         case env_fsr_all:
6336           break;
6337         case env_fsr_only_coming_frame:
6338           restr = env_fsr_only_this_frame;
6339           break;
6340         case env_fsr_only_this_frame:
6341           return 0;
6342         default:
6343           errx (3,
6344                "find_slot_in_env_aux: Bad restriction enum: %d", restr);
6345         }
6346       /* Fallthru */
6347     case T_ENV_PAIR:
6348       {
6349         /* Explore car before cdr */
6350         pko found = find_slot_in_env_aux (unsafe_v2car (eobj), hdl, restr);
6351         if(found) { return found; }
6352         return find_slot_in_env_aux (unsafe_v2cdr (eobj),hdl,restr);
6353       }
6354     default:
6355       /* No other type should be found */
6356       errx (3,
6357            "find_slot_in_env_aux: Bad type: %d", type);
6358       return 0;                 /* NOTREACHED */
6359     }
6360 }
6361
6362 static pko
6363 find_slot_in_env (pko env, pko hdl, int all)
6364 {
6365   assert(is_environment(env));
6366   enum env_frame_search_restriction restr =
6367     all ? env_fsr_all : env_fsr_only_coming_frame;
6368   return find_slot_in_env_aux(env,hdl,restr);
6369 }
6370 /*_   , Reverse find-slot */
6371 /*_    . env_confirm_slot */
6372 static int
6373 env_confirm_slot(pko env, pko slot)
6374 {
6375   assert(is_pair(slot));
6376   return
6377     (find_slot_in_env_aux(env,unsafe_v2car(slot),env_fsr_all) == slot);
6378 }
6379 /*_    . reverse_find_slot_in_env_aux2 */
6380 static pko
6381 reverse_find_slot_in_env_aux2(pko env, pko eobj, pko value)
6382 {
6383   if(eobj == K_NIL)
6384     { return 0; }
6385   _kt_tag type = _get_type (eobj);
6386   switch(type)
6387     {
6388       /* We have a slot (Which for now is just a pair) */
6389     case T_PAIR:
6390       if((unsafe_v2cdr (eobj) == value)
6391          && env_confirm_slot(env, eobj))
6392         { return eobj; }
6393       else
6394         { return 0; }
6395 #ifndef USE_ALIST_ENV
6396     case T_VECTOR:
6397       {
6398         /* $$IMPROVE ME Create a reverse-lookup vector if we come here
6399            and there is none.  */
6400         int i;
6401         for(i = 0; i < vector_len (eobj); ++i)
6402           {
6403             pko slot = reverse_find_slot_in_env_vector(vector_elem (eobj, i), value);
6404             if(slot &&
6405                env_confirm_slot(env, slot))
6406               { return slot; }
6407           }
6408         return 0;
6409       }
6410 #endif
6411       /* We have some sort of env pair */
6412     case T_ENV_FRAME:
6413       /* Fallthru */
6414     case T_ENV_PAIR:
6415       {
6416         /* Explore car before cdr */
6417         pko found =
6418           reverse_find_slot_in_env_aux2 (env, unsafe_v2car (eobj), value);
6419         if(found && env_confirm_slot(env, found))
6420           { return found; }
6421         found =
6422           reverse_find_slot_in_env_aux2 (env, unsafe_v2cdr (eobj), value);
6423         if(found && env_confirm_slot(env, found))
6424           { return found; }
6425         return 0;
6426       }
6427     default:
6428       /* No other type should be found */
6429       errx (3,
6430            "reverse_find_slot_in_env_aux2: Bad type: %d", type);
6431       return 0;                 /* NOTREACHED */
6432     }
6433 }
6434
6435 /*_    . reverse_find_slot_in_env_aux */
6436 static pko
6437 reverse_find_slot_in_env_aux (pko env, pko value)
6438 {
6439   assert(is_environment(env));
6440   return reverse_find_slot_in_env_aux2(env, env, value);
6441 }
6442
6443 /*_    . Entry point */
6444 /* Exposed for testing */
6445 /* NB, args are in different order than in the helpers */
6446 SIG_CHKARRAY(reverse_find_slot_in_env) =
6447 { K_ANY, REF_OPER(is_environment), };
6448 DEF_SIMPLE_APPLICATIVE (ps0a2, reverse_find_slot_in_env,T_NO_K,unsafe, "reverse-lookup")
6449 {
6450   WITH_2_ARGS(value,env);
6451   WITH_REPORTER(0);
6452   pko slot = reverse_find_slot_in_env_aux(env, value);
6453   if(slot) { return car(slot); }
6454   else
6455     {
6456       KERNEL_ERROR_0(sc, "reverse_find_slot_in_env: No match");
6457     }
6458 }
6459
6460 /*_    . reverse-binds?/2 */
6461 /* $$IMPROVE ME  Maybe combine these */
6462 DEF_APPLICATIVE_W_DESTR(b00a2,reverse_binds_p,
6463                         REF_DESTR(reverse_find_slot_in_env),
6464                         T_NO_K,simple,"reverse-binds?/2")
6465 {
6466   WITH_2_ARGS(value,env);
6467   return reverse_find_slot_in_env_aux(env, value) ? 1 : 0;
6468 }
6469 /*_   , Shared functions */
6470
6471 static INLINE void
6472 new_frame_in_env (klink * sc, pko old_env)
6473 {
6474   sc->envir = make_new_frame (old_env);
6475 }
6476
6477 static INLINE void
6478 set_slot_in_env (pko slot, pko value)
6479 {
6480   assert (is_pair (slot));
6481   set_cdr (0, slot, value);
6482 }
6483
6484 static INLINE pko
6485 slot_value_in_env (pko slot)
6486 {
6487   WITH_REPORTER(0);
6488   assert (is_pair (slot));
6489   return cdr (slot);
6490 }
6491
6492 /*_   , Keyed static bindings */
6493 /*_    . Support */
6494 /*_     , Making them */
6495 /* Make a new frame containing just the one keyed static variable. */
6496 static INLINE pko
6497 env_plus_keyed_var (pko key, pko value, pko old_env)
6498 {
6499   pko slot = cons (key, value);
6500   return v2cons (T_ENV_FRAME, slot, old_env);
6501 }
6502 /*_     , Finding them */
6503 /* find_slot_in_env works for this too. */
6504 /*_    . Interface */
6505 /*_     , Binder */
6506 SIG_CHKARRAY(klink_ksb_binder) =
6507 { REF_OPER(is_key),  K_ANY, REF_OPER(is_environment), };
6508 DEF_SIMPLE_CFUNC(ps0a3,klink_ksb_binder,T_NO_K)
6509 {
6510   WITH_3_ARGS(key, value, env);
6511   /* Check that env is in fact a environment. */
6512   if(!is_environment(env))
6513     {
6514       KERNEL_ERROR_1(sc,
6515                      "klink_ksb_binder: Arg 2 must be an environment: ",
6516                      env);
6517     }
6518   /* Return a new environment with just that binding. */
6519   return env_plus_keyed_var(key, value, env);
6520 }
6521
6522 /*_     , Accessor */
6523 SIG_CHKARRAY(klink_ksb_accessor) =
6524 { REF_OPER(is_key), };
6525 DEF_SIMPLE_CFUNC(ps0a1,klink_ksb_accessor,T_NO_K)
6526 {
6527   WITH_1_ARGS(key);
6528   pko value = find_slot_in_env(sc->envir,key,1);
6529   if(!value)
6530     {
6531       KERNEL_ERROR_0(sc, "klink_ksb_accessor: No binding found");
6532     }
6533
6534   return slot_value_in_env (value);
6535 }
6536
6537 /*_     , make_keyed_static_variable */
6538 RGSTR(ground, "make-keyed-static-variable", REF_OPER(make_keyed_static_variable))
6539 DEF_CFUNC(p00a0, make_keyed_static_variable,K_NO_TYPE,T_NO_K)
6540 {
6541   return make_keyed_variable(
6542                              REF_OPER(klink_ksb_binder),
6543                              REF_OPER (klink_ksb_accessor));
6544 }
6545 /*_   , Building environments */
6546 /* Argobject is checked internally, so K_ANY */
6547 DEF_APPLICATIVE_W_DESTR(ps0a1,make_environment,K_ANY,T_NO_K,ground, "make-environment")
6548 {
6549   WITH_1_ARGS(parents);
6550   /* $$IMPROVE ME Factor this so we only call get_list_metrics_aux
6551      once on this object. */
6552   int4 metrics;
6553   get_list_metrics_aux(parents, metrics);
6554   pko typecheck = REF_OPER(is_environment);
6555   /* This will reject dotted lists */
6556   if(!typecheck_repeat(sc,parents,&typecheck,1,1))
6557     {
6558       KERNEL_ERROR_0 (sc, "make_environment: argobject must be a list of environments");
6559     }
6560
6561   /* Collect the parent environments. */
6562   int i;
6563   pko rv_par_list = K_NIL;
6564   for(i = 0; i < metrics[lm_num_pairs]; ++i, parents = pair_cdr(0, parents))
6565     {
6566       pko pare = pair_car(0, parents);
6567       rv_par_list = v2cons (T_ENV_PAIR, pare, rv_par_list);
6568     }
6569
6570   /* Reverse the list in place. */
6571   pko par_list;
6572
6573   par_list = unsafe_v2reverse_in_place(K_NIL, rv_par_list);
6574
6575   /* $$IMPROVE ME Check for redundant environments and skip them.
6576      Check only *previous* environments, because we still need to
6577      search correctly.  When recurrences walks environments too, we
6578      can use that to find them. */
6579   /* $$IMPROVE ME Add to environment information to block rechecks. */
6580
6581   /* Return a new environment with all of those as parents. */
6582   return make_new_frame(par_list);
6583 }
6584 /*_   , bindsp_1 */
6585 RGSTR(simple,"$binds?/2", REF_OPER(bindsp_1))
6586 SIG_CHKARRAY(bindsp_1) =
6587 { REF_OPER(is_environment), REF_OPER(is_symbol), };
6588 DEF_SIMPLE_CFUNC(bs0a2,bindsp_1,T_NO_K)
6589 {
6590   WITH_2_ARGS(env, sym);
6591   return find_slot_in_env(env, sym, 1) ? 1 : 0;
6592 }
6593 /*_   , find-binding */
6594 DEF_APPLICATIVE_W_DESTR(ps0a2,find_binding,REF_DESTR(bindsp_1),T_NO_K,ground,"find-binding")
6595 {
6596   WITH_2_ARGS(env, sym);
6597   pko binding = find_slot_in_env(env, sym, 1);
6598   if(binding)
6599     {
6600       return cons(K_T,slot_value_in_env (binding));
6601     }
6602   else
6603     {
6604       return cons(K_F,K_INERT);
6605     }
6606 }
6607
6608 /*_  . Stack */
6609 /*_   , Enumerations */
6610 enum klink_stack_cell_types
6611 {
6612   ksct_invalid,
6613   ksct_frame,
6614   ksct_binding,
6615   ksct_entry_guards,
6616   ksct_exit_guards,
6617   ksct_profile,
6618   ksct_args,
6619   ksct_arg_barrier,             /* Barrier to propagating pseudo-env. */
6620 };
6621 /*_   , Structs */
6622
6623 struct dump_stack_frame
6624 {
6625   pko envir;
6626   pko ff;
6627 };
6628 struct stack_binding
6629 {
6630   pko key;
6631   pko value;
6632 };
6633
6634 struct stack_guards
6635 {
6636   pko guards;
6637   pko envir;
6638 };
6639
6640 struct stack_profiling
6641 {
6642   pko ff;
6643   int initial_count;
6644   int returned_p;
6645 };
6646
6647 struct stack_arg
6648 {
6649   pko vec;
6650   int frame_depth;
6651 };
6652
6653 typedef struct dump_stack_frame_cell
6654 {
6655   enum klink_stack_cell_types type;
6656   _kt_spagstack next;
6657   union
6658   {
6659     struct dump_stack_frame frame;
6660     struct stack_binding    binding;
6661     struct stack_guards     guards;
6662     struct stack_profiling  profiling;
6663     struct stack_arg        pseudoenv;
6664   } data;
6665 } dump_stack_frame_cell;
6666
6667 /*_   , Initialize */
6668
6669 static INLINE void
6670 dump_stack_initialize (klink * sc)
6671 {
6672   sc->dump = 0;
6673 }
6674
6675 static INLINE int
6676 stack_empty (klink * sc)
6677 { return sc->dump == 0; }
6678
6679 /*_   , Frames */
6680 static int
6681 klink_pop_cont (klink * sc)
6682 {
6683   _kt_spagstack rv_pseudoenvs = 0;
6684
6685   /* Always return frame, which sc->dump will be set to. */
6686   /* for(frame = sc->dump; frame != 0; frame = frame->next) */
6687   while(1)
6688     {
6689       if (sc->dump == 0)
6690         {
6691           return 0;
6692         }
6693       else
6694         {
6695           const _kt_spagstack frame = sc->dump;
6696           if(frame->type == ksct_frame)
6697             {
6698               const struct dump_stack_frame *pdata = &frame->data.frame;
6699               sc->next_func    = pdata->ff;
6700               sc->envir        = pdata->envir;
6701
6702               _kt_spagstack final_frame = frame->next;
6703
6704               /* Add the collected pseudo-env elements */
6705               while(rv_pseudoenvs)
6706                 {
6707                   _kt_spagstack el = rv_pseudoenvs;
6708                   _kt_spagstack new_top = rv_pseudoenvs->next;
6709                   el->next = final_frame;
6710                   final_frame = el;
6711                   rv_pseudoenvs = new_top;
6712                 }
6713               sc->dump = final_frame;
6714               return 1;
6715             }
6716 #ifdef PROFILING
6717           else
6718           if(frame->type == ksct_profile)
6719             {
6720               struct stack_profiling * pdata = &frame->data.profiling;
6721               k_profiling_done_frame(sc,pdata);
6722               sc->dump = frame->next;
6723             }
6724 #endif
6725           else if( frame->type == ksct_args )
6726             {
6727               struct stack_arg * old_pe = &frame->data.pseudoenv;
6728               if(old_pe->frame_depth > 0)
6729                 {
6730                   /* Make a copy, to be re-added lower down */
6731                   _kt_spagstack new_pseudoenv =
6732                     (_kt_spagstack)
6733                     GC_MALLOC (sizeof (dump_stack_frame_cell));
6734                   struct stack_arg * new_pe = &new_pseudoenv->data.pseudoenv;
6735                   new_pe->vec         = old_pe->vec;
6736                   new_pe->frame_depth = old_pe->frame_depth - 1;
6737
6738                   new_pseudoenv->type = ksct_args;
6739                   new_pseudoenv->next = rv_pseudoenvs;
6740                   rv_pseudoenvs = new_pseudoenv;
6741                 }
6742
6743               sc->dump = frame->next;
6744             }
6745           else if( frame->type == ksct_arg_barrier )
6746             {
6747               errx( 0, "Not allowed");
6748               rv_pseudoenvs = 0;
6749               sc->dump = frame->next;
6750             }
6751           else
6752             {
6753               sc->dump = frame->next;
6754             }
6755         }
6756     }
6757 }
6758
6759 static _kt_spagstack
6760 klink_push_cont_aux
6761 (_kt_spagstack old_frame, pko ff, pko env)
6762 {
6763   _kt_spagstack frame =
6764     (_kt_spagstack)
6765     GC_MALLOC (sizeof (dump_stack_frame_cell));
6766   struct dump_stack_frame * pdata = &frame->data.frame;
6767   pdata->ff           = ff;
6768   pdata->envir        = env;
6769
6770   frame->type = ksct_frame;
6771   frame->next = old_frame;
6772   return frame;
6773 }
6774
6775 /* $$MOVE ME */
6776 static void
6777 klink_push_cont (klink * sc, pko ff)
6778 { sc->dump = klink_push_cont_aux(sc->dump, ff, sc->envir); }
6779
6780 /*_   , Dynamic bindings */
6781
6782 /* We do not pop dynamic bindings, only frames. */
6783 /* We deal with dynamic bindings in the context of the interpreter so
6784    that in the future we can cache them. */
6785 static void
6786 klink_push_dyn_binding (klink * sc, pko key, pko value)
6787 {
6788   _kt_spagstack frame =
6789     (_kt_spagstack)
6790     GC_MALLOC (sizeof (dump_stack_frame_cell));
6791   struct stack_binding *pdata = &frame->data.binding;
6792
6793   pdata->key           = key;
6794   pdata->value        = value;
6795
6796   frame->type = ksct_binding;
6797   frame->next = sc->dump;
6798   sc->dump = frame;
6799 }
6800
6801
6802 static pko
6803 klink_find_dyn_binding(klink * sc, pko key)
6804 {
6805   _kt_spagstack frame = sc->dump;
6806   while(1)
6807     {
6808       if (frame == 0)
6809         {
6810           return 0;
6811         }
6812       else
6813         {
6814           if(frame->type == ksct_binding)
6815             {
6816               const struct stack_binding *pdata = &frame->data.binding;
6817               if(pdata->key == key)
6818                 { return pdata->value; }
6819             }
6820           frame = frame->next;
6821         }
6822     }
6823 }
6824 /*_   , Guards */
6825 /*_    . klink_push_guards */
6826 static _kt_spagstack
6827 klink_push_guards
6828 (_kt_spagstack old_frame, pko guards, pko envir, int exit)
6829 {
6830   _kt_spagstack frame =
6831     (_kt_spagstack)
6832     GC_MALLOC (sizeof (dump_stack_frame_cell));
6833   struct stack_guards * pdata = &frame->data.guards;
6834   pdata->guards = guards;
6835   pdata->envir  = envir;
6836
6837   frame->type = exit ? ksct_exit_guards : ksct_entry_guards;
6838   frame->next = old_frame;
6839   return frame;
6840 }
6841 /*_    . get_guards_lo1st */
6842 /* Get a list of guard entries, root-most on top. */
6843 static pko
6844 get_guards_lo1st(_kt_spagstack frame)
6845 {
6846   pko list = K_NIL;
6847   for(; frame != 0; frame = frame->next)
6848     {
6849       if((frame->type == ksct_entry_guards) ||
6850          (frame->type == ksct_exit_guards))
6851         {
6852           list = cons(mk_continuation(frame), list);
6853         }
6854     }
6855
6856   return list;
6857 }
6858 /*_   , Args */
6859 /*_    . Misc */
6860 /*_     , set_nth_arg */
6861 #if 0
6862 /* Set the nth arg */
6863 /* Unused, probably for a while, probably will never be used in this
6864    form. */
6865 int
6866 set_nth_arg(klink * sc, int n, pko value)
6867 {
6868   _kt_spagstack frame = sc->dump;
6869   int i = 0;
6870   for(frame = sc->dump; frame != 0; frame = frame->next)
6871     {
6872       if(frame->type == ksct_args)
6873         {
6874           if( i == n )
6875             {
6876               frame->data.arg = value;
6877               return 1;
6878             }
6879           else
6880             { i++; }
6881         }
6882     }
6883   /* If we got here we never encountered the target. */
6884   return 0;
6885 }
6886 #endif
6887 /*_    . Store from value */
6888 /*_     , push_arg_raw */
6889 _kt_spagstack
6890 push_arg_raw(_kt_spagstack old_frame, pko value, int frame_depth)
6891 {
6892   _kt_spagstack frame =
6893     (_kt_spagstack)
6894     GC_MALLOC (sizeof (dump_stack_frame_cell));
6895
6896   frame->data.pseudoenv.vec = value;
6897   frame->data.pseudoenv.frame_depth = frame_depth;
6898   frame->type = ksct_args;
6899   frame->next = old_frame;
6900   return frame;
6901 }
6902 /*_     , k_do_store */
6903 /* T_STORE */
6904 pko
6905 k_do_store(klink * sc, pko functor, pko value)
6906 {
6907   WITH_PSYC_UNBOXED( kt_opstore, functor, T_STORE, sc );
6908   /* $$MAKE ME SAFE do_destructure must be safe vs resuming.  Error if
6909      not T_NO_K.  Don't try to maybe resume, because so far we never
6910      have to do that.
6911    */
6912   pko vec = do_destructure( sc, value, pdata->destr );
6913   /* Push that as arg */
6914   sc->dump = push_arg_raw (sc->dump, vec, pdata->frame_depth);
6915   return K_INERT;
6916 }
6917 /*_    . Load to value */
6918 /*_     , get_nth_arg */
6919 pko
6920 get_nth_arg( _kt_spagstack frame, int n )
6921 {
6922   int i = 0;
6923   for(; frame != 0; frame = frame->next)
6924     {
6925       if(frame->type == ksct_args)
6926         {
6927           if( i == n )
6928             { return frame->data.pseudoenv.vec; }
6929           else
6930             { i++; }
6931         }
6932     }
6933   /* If we got here we never encountered the target. */
6934   return 0;
6935 }
6936
6937 /*_     , k_load_recurse */
6938 /* $$IMPROVE ME Add a shortcut for accessing value without ever
6939    storing it. */
6940 pko
6941 k_load_recurse( _kt_spagstack frame, pko tree )
6942 {
6943   if(_get_type( tree) == T_PAIR)
6944     {
6945       WITH_PSYC_UNBOXED( kt_vec2, tree, T_PAIR, 0 );
6946       if( is_integer( pdata->_car ) && is_integer( pdata->_cdr ))
6947         {
6948           /* Pair of integers: Look up that item, look up secondary
6949              index, return it */
6950           const int n = ivalue( pdata->_car );
6951           const int m = ivalue( pdata->_cdr );
6952           pko vec = get_nth_arg( frame, n );
6953           assert( vec );
6954           assert( is_vector( vec ));
6955           pko value = basvector_elem( vec, m );
6956           assert( value );
6957           return value;
6958         }
6959       else
6960         {
6961           /* Pair, not integers: Explore car and cdr, return cons of them. */
6962           return cons(
6963                       k_load_recurse( frame, pdata->_car ),
6964                       k_load_recurse( frame, pdata->_cdr ));
6965         }
6966     }
6967   else
6968     {
6969       /* Anything else: Return it literally. */
6970       return tree;
6971     }
6972 }
6973
6974 /*_     , k_do_load */
6975 /* T_LOAD C-destructures as a singleton.  It will contain a tree */
6976 /* This may largely take over for decurriers. */
6977 pko
6978 k_do_load(klink * sc, pko functor, pko value)
6979 {
6980   WITH_PSYC_UNBOXED( pko, functor, T_LOAD, sc );
6981   return k_load_recurse( sc->dump, *pdata );
6982 }
6983
6984 /*_   , Stack ancestry */
6985 /*_    . frame_is_ancestor_of */
6986 int frame_is_ancestor_of(_kt_spagstack frame, _kt_spagstack other)
6987 {
6988   /* Walk from other towards root.  Return 1 if we ever encounter
6989      frame, otherwise 0. */
6990   for(; other != 0; other = other->next)
6991     {
6992       if(other == frame)
6993         { return 1; }
6994     }
6995   return 0;
6996 }
6997 /*_    . special_dynxtnt */
6998 /* Make a child of dynamic extent OUTER that evals with dynamic
6999    environment ENVIR continues normally to PROX_DEST. */
7000 _kt_spagstack special_dynxtnt
7001 (_kt_spagstack outer, _kt_spagstack prox_dest, pko envir)
7002 {
7003   return
7004     klink_push_cont_aux(outer,
7005                         mk_curried(dcrry_2A01VLL,
7006                                    LIST1(mk_continuation(prox_dest)),
7007                                    REF_OPER(invoke_continuation)),
7008                         envir);
7009 }
7010 /*_    . curr_frame_depth */
7011 int curr_frame_depth(_kt_spagstack frame)
7012 {
7013   /* Walk towards root, counting. */
7014   int count = 0;
7015   for(; frame != 0; frame = frame->next, count++)
7016     { }
7017   return count;
7018 }
7019 /*_   , Continuations */
7020 /*_    . Struct */
7021 typedef struct
7022 {
7023   _kt_spagstack frame;
7024 }
7025   continuation_t;
7026
7027 /*_    . Type */
7028 DEF_T_PRED (is_continuation, T_CONTINUATION,ground, "continuation?/o1");
7029 /*_    . Create */
7030 static pko
7031 mk_continuation (_kt_spagstack frame)
7032 {
7033   ALLOC_BOX_PRESUME (continuation_t, T_CONTINUATION);
7034   pdata->frame        = frame;
7035   return PTR2PKO(pbox);
7036 }
7037 /*_    . Parts */
7038 static _kt_spagstack
7039 cont_dump (pko p)
7040 {
7041   WITH_PSYC_UNBOXED(continuation_t,p,T_CONTINUATION,0);
7042   return pdata->frame;
7043 }
7044
7045 /*_    . Continuations WRT interpreter */
7046 /*_     , current_continuation */
7047 static pko
7048 current_continuation (klink * sc)
7049 {
7050   return mk_continuation (sc->dump);
7051 }
7052 /*_    . Operations */
7053 /*_     , invoke_continuation */
7054 /* DOES NOT RETURN */
7055 /* Control is resumed at _klink_cycle */
7056
7057 /* Static and not directly available to Kernel, it's the eventual
7058    target of continuation_to_applicative. */
7059 SIG_CHKARRAY(invoke_continuation) =
7060 { REF_OPER(is_continuation), K_ANY, };
7061 DEF_SIMPLE_CFUNC(vs0a2,invoke_continuation,T_NO_K)
7062 {
7063   WITH_2_ARGS (p, value);
7064   assert(is_continuation(p));
7065   if(p)
7066     { sc->dump = cont_dump (p); }
7067   sc->value = value;
7068   longjmp (sc->pseudocontinuation, 1);
7069 }
7070 /*_     , add_guard */
7071 /* Add the appropriate guard, if any, and return the new proximate
7072    destination. */
7073 _kt_spagstack
7074 add_guard
7075 (_kt_spagstack prox_dest, _kt_spagstack to_contain,
7076  pko guard_list, pko envir, _kt_spagstack outer)
7077 {
7078   WITH_REPORTER(0);
7079   pko x;
7080   for(x = guard_list; x != K_NIL; x = cdr(x))
7081     {
7082       pko selector = car(car(x));
7083       assert(is_continuation(selector));
7084       if(frame_is_ancestor_of(cont_dump(selector), to_contain))
7085         {
7086           /* Call has to take place in the dynamic extent of the
7087              next frame around this set of guards, so that the
7088              interceptor has access to dynamic bindings, but then
7089              control has to continue normally to the next guard or
7090              finally to the destination.
7091
7092              So we extend the next frame with a call to
7093              invoke_continuation, currying the next destination in the
7094              chain.  That does not check guards, so in effect it
7095              continues normally.  Then we extend that with a call to
7096              the interceptor, currying an continuation->applicative of
7097              the guards' outer continuation.
7098
7099              NB, continuation->applicative is correct.  It would be
7100              wrong to shortcircuit it.  Although there are no guards
7101              between there and the outer continuation, the
7102              continuation we pass might be called from another dynamic
7103              context.  But it needs to be unwrapped.
7104           */
7105           pko wrapped_interceptor = cadr(car(x));
7106           assert(is_applicative(wrapped_interceptor));
7107           pko interceptor = unwrap(0,wrapped_interceptor);
7108           assert(is_operative(interceptor));
7109
7110           _kt_spagstack med_frame =
7111             special_dynxtnt(outer, prox_dest, envir);
7112           prox_dest =
7113             klink_push_cont_aux(med_frame,
7114                                 mk_curried(dcrry_2VLLdotALL,
7115                                            LIST1(continuation_to_applicative(mk_continuation(outer))),
7116                                            interceptor),
7117                                 envir);
7118
7119           /* We use only the first match so end the loop. */
7120           break;
7121         }
7122     }
7123   return prox_dest;
7124 }
7125 /*_     , add_guard_chain */
7126 _kt_spagstack
7127 add_guard_chain
7128 (_kt_spagstack prox_dest, pko guard_frame_list, _kt_spagstack to_contain, int exit)
7129 {
7130   WITH_REPORTER(0);
7131   const enum klink_stack_cell_types tag
7132     = exit ? ksct_exit_guards : ksct_entry_guards ;
7133   for( ; guard_frame_list != K_NIL ; guard_frame_list = cdr(guard_frame_list))
7134     {
7135       _kt_spagstack guard_frame = cont_dump(car(guard_frame_list));
7136       if(guard_frame->type == tag)
7137         {
7138           struct stack_guards * pguards = &guard_frame->data.guards;
7139           prox_dest =
7140             add_guard(prox_dest,
7141                       to_contain,
7142                       pguards->guards,
7143                       pguards->envir,
7144                       exit ? guard_frame->next : guard_frame);
7145         }
7146     }
7147   return prox_dest;
7148 }
7149 /*_     , continue_abnormally */
7150 /*** Arrange to "walk" from current continuation to c, passing control
7151      thru appropriate guards.  ***/
7152 SIG_CHKARRAY(continue_abnormally) =
7153 { REF_OPER(is_continuation), K_ANY, };
7154 /* I don't give this T_NO_K even though technically it longjmps
7155    rather than pushing into the eval loop.  In the future we may
7156    distinguish those two cases. */
7157 DEF_SIMPLE_CFUNC(ps0a2,continue_abnormally,0)
7158 {
7159   WITH_2_ARGS(c,value);
7160   WITH_REPORTER(0);
7161   _kt_spagstack source      = sc->dump;
7162   _kt_spagstack destination = cont_dump (c);
7163
7164   /*** Find the guard frames on the intermediate path. ***/
7165
7166   /* Control is exiting our current frame, so collect guards from
7167      there towards root.  What we get is lowest first. */
7168   pko exiting_lo1st = get_guards_lo1st(source);
7169   /* Control is entering c's frame, so collect guards from there
7170      towards root.  Again it's lowest first.  */
7171   pko entering_lo1st = get_guards_lo1st(destination);
7172
7173   /* Remove identical entries from the top, thus removing any merged
7174      part. */
7175   while((exiting_lo1st != K_NIL) &&
7176         (entering_lo1st != K_NIL) &&
7177         (cont_dump(car(exiting_lo1st)) == cont_dump(car(entering_lo1st))))
7178     {
7179       exiting_lo1st  = cdr(exiting_lo1st);
7180       entering_lo1st = cdr(entering_lo1st);
7181     }
7182
7183
7184
7185   /*** Construct a string of calls to the appropriate guards, ending
7186        at destination.  We collect in the reverse of the order that
7187        they will be run, so collect from "entering" first, from
7188        highest to lowest, then collect from "exiting", from lowest to
7189        highest. ***/
7190
7191   _kt_spagstack prox_dest = destination;
7192
7193   pko entering_hi1st = reverse(sc, entering_lo1st);
7194   prox_dest = add_guard_chain(prox_dest, entering_hi1st, destination, 0);
7195   prox_dest = add_guard_chain(prox_dest,  exiting_lo1st, source,      1);
7196
7197   invoke_continuation(sc, mk_continuation(prox_dest), value);
7198   return value;                 /* NOTREACHED */
7199 }
7200
7201 /*_    . Interface */
7202 /*_     , call_cc */
7203 SIG_CHKARRAY(call_cc) = { REF_OPER(is_combiner), };
7204 DEF_SIMPLE_APPLICATIVE(ps0a1,call_cc,0,ground, "call/cc")
7205 {
7206   WITH_1_ARGS(combiner);
7207   pko cc = current_continuation(sc);
7208   return kernel_eval_aux(sc,combiner,LIST1(cc),sc->envir);
7209 }
7210 /*_     , extend-continuation */
7211 /*_      . extend_continuation_aux */
7212 pko
7213 extend_continuation_aux(_kt_spagstack old_frame, pko a, pko env)
7214 {
7215   _kt_spagstack frame = klink_push_cont_aux(old_frame, a, env);
7216   return mk_continuation(frame);
7217 }
7218 /*_      . extend_continuation */
7219 SIG_CHKARRAY(extend_continuation) =
7220 { REF_OPER(is_continuation),
7221   REF_OPER(is_applicative),
7222   REF_KEY(K_TYCH_OPTIONAL),
7223   REF_OPER(is_environment),
7224 };
7225 DEF_SIMPLE_APPLICATIVE(ps0a3, extend_continuation,T_NO_K,ground, "extend-continuation")
7226 {
7227   WITH_3_ARGS(c, a, env);
7228   assert(is_applicative(a));
7229   if(env == K_INERT) { env = make_new_frame(K_NIL); }
7230   return extend_continuation_aux(cont_dump(c), unwrap(sc,a), env);
7231 }
7232 /*_     , continuation->applicative */
7233 SIG_CHKARRAY(continuation_to_applicative) = { REF_OPER(is_continuation), };
7234 DEF_SIMPLE_APPLICATIVE(p00a1,continuation_to_applicative,T_NO_K,ground, "continuation->applicative")
7235 {
7236   WITH_1_ARGS(c);
7237   return
7238     wrap(mk_curried (dcrry_2A01VLL, LIST1(c), REF_OPER(continue_abnormally)));
7239 }
7240
7241 /*_     , guard-continuation */
7242 /* Each guard list is repeat (list continuation applicative) */
7243 /* We'd like to spec that applicative take 2 args, a continuation and
7244    a value, and be wrapped exactly once. */
7245 SIG_CHKARRAY(guard_continuation) =
7246 { K_ANY, REF_OPER(is_continuation), K_ANY, };
7247 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_continuation,T_NO_K,ground, "guard-continuation")
7248 {
7249   WITH_3_ARGS(entry_guards, c, exit_guards);
7250   /* The spec wants an outer continuation to keeps sets of guards from
7251      being mixed together if there are two calls to guard_continuation
7252      with the same c.  But that happens naturally here, so it seems
7253      unneeded.  */
7254
7255   /* $$IMPROVE ME Copy the es of both lists of guards. */
7256   _kt_spagstack frame = cont_dump(c);
7257   if(entry_guards != K_NIL)
7258     {
7259       frame = klink_push_guards(frame, entry_guards, sc->envir, 0);
7260     }
7261   if(exit_guards != K_NIL)
7262     {
7263       frame = klink_push_guards(frame, exit_guards, sc->envir, 1);
7264     }
7265
7266   pko inner_cont = mk_continuation(frame);
7267   return inner_cont;
7268 }
7269
7270 /*_     , guard-dynamic-extent */
7271 SIG_CHKARRAY(guard_dynamic_extent) =
7272   {
7273     REF_OPER(is_finite_list),
7274     REF_OPER(is_applicative),
7275     REF_OPER(is_finite_list),
7276   };
7277   /* DOES NOT RETURN */
7278 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_dynamic_extent,0,ground, "guard-dynamic-extent")
7279 {
7280   WITH_3_ARGS(entry,app,exit);
7281   pko cont = guard_continuation(sc,entry,current_continuation(sc),exit);
7282   pko cont2 = extend_continuation(sc,cont, app, sc->envir);
7283   /* Skip directly into the new continuation, don't invoke the
7284      guards */
7285   invoke_continuation(sc,cont2, K_NIL);
7286   /* NOTREACHED */
7287   return 0;
7288 }
7289
7290 /*_   , Keyed dynamic bindings */
7291 /*_    . klink_kdb_binder */
7292 SIG_CHKARRAY(klink_kdb_binder) =
7293 { REF_OPER(is_key), K_ANY, REF_OPER(is_combiner), };
7294 DEF_SIMPLE_CFUNC(ps0a3,klink_kdb_binder,T_NO_K)
7295 {
7296   WITH_3_ARGS(key, value, combiner);
7297   /* Check that combiner is in fact a combiner. */
7298   if(!is_combiner(combiner))
7299     {
7300       KERNEL_ERROR_1(sc,
7301                      "klink_kdb_binder: Arg 2 must be a combiner: ",
7302                      combiner);
7303     }
7304   /* Push the new binding. */
7305   klink_push_dyn_binding(sc, key, value);
7306   /* $$IMPROVE ME In general, should can control calling better than
7307      this.  Possibly do this thru invoke_continuation, except we're
7308      not arbitrarily changing continuations.  */
7309   /* $$IMPROVE ME Want a better way to control what environment to
7310      push in.  In fact, that's much like a dynamic variable. */
7311   /* $$IMPROVE ME Want a better and cheaper way to make empty
7312      environments. The vector thing should be controlled by a hint. */
7313   /* Make an empty static environment */
7314   new_frame_in_env(sc,K_NIL);
7315   /* Push combiner in that environment. */
7316   klink_push_cont(sc,combiner);
7317   /* And call it with no operands. */
7318   return K_NIL;
7319 }
7320 /* Combines with data to become "an applicative that takes two
7321   arguments, the second of which must be a oper. It calls its
7322   second argument with no operands (nil operand tree) in a fresh empty
7323   environment, and returns the result." */
7324 /*_    . klink_kdb_accessor */
7325 SIG_CHKARRAY(klink_kdb_accessor) =
7326 { REF_OPER(is_key), };
7327 DEF_SIMPLE_CFUNC(ps0a1,klink_kdb_accessor,T_NO_K)
7328 {
7329   WITH_1_ARGS(key);
7330   pko value = klink_find_dyn_binding(sc,key);
7331   if(!value)
7332     {
7333       KERNEL_ERROR_0(sc, "klink_kdb_accessor: No binding found");
7334     }
7335   return value;
7336 }
7337 /* Combines with data to become "an applicative that takes zero
7338   arguments. If the call to a occurs within the dynamic extent of a
7339   call to b, then a returns the value of the first argument passed to
7340   b in the smallest enclosing dynamic extent of a call to b. If the
7341   call to a is not within the dynamic extent of any call to b, an
7342   error is signaled."
7343  */
7344 /*_    . make_keyed_dynamic_variable */
7345 RGSTR(ground, "make-keyed-dynamic-variable", REF_OPER(make_keyed_dynamic_variable))
7346
7347 DEF_CFUNC(p00a0, make_keyed_dynamic_variable,K_NO_TYPE,T_NO_K)
7348 {
7349   return make_keyed_variable(
7350                              REF_OPER(klink_kdb_binder),
7351                              REF_OPER (klink_kdb_accessor));
7352 }
7353 /*_   , Profiling */
7354 #ifdef PROFILING
7355 /*_    . Structs */
7356 typedef struct profiling_data
7357 {
7358   int  num_calls;
7359   long num_evalloops;
7360 } profiling_data;
7361 typedef struct
7362 {
7363   pko     * objs;
7364   profiling_data * entries;
7365   int table_size;
7366   int alloced_size;
7367 } kt_profile_table;
7368 /*_    . Current data */
7369 /* This may be moved to per interpreter, or even more fine-grained. */
7370 /* This may not always be the way we get elapsed counts. */
7371 static long k_profiling_count = 0;
7372 static int k_profiling_p = 0;   /* Are we profiling now? */
7373 /* If we are profiling, init this if it's not initted */
7374 static kt_profile_table k_profiling_table = { 0 };
7375 /*_    . Dealing with table (All will be shared with other lookup tables) */
7376 /*_     , Init */
7377 void
7378 init_profile_table(kt_profile_table * p_table, int initial_size)
7379 {
7380   p_table->objs   = initial_size ?
7381     GC_MALLOC(sizeof(pko) * initial_size) : 0;
7382   p_table->entries = initial_size ?
7383     GC_MALLOC(sizeof(profiling_data) * initial_size)     : 0;
7384   p_table->alloced_size = initial_size;
7385   p_table->table_size = 0;
7386 }
7387 /*_     , Increase its size */
7388 void
7389 enlarge_profile_table(kt_profile_table * p_table)
7390 {
7391   if(p_table->table_size == p_table->alloced_size)
7392     {
7393       p_table->alloced_size *= 2;
7394       p_table->entries = GC_REALLOC(p_table->entries, sizeof(profiling_data) * p_table->alloced_size);
7395       p_table->objs = GC_REALLOC(p_table->objs, sizeof(pko) * p_table->alloced_size);
7396     }
7397
7398
7399 }
7400 /*_     , Searching in it */
7401 /* Use objtable_get_index */
7402 /*_    . On the stack */
7403 static struct stack_profiling *
7404 klink_find_profile_in_frame (_kt_spagstack frame, pko ff)
7405 {
7406   for( ;
7407       (frame != 0) && (frame->type != ksct_frame) ;
7408       frame = frame->next)
7409     {
7410       if(frame->type == ksct_profile)
7411         {
7412           struct stack_profiling *pdata = &frame->data.profiling;
7413           if(pdata->ff == ff) { return pdata; }
7414         }
7415     }
7416   return 0;
7417 }
7418 /*_    . Profile collection operations */
7419 /*_     , When eval loop steps */
7420 void
7421 k_profiling_step(void)
7422 { k_profiling_count++; }
7423 /*_     , When we begin executing a frame */
7424 /* Push a stack_profiling cell onto the frame.  */
7425
7426 void
7427 k_profiling_new_frame(klink * sc, pko ff)
7428 {
7429   if(!k_profiling_p) { return; }
7430   if(!is_operative(ff)) { return; }
7431   /* Do this only if ff is interesting (which for the moment means
7432      that it can be found in ground environment). */
7433   if(!reverse_binds_p(ff, ground_env)           &&
7434      !reverse_binds_p(ff, print_lookup_unwraps) &&
7435      !reverse_binds_p(ff, print_lookup_to_xary))
7436     { return; }
7437   struct stack_profiling * found_profile =
7438     klink_find_profile_in_frame (sc->dump, ff);
7439   /* If the same combiner is already being profiled in this frame,
7440      don't add another copy.  */
7441   if(found_profile)
7442     {
7443       /* $$IMPROVE ME Count tail calls */
7444     }
7445   else
7446     {
7447       /* Push a profiling frame */
7448       _kt_spagstack old_frame = sc->dump;
7449       _kt_spagstack frame =
7450         (_kt_spagstack)
7451         GC_MALLOC (sizeof (dump_stack_frame_cell));
7452       struct stack_profiling * pdata = &frame->data.profiling;
7453       pdata->ff            = ff;
7454       pdata->initial_count = k_profiling_count;
7455       pdata->returned_p    = 0;
7456       frame->type = ksct_profile;
7457       frame->next = old_frame;
7458       sc->dump = frame;
7459     }
7460 }
7461
7462 /*_     , When we pop a stack_profiling cell */
7463 void
7464 k_profiling_done_frame(klink * sc, struct stack_profiling * profile)
7465 {
7466   if(!k_profiling_p) { return; }
7467   profiling_data * pdata = 0;
7468   pko ff = profile->ff;
7469
7470   /* This stack_profiling cell is popped past but it might be used
7471      again if we re-enter, so mark it accordingly. */
7472   profile->returned_p = 1;
7473   if(k_profiling_table.alloced_size == 0)
7474     { init_profile_table(&k_profiling_table, 8); }
7475   else
7476     {
7477       int index = objtable_get_index(k_profiling_table.objs, k_profiling_table.table_size, ff);
7478       if(index >= 0)
7479         { pdata = &k_profiling_table.entries[index]; }
7480     }
7481
7482   /* Create it if needed */
7483   if(!pdata)
7484     {
7485       /* Increase size as needed */
7486       enlarge_profile_table(&k_profiling_table);
7487       /* Add entry */
7488       const int index = k_profiling_table.table_size;
7489       k_profiling_table.objs[index] = ff;
7490       k_profiling_table.table_size++;
7491       pdata = &k_profiling_table.entries[index];
7492       /* Initialize it here */
7493       pdata->num_calls     = 0;
7494       pdata->num_evalloops = 0;
7495     }
7496
7497   /* Add to its counts: Num calls.  Num eval-loops taken. */
7498   pdata->num_calls++;
7499   pdata->num_evalloops += k_profiling_count - profile->initial_count;
7500 }
7501 /*_    . Interface */
7502 /*_     , Turn profiling on */
7503 /* Maybe better as a command-line switch or binder. */
7504 SIG_CHKARRAY(profiling) = { REF_OPER(is_integer), };
7505 DEF_SIMPLE_APPLICATIVE (ps0a1, profiling,T_NO_K,ground, "profiling")
7506 {
7507   WITH_1_ARGS(profile_p);
7508   int pr = k_profiling_p;
7509   k_profiling_p = ivalue (profile_p);
7510   return mk_integer (pr);
7511 }
7512
7513 /*_     , Dumping profiling data */
7514 /* Return a list of the profiled combiners. */
7515 DEF_APPLICATIVE_W_DESTR(ps0a0,get_profiling_data,K_NO_TYPE,T_NO_K,ground,"get-profiling-data")
7516 {
7517   int index;
7518   pko result_list = K_NIL;
7519   for(index = 0; index < k_profiling_table.table_size; index++)
7520     {
7521       pko ff = k_profiling_table.objs[index];
7522       profiling_data * pdata = &k_profiling_table.entries[index];
7523
7524       /* Element format: (object num-calls num-evalloops) */
7525       result_list = cons(
7526                          LIST3(ff,
7527                                mk_integer(pdata->num_calls),
7528                                mk_integer(pdata->num_evalloops)),
7529                          result_list);
7530     }
7531   /* Don't care about order so no need to reverse the list. */
7532   return result_list;
7533 }
7534 /*_    . Reset profiling data */
7535 /*_   , Alternative definitions for no profiling */
7536 #else
7537 #define k_profiling_step()
7538 #define k_profiling_new_frame(DUMMY, DUMMY2)
7539 #endif
7540 /*_  . Error handling */
7541 /*_   , _klink_error_1 */
7542 static void
7543 _klink_error_1 (klink * sc, const char *s, pko a)
7544 {
7545 #if SHOW_ERROR_LINE
7546   const char *str = s;
7547   char sbuf[STRBUFFSIZE];
7548   pko the_inport = klink_find_dyn_binding(sc,K_INPORT);
7549   if (the_inport && (the_inport != K_NIL))
7550     {
7551       port * pt = portvalue(the_inport);
7552       /* Make sure error is not in REPL */
7553       if((pt->kind & port_file) && (pt->rep.stdio.file != stdin))
7554         {
7555           /* Count is 0-based but print it 1-based. */
7556           int ln = pt->rep.stdio.curr_line + 1;
7557           const char *fname = pt->rep.stdio.filename;
7558
7559           if (!fname)
7560             { fname = "<unknown>"; }
7561
7562           snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
7563
7564           str = (const char *) sbuf;
7565         }
7566     }
7567 #else
7568   const char *str = s;
7569 #endif
7570   {
7571     pko err_arg;
7572     pko err_string = mk_string (str);
7573     if (a != 0)
7574       {
7575         err_arg = mcons (a, K_NIL);
7576       }
7577     else
7578       {
7579         err_arg = K_NIL;
7580       }
7581     err_arg = mcons (err_string, err_arg);
7582     invoke_continuation (sc, sc->error_continuation, err_arg);
7583   }
7584   /* NOTREACHED */
7585   return;
7586 }
7587
7588 /*_   , Default cheap error handlers */
7589 /*_    .  kernel_err */
7590 DEF_CFUNC (ps0a1, kernel_err, K_ANY,0)
7591 {
7592   WITH_REPORTER(0);
7593   if(arg1 == K_NIL)
7594     {
7595       putstr (sc, "Error with no arguments.  I know nut-ting!");
7596       return K_INERT;
7597     }
7598   if(!is_finite_list(arg1))
7599     {
7600       putstr (sc, "kernel_err: arg must be a finite list");
7601       return K_INERT;
7602     }
7603
7604   assert(is_pair(arg1));
7605   int got_string = is_string (car (arg1));
7606   pko args_x = got_string ? cdr (arg1) : arg1;
7607   const char *message = got_string ? string_value (car (arg1)) : " -- ";
7608
7609   putstr (sc, "Error: ");
7610   putstr (sc, message);
7611   return kernel_err_x (sc, args_x);
7612 }
7613
7614 /*_    . kernel_err_x */
7615 DEF_CFUNC (ps0a1, kernel_err_x, K_ANY_SINGLETON,0)
7616 {
7617   WITH_1_ARGS(args);
7618   WITH_REPORTER(0);
7619   putstr (sc, " ");
7620   if (args != K_NIL)
7621     {
7622       assert(is_pair(args));
7623       CONTIN_1 (dcrry_1dotALL, kernel_err_x, sc, cdr (args));
7624       klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
7625       CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, car (args));
7626       return K_INERT;
7627     }
7628   else
7629     {
7630       putstr (sc, "\n");
7631       return K_INERT;
7632     }
7633 }
7634 /*_    . kernel_err_return */
7635 DEF_CFUNC(ps0a1,kernel_err_return, K_ANY,0)
7636 {
7637   /* This should not set sc->done, because when it's called it still
7638      must print the error, which may require more eval loops.  */
7639   sc->retcode = 1;
7640   return kernel_err(sc, arg1);
7641 }
7642 /*_   , Interface */
7643 /*_    . error */
7644 DEF_APPLICATIVE_W_DESTR(ps0a1,error,K_ANY,0,ground,"error")
7645 {
7646   WITH_1_ARGS(err_arg);
7647   invoke_continuation (sc, sc->error_continuation, err_arg);
7648   return 0;                     /* NOTREACHED */
7649 }
7650 /*_    . error-descriptor? */
7651 /* $$WRITE ME TO replace the punted version */
7652
7653 /*_  . Support for calling C functions */
7654
7655 /*_   , klink_call_cfunc_aux */
7656 static pko
7657 klink_call_cfunc_aux (klink * sc, const kt_cfunc * p_cfunc, pko * arg_array)
7658 {
7659   switch (p_cfunc->type)
7660     {
7661       /* For these macros, the arglist is parenthesized so is
7662          usable. */
7663
7664       /* ***************************************** */
7665       /* For function types returning bool as int (bXXaX) */
7666 #define CASE_CFUNCTYPE_bX(SUFFIX,ARGLIST)                       \
7667       case klink_ftype_##SUFFIX:                                \
7668         return kernel_bool(p_cfunc->func.f_##SUFFIX ARGLIST)
7669
7670       CASE_CFUNCTYPE_bX (b00a1, (arg_array[0]));
7671       CASE_CFUNCTYPE_bX (b00a2, (arg_array[0], arg_array[1]));
7672       CASE_CFUNCTYPE_bX (bs0a2, (sc, arg_array[0], arg_array[1]));
7673
7674 #undef CASE_CFUNCTYPE_bX
7675
7676
7677       /* ***************************************** */
7678       /* For function types returning pko (pXXaX) */
7679 #define CASE_CFUNCTYPE_pX(SUFFIX,ARGLIST)       \
7680       case klink_ftype_##SUFFIX:                \
7681         return p_cfunc->func.f_##SUFFIX ARGLIST
7682
7683       CASE_CFUNCTYPE_pX (p00a0, ());
7684       CASE_CFUNCTYPE_pX (p00a1, (arg_array[0]));
7685       CASE_CFUNCTYPE_pX (p00a2, (arg_array[0], arg_array[1]));
7686       CASE_CFUNCTYPE_pX (p00a3, (arg_array[0], arg_array[1], arg_array[2]));
7687
7688       CASE_CFUNCTYPE_pX (ps0a0, (sc));
7689       CASE_CFUNCTYPE_pX (ps0a1, (sc, arg_array[0]));
7690       CASE_CFUNCTYPE_pX (ps0a2, (sc, arg_array[0], arg_array[1]));
7691       CASE_CFUNCTYPE_pX (ps0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7692       CASE_CFUNCTYPE_pX (ps0a4, (sc, arg_array[0], arg_array[1],
7693                                  arg_array[2], arg_array[3]));
7694       CASE_CFUNCTYPE_pX (ps0a5, (sc, arg_array[0], arg_array[1], arg_array[2], arg_array[3], arg_array[4]));
7695
7696 #undef CASE_CFUNCTYPE_pX
7697
7698
7699       /* ***************************************** */
7700       /* For function types returning void (vXXaX) */
7701 #define CASE_CFUNCTYPE_vX(SUFFIX,ARGLIST)       \
7702       case klink_ftype_##SUFFIX:                \
7703         p_cfunc->func.f_##SUFFIX ARGLIST;       \
7704       return K_INERT
7705
7706       CASE_CFUNCTYPE_vX (vs0a2, (sc, arg_array[0], arg_array[1]));
7707       CASE_CFUNCTYPE_vX (vs0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7708
7709 #undef CASE_CFUNCTYPE_vX
7710
7711     default:
7712       KERNEL_ERROR_0 (sc,
7713                       "kernel_call: About that function type, I know nut-ting!");
7714     }
7715 }
7716 /*_   , klink_call_cfunc */
7717 static pko
7718 klink_call_cfunc (klink * sc, pko functor, pko env, pko args)
7719 {
7720   const kt_cfunc * p_cfunc = get_cfunc_func (functor);
7721   assert(p_cfunc->argcheck);
7722   const int max_args = 5;
7723   pko arg_array[max_args];
7724   destructure_to_array(sc,args,
7725                        p_cfunc->argcheck,
7726                        arg_array,
7727                        max_args,
7728                        REF_OPER (k_resume_to_cfunc),
7729                        functor);
7730   return klink_call_cfunc_aux (sc, p_cfunc, arg_array);
7731 }
7732 /*_   , k_resume_to_cfunc */
7733 SIG_CHKARRAY (k_resume_to_cfunc) =
7734 {
7735   REF_OPER (is_destr_result),
7736   REF_KEY (K_TYCH_DOT),
7737   REF_OPER (is_cfunc),
7738 };
7739 DEF_SIMPLE_CFUNC (ps0a2, k_resume_to_cfunc, 0)
7740 {
7741   WITH_2_ARGS (destr_result, functor);
7742   assert_type (0, functor, T_CFUNC);
7743   const int max_args = 5;
7744   pko arg_array[max_args];
7745   destr_result_fill_array (destr_result, max_args, arg_array);
7746   return klink_call_cfunc_aux (sc, get_cfunc_func (functor), arg_array);
7747 }
7748 /*_  . Some decurriers */
7749 static pko
7750 dcrry_2A01VLL (klink * sc, pko args, pko value)
7751 {
7752   WITH_REPORTER(sc);
7753   return LIST2(car (args), value);
7754 }
7755 static pko dcrry_3A01dotVLL (klink * sc, pko args, pko value)
7756 {
7757   WITH_REPORTER(sc);
7758   return cons (car (args), value);
7759 }
7760 static pko
7761 dcrry_2CA01VLLA02 (klink * sc, pko args, pko value)
7762 {
7763   WITH_REPORTER(sc);
7764   return LIST2( cons (car (args), value), cadr (args));
7765 }
7766 /* May not be needed */
7767 static pko
7768 dcrry_3A01A02VLL (klink * sc, pko args, pko value)
7769 {
7770   WITH_REPORTER(sc);
7771   return LIST3(car (args), cadr (args), value);
7772 }
7773 static pko
7774 dcrry_2ALLVLL (klink * sc, pko args, pko value)
7775 {
7776   return LIST2(args, value);
7777 }
7778 static pko dcrry_2ALLV01     (klink * sc, pko args, pko value)
7779 {
7780   WITH_REPORTER(sc);
7781   return LIST2(args, car (value));
7782 }
7783
7784 static pko
7785 dcrry_NCVLLA01dotAX1 (klink * sc, pko args, pko value)
7786 {
7787   WITH_REPORTER(sc);
7788   return cons(cons (value, car (args)), cdr (args));
7789 }
7790 static pko dcrry_NdotALL (klink * sc, pko args, pko value)
7791 { return args; }
7792
7793 static pko dcrry_1ALL (klink * sc, pko args, pko value)
7794 { return cons( args, K_NIL ); }
7795
7796 static pko dcrry_5ALLdotVLL (klink * sc, pko args, pko value)
7797 { return cons (args, value); }
7798
7799 static pko dcrry_NVLLdotALL (klink * sc, pko args, pko value)
7800 { return cons (value, args); }
7801
7802 static pko
7803 dcrry_1VLL (klink * sc, pko args, pko value)
7804 { return LIST1 (value); }
7805
7806 /*_  . Defining */
7807 /*_   , Internal functions */
7808 /*_    . kernel_define_tree_aux */
7809 kt_destr_outcome
7810 kernel_define_tree_aux
7811 (klink * sc, pko value, pko formal, pko env, pko * extra_result)
7812 {
7813   WITH_REPORTER(0);
7814   if (is_pair (formal))
7815     {
7816       if (is_pair (value))
7817         {
7818           kt_destr_outcome outcome =
7819             kernel_define_tree_aux (sc, car (value), car (formal), env,
7820                                     extra_result);
7821           switch (outcome)
7822             {
7823             case destr_success:
7824               /* $$IMPROVE ME On error, give a more accurate position. */
7825               return
7826                 kernel_define_tree_aux (sc, cdr (value), cdr (formal), env,
7827                                         extra_result);
7828             case destr_err:
7829               return destr_err;
7830             case destr_must_call_k:
7831               /* $$IMPROVE ME Also schedule to resume the cdr */
7832               /* Operations to run, in reverse order. */
7833               *extra_result =
7834                 LISTSTAR3(
7835                       /* ^V= #inert */
7836                       REF_OPER (kernel_define_tree),
7837                       /* V= (value formal env) */
7838                       mk_load (LIST3 (cdr (value),
7839                                       cdr (formal),
7840                                       env)),
7841                       *extra_result);
7842               return destr_must_call_k;
7843             default:
7844               errx (7, "Unrecognized enumeration");
7845             }
7846         }
7847       if (is_promise (value))
7848         {
7849           /* Operations to run, in reverse order. */
7850           *extra_result =
7851             LIST5(
7852                   /* ^V= #inert */
7853                   REF_OPER (kernel_define_tree),
7854                   /* V= (forced-value formal env) */
7855                   mk_load (LIST3 (mk_load_ix (0, 0),
7856                                   formal,
7857                                   env)),
7858                   mk_store (K_ANY, 1),
7859                   /* V= forced-argobject */
7860                   REF_OPER (force),
7861                   /* ^V= (value) */
7862                   mk_load (LIST1 (value)));
7863           return destr_must_call_k;
7864         }
7865       else
7866         {
7867           _klink_error_1 (sc,
7868                            "kernel_define_tree: value must be a pair: ", value);
7869           return destr_err;             /* NOTREACHED */
7870         }
7871     }
7872   /* We can encounter NIL at the end of a non-dotted list, so mustn't
7873      try to bind it, and value list must end here too. */
7874   else if (formal == K_NIL)
7875     {
7876       if(value != K_NIL)
7877         {
7878           _klink_error_1 (sc,
7879                            "kernel_define_tree: too many args: ", value);
7880           return destr_err;             /* NOTREACHED */
7881         }
7882       return destr_success;
7883     }
7884   /* If formal is #ignore, don't try to bind it, do nothing. */
7885   else if (formal == K_IGNORE)
7886     {
7887       return destr_success;
7888     }
7889   /* If it's a symbol, bind it.  Even a promise is bound thus. */
7890   else if (is_symbol (formal))
7891     {
7892       kernel_define (env, formal, value);
7893       return destr_success;
7894     }
7895   else
7896     {
7897       _klink_error_1 (sc,
7898                       "kernel_define_tree: can't bind to: ", formal);
7899       return destr_err;         /* NOTREACHED */
7900     }
7901 }
7902 /*_    . kernel_define_tree */
7903 /* This can no longer be assumed to be T_NO_K, in case promises must
7904    be forced. */
7905 SIG_CHKARRAY(kernel_define_tree) =
7906 { K_ANY,  K_ANY, REF_OPER(is_environment), };
7907 DEF_SIMPLE_CFUNC(vs0a3,kernel_define_tree,0)
7908 {
7909   WITH_3_ARGS(value, formal, env);
7910   pko extra_result;
7911   kt_destr_outcome outcome =
7912     kernel_define_tree_aux(sc, value, formal, env, &extra_result);
7913   switch (outcome)
7914     {
7915     case destr_success:
7916       break;
7917     case destr_err:
7918       /* Later this may raise the error */
7919       return;
7920     case destr_must_call_k:
7921       schedule_rv_list (sc, extra_result);
7922       return;
7923     default:
7924       errx (7, "Unrecognized enumeration");
7925     }
7926 }
7927 /*_    . kernel_define */
7928 SIG_CHKARRAY(kernel_define) =
7929 {
7930   REF_OPER(is_environment),
7931   REF_OPER(is_symbol),
7932   K_ANY,
7933 };
7934 DEF_SIMPLE_CFUNC(p00a3,kernel_define,T_NO_K)
7935 {
7936   WITH_3_ARGS(env, symbol, value);
7937   assert(is_symbol(symbol));
7938   pko x = find_slot_in_env (env, symbol, 0);
7939   if (x != 0)
7940     {
7941       set_slot_in_env (x, value);
7942     }
7943   else
7944     {
7945       new_slot_spec_in_env (env, symbol, value);
7946     }
7947   return K_INERT;
7948 }
7949 void klink_define (klink * sc, pko symbol, pko value)
7950 { kernel_define(sc->envir,symbol,value); }
7951
7952 /*_   , Supporting kernel registerables */
7953 /*_    . eval_define */
7954 RGSTR(ground, "$define!", REF_OPER(eval_define))
7955 SIG_CHKARRAY(eval_define) =
7956 { K_ANY, K_ANY, };
7957 DEF_SIMPLE_CFUNC(ps0a2,eval_define,0)
7958 {
7959   pko env = sc->envir;
7960   WITH_2_ARGS(formal, expr);
7961   CONTIN_2(dcrry_3VLLdotALL,kernel_define_tree,sc,formal,env);
7962   /* Using args functionality:
7963      BEFORE:
7964      make 2 new slots
7965      put formal in 2,
7966      put env in 3,
7967
7968      RUN, in reverse order
7969      kernel_define_tree (CONTIN_0)
7970      make arglist from 3 args ($$WRITE MY SUPPORT) - or from 2 args and value.
7971      (The 2 slots will go here)
7972      put return value in new slot ($$WRITE MY SUPPORT)
7973      kernel_eval
7974
7975
7976      Possibly "make arglist" will be an array of integers, -1 meaning
7977      the current value.  And on its own it could do decurrying.
7978    */
7979   return kernel_eval(sc,expr,env);
7980 }
7981 /*_    . set */
7982 RGSTR(ground, "$set!", REF_OPER(set))
7983 SIG_CHKARRAY(set) =
7984 { K_ANY, K_ANY, K_ANY, };
7985 DEF_SIMPLE_CFUNC(ps0a3,set,0)
7986 {
7987   pko env = sc->envir;
7988   WITH_3_ARGS(env_expr, formal, expr);
7989   /* Using args functionality:
7990
7991      RUN, in reverse order
7992      kernel_define_tree (CONTIN_0)
7993      make arglist from 3 args - or from 2 args and value.
7994      put return value in new slot
7995      kernel_eval
7996      make arglist from 1 arg
7997      env_expr in slot
7998      formal in slot
7999      put return value in new slot
8000      kernel_eval
8001      expr (Passed directly)
8002
8003    */
8004
8005   CONTIN_0(kernel_define_tree,sc);
8006   return
8007     kernel_mapeval(sc, K_NIL,
8008                    LIST3(expr,
8009                          LIST2(REF_OPER (arg1), formal),
8010                          env_expr),
8011                    env);
8012 }
8013
8014 /*_  . Misc Kernel functions */
8015 /*_   , tracing */
8016
8017 SIG_CHKARRAY(tracing) = { REF_OPER(is_integer), };
8018 DEF_SIMPLE_APPLICATIVE (ps0a1, tracing,T_NO_K,ground, "tracing")
8019 {
8020   WITH_1_ARGS(trace_p);
8021   int tr = sc->tracing;
8022   sc->tracing = ivalue (trace_p);
8023   return mk_integer (tr);
8024 }
8025
8026 /*_   , new_tracing */
8027
8028 SIG_CHKARRAY(new_tracing) = { REF_OPER(is_integer), };
8029 DEF_SIMPLE_APPLICATIVE (ps0a1, new_tracing,T_NO_K,ground, "new-tracing")
8030 {
8031   WITH_1_ARGS(trace_p);
8032   int tr = sc->new_tracing;
8033   sc->new_tracing = ivalue (trace_p);
8034   return mk_integer (tr);
8035 }
8036
8037
8038 /*_   , get-current-environment */
8039 DEF_APPLICATIVE_W_DESTR (ps0a0, get_current_environment, K_NO_TYPE,T_NO_K,ground, "get-current-environment")
8040 { return sc->envir; }
8041
8042 /*_   , arg1, $quote, list */
8043 DEF_APPLICATIVE_W_DESTR (ps0a1, arg1, K_ANY_SINGLETON,T_NO_K,ground, "identity")
8044 {
8045   WITH_1_ARGS(p);
8046   return p;
8047 }
8048 /* Same, unwrapped */
8049 RGSTR(ground, "$quote",   REF_OPER(arg1))
8050
8051 /*_   , val2val */
8052 RGSTR(ground, "list", REF_APPL(val2val))
8053 /* The underlying C function here is "arg1", but it's called with
8054    the whole argobject as arg1 */
8055 /* K_ANY instead of REF_OPER(is_finite_list) because we deliberately allow
8056    non-lists and improper lists. */
8057 DEF_CFUNC_RAW(OPER(val2val),ps0a1,arg1,K_ANY,T_NO_K);
8058 DEF_BOXED_APPLICATIVE(val2val, REF_OPER (val2val));
8059
8060 /*_   , k_quit */
8061 RGSTR(ground,"exit",REF_OPER(k_quit))
8062 DEF_CFUNC(ps0a0,k_quit,K_NO_TYPE,0)
8063 {
8064   if(!nest_depth_ok_p(sc))
8065     { sc->retcode = 1; }
8066
8067   sc->done = 1;
8068   return K_INERT;               /* Value is unused anyways */
8069 }
8070 /*_   , gc */
8071 RGSTR(ground,"gc",REF_OPER(k_gc))
8072 DEF_CFUNC(ps0a0,k_gc,K_NO_TYPE,0)
8073 {
8074   GC_gcollect();
8075   return K_INERT;
8076 }
8077
8078 /*_   , k_if */
8079
8080 RGSTR(ground, "$if", REF_OPER(k_if))
8081 FORWARD_DECL_CFUNC(static,ps0a3,k_if_literal);
8082 SIG_CHKARRAY(k_if) = { K_ANY, K_ANY, K_ANY, };
8083 DEF_SIMPLE_DESTR( k_if );
8084 SIG_CHAIN(k_if) =
8085   {
8086     /* Store (test consequent alternative) */
8087     ANON_STORE(REF_DESTR(k_if)),
8088
8089     ANON_LOAD(ANON_LIST1(ANON_LOAD_IX( 0, 0 ))),
8090     /* value = (test) */
8091
8092     REF_OPER(kernel_eval),
8093     /* test_result */
8094     /* Store (test_result) */
8095     ANON_STORE(K_ANY),
8096
8097     ANON_LOAD(ANON_LIST3(ANON_LOAD_IX( 0, 0 ),
8098                          ANON_LOAD_IX( 1, 1 ),
8099                          ANON_LOAD_IX( 1, 2 ))),
8100
8101     /* test_result, consequent, alternative */
8102     REF_OPER(k_if_literal),
8103   };
8104
8105 DEF_SIMPLE_CHAIN(k_if);
8106
8107 SIG_CHKARRAY(k_if_literal) = { REF_OPER(is_bool), K_ANY, K_ANY, };
8108 DEF_SIMPLE_CFUNC(ps0a3,k_if_literal,0)
8109 {
8110   WITH_3_ARGS(test, consequent, alternative);
8111   if(test == K_T) { return kernel_eval(sc, consequent, sc->envir); }
8112   if(test == K_F) { return kernel_eval(sc, alternative, sc->envir); }
8113   KERNEL_ERROR_1(sc,"Must be a boolean: ", test);
8114 }
8115
8116 /*_  . Routines for applicatives */
8117 BOX_OF_VOID (K_APPLICATIVE);
8118
8119 DEF_SIMPLE_PRED (is_applicative,T_NO_K,ground, "applicative?/o1")
8120 {
8121   WITH_1_ARGS(p);
8122   return is_encap (REF_KEY(K_APPLICATIVE), p);
8123 }
8124
8125 DEF_SIMPLE_PRED (is_combiner,T_NO_K,ground, "combiner?/o1")
8126 {
8127   WITH_1_ARGS(p);
8128   return is_applicative(p) || is_operative(p);
8129 }
8130
8131 SIG_CHKARRAY(wrap) = { REF_OPER(is_combiner) };
8132 DEF_SIMPLE_APPLICATIVE (p00a1, wrap,T_NO_K,ground, "wrap")
8133 {
8134   WITH_1_ARGS(p);
8135   return mk_encap (REF_KEY(K_APPLICATIVE), p);
8136 }
8137
8138 SIG_CHKARRAY(unwrap) = { REF_OPER(is_applicative) };
8139 DEF_SIMPLE_APPLICATIVE (ps0a1, unwrap,T_NO_K,ground, "unwrap")
8140 {
8141   WITH_1_ARGS(p);
8142   return unencap (sc, REF_KEY(K_APPLICATIVE), p);
8143 }
8144
8145 SIG_CHKARRAY(unwrap_all) = { REF_OPER(is_combiner) };
8146 DEF_SIMPLE_APPLICATIVE (p00a1, unwrap_all,T_NO_K,ground, "unwrap-all")
8147 {
8148   WITH_1_ARGS(p);
8149   /* Wrapping does not allowing circular wrapping, so this will
8150      terminate.  */
8151   while(is_encap (REF_KEY(K_APPLICATIVE), p))
8152     { p = unencap (0, REF_KEY(K_APPLICATIVE), p); }
8153   return p;
8154 }
8155
8156
8157 /*_  . Operatives */
8158 /*_   , is_operative */
8159 /* This can be hacked quicker by suppressing 1 more bit and testing
8160  * just once.  Requires keeping those T_ types co-ordinated, though. */
8161 DEF_SIMPLE_PRED (is_operative,T_NO_K,ground, "operative?/o1")
8162 {
8163   WITH_1_ARGS(p);
8164   return
8165        is_type (p, T_CFUNC)
8166     || is_type (p, T_CFUNC_RESUME)
8167     || is_type (p, T_CURRIED)
8168     || is_type (p, T_LISTLOOP)
8169     || is_type (p, T_CHAIN)
8170     || is_type (p, T_STORE)
8171     || is_type (p, T_LOAD)
8172     || is_type (p, T_TYPEP);
8173 }
8174
8175 /*_  . vau_1 */
8176 RGSTR(simple, "$vau/3", REF_OPER(vau_1))
8177
8178 /* This is a simple vau for bootstrap.  It handles just a single
8179    expression.  It's in ground for now, but will be only in
8180    low-for-optimization later */
8181
8182 /* $$IMPROVE ME Check that formals is a non-circular list with no
8183    duplicated symbols.  If this check is typical for
8184    kernel_define_tree (probably), pass that an initially blank
8185    environment and it can check for symbols and error if they are
8186    already defined.
8187
8188    eformal is almost REF_OPER(is_symbol) but must accept #ignore also.
8189 */
8190 SIG_CHKARRAY(vau_1) = { K_ANY, K_ANY, K_ANY };
8191 DEF_SIMPLE_CFUNC (ps0a3, vau_1,0)
8192 {
8193   pko env = sc->envir;
8194   WITH_3_ARGS(formals, eformal, expression);
8195   /* This defines a vau object.  Evaluating it is different.
8196      See 4.10.3 */
8197
8198   /* $$IMPROVE ME Could compile the expression now, but that's not so
8199      easy in Kernel. At least make a hook for that. */
8200
8201   /* Vau data is a list of the 4 things:
8202      The dynamic environment
8203      The eformal symbol
8204      An immutable copy of the formals es
8205      An immutable copy of the expression
8206
8207      $$IMPROVE ME Make not a list but a dedicated struct.
8208    */
8209   pko vau_data =
8210     LIST4(env,
8211           eformal,
8212           copy_es_immutable(sc, formals),
8213           copy_es_immutable (sc, expression));
8214   return
8215     mk_curried (dcrry_5VLLdotALL, vau_data, REF_OPER (eval_vau));
8216 }
8217
8218 /*_  . Evaluation, Kernel style */
8219 /*_   , Calling operatives */
8220 /*_    . eval_vau */
8221 /* Again, can't simply say REF_OPER(is_symbol) because it might be
8222    #ignore */
8223 SIG_CHKARRAY(eval_vau) =
8224 { K_ANY,
8225   REF_OPER(is_environment),
8226   K_ANY,
8227   K_ANY,
8228   K_ANY };
8229 DEF_SIMPLE_CFUNC (ps0a5, eval_vau,0)
8230 {
8231   pko env = sc->envir;
8232   WITH_5_ARGS(args, old_env, eformal, formals, expression);
8233
8234   /* Make a new environment, child of the static environment (which
8235      we get now while making the vau) and put it into the envir
8236      register. */
8237   new_frame_in_env (sc, old_env);
8238
8239   /* This will change in kernel_define, not here. */
8240   /* Bind the dynamic environment to the eformal symbol. */
8241   kernel_define_tree (sc, env, eformal, sc->envir);
8242
8243   /* Bind the formals (symbols) to the operands (values) treewise.  */
8244   pko extra_result;
8245   kt_destr_outcome outcome =
8246     kernel_define_tree_aux(sc, args, formals, sc->envir, &extra_result);
8247   switch (outcome)
8248     {
8249     case destr_success:
8250       break;
8251     case destr_err:
8252       /* Later this may raise the error */
8253       return K_INERT;
8254     case destr_must_call_k:
8255       CONTIN_2 (dcrry_2dotALL, kernel_eval, sc, expression, sc->envir);
8256       schedule_rv_list (sc, extra_result);
8257       return K_INERT;
8258     default:
8259       errx (7, "Unrecognized enumeration");
8260     }
8261
8262   /* Evaluate the expression. */
8263   return kernel_eval (sc, expression, sc->envir);
8264 }
8265
8266 /*_   , Kernel eval mutual callers */
8267 /*_    . kernel_eval */
8268
8269 /* Optionally define a tracing kernel_eval  */
8270 SIG_CHKARRAY(kernel_eval) = { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
8271 DEF_SIMPLE_DESTR(kernel_eval);
8272 #if USE_TRACING
8273 FORWARD_DECL_CFUNC(static,ps0a2,kernel_real_eval);
8274 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
8275 {
8276   WITH_2_ARGS(form, env);
8277   /* $$RETHINK ME  Set sc->envir here, remove arg from
8278      kernel_real_eval, and the tracing call will know its own env,
8279      it may just be a closure with form as value. */
8280   if(env == K_INERT)
8281     {
8282       env = sc->envir;
8283     }
8284   if (sc->tracing)
8285     {
8286       CONTIN_2 (dcrry_2dotALL, kernel_real_eval, sc, form, env);
8287       putstr (sc, "\nEval: ");
8288       CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, form);
8289       return K_INERT;
8290     }
8291   else
8292     {
8293       return kernel_real_eval (sc, form, env);
8294     }
8295 }
8296 #endif
8297
8298 /* Define either kernel_eval (if not defined above) or kernel_real_eval  */
8299 #if USE_TRACING
8300 /* $$IMPROVE MY DESIGN  Don't like the pointers being different
8301    levels of pointingness.  In fact, we always potentially have
8302    tracing (or w/e) so let's lose the preprocessor condition. */
8303
8304 DEF_CFUNC (ps0a2, kernel_real_eval, REF_DESTR(kernel_eval),0)
8305 #else
8306 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
8307 #endif
8308 {
8309   WITH_REPORTER(0);
8310   WITH_2_ARGS(form, env);
8311
8312   /* Evaluate form in env */
8313   /* Arguments:
8314      form: form to be evaluated
8315      env: environment to evaluate it in.
8316    */
8317   assert (form);
8318   assert (env);
8319   /* $$IMPROVE ME Let this be done in kernel_eval and lose the env
8320      argument, here just assert that we have an environment. */
8321   if(env != K_INERT)
8322     {
8323       if (is_environment (env))
8324         { sc->envir = env; }
8325       else
8326         {
8327           KERNEL_ERROR_0 (sc, "eval: Arg 2 must be an environment:");
8328         }
8329     }
8330   /* symbol */
8331   if (is_symbol (form))
8332     {
8333       pko x = find_slot_in_env (env, form, 1);
8334       if (x != 0)
8335         {
8336           return slot_value_in_env (x);
8337         }
8338       else
8339         {
8340           KERNEL_ERROR_1 (sc, "eval: unbound variable:", form);
8341         }
8342     }
8343   /* pair */
8344   else if (is_pair (form))
8345     {
8346       CONTIN_2 (dcrry_3VLLdotALL, kernel_eval_aux, sc, cdr (form), env);
8347       return kernel_eval (sc, car (form), env);
8348     }
8349   /* Otherwise return the object literally. */
8350   else
8351     {
8352       return form;
8353     }
8354 }
8355 /*_    . kernel_eval_aux */
8356 /* The stage of `eval' when we've already decided that we're to use a
8357    combiner and what that combiner is. */
8358 /* $$IMPROVE ME  Lose the env argument, it's always sc->envir */
8359 SIG_CHKARRAY(kernel_eval_aux) =
8360 { REF_OPER(is_combiner), K_ANY, REF_OPER(is_environment), };
8361 DEF_SIMPLE_DESTR(kernel_eval_aux);
8362 DEF_CFUNC (ps0a3, kernel_eval_aux, REF_DESTR(kernel_eval_aux),0)
8363 {
8364   WITH_3_ARGS(functor, args, env);
8365   assert (is_environment (env));
8366   /* Args:
8367      functor: what the car of the form has evaluated to.
8368      args: cdr of form, as yet unevaluated.
8369      env: environment to evaluate in.
8370    */
8371   k_profiling_new_frame(sc, functor);
8372   if(is_type(functor, T_CFUNC))
8373     {
8374       return klink_call_cfunc(sc, functor, env, args);
8375     }
8376   else if(is_type(functor, T_CURRIED))
8377     {
8378       return call_curried(sc, functor, args);
8379     }
8380   else if(is_type(functor, T_TYPEP))
8381     {
8382       /* $$MOVE ME Into something paralleling the other operative calls */
8383       /* $$IMPROVE ME  Check arg number */
8384       WITH_REPORTER(0);
8385       if(!is_pair(args))
8386         { KERNEL_ERROR_1 (sc, "Takes one arg: ", functor); }
8387       return kernel_bool(call_T_typecheck(functor,car(args)));
8388     }
8389   else if(is_type(functor, T_LISTLOOP))
8390     {
8391       return eval_listloop(sc, functor,args);
8392     }
8393   else if(is_type(functor, T_CHAIN))
8394     {
8395       return eval_chain( sc, functor, args );
8396     }
8397   else if ( is_type( functor, T_STORE ))
8398     {
8399       return k_do_store( sc, functor, args );
8400     }
8401   else if ( is_type( functor, T_LOAD ))
8402     {
8403       return k_do_load( sc, functor, args );
8404     }
8405   else if (is_applicative (functor))
8406     {
8407       /* Operation:
8408          Get the underlying operative.
8409          Evaluate arguments (may make frames)
8410          Use the oper on the arguments
8411        */
8412       pko oper = unwrap (sc, functor);
8413       assert (oper);
8414       int4 metrics;
8415       get_list_metrics_aux(args, metrics);
8416       if(metrics[lm_cyc_len] != 0)
8417         {
8418           KERNEL_ERROR_1 (sc, "kernel_eval_aux: Arguments must be a list", args);
8419         }
8420       sc->envir = env;          /* $$IMPROVE ME  Treat this cache better */
8421       CONTIN_2 (dcrry_2CA01VLLA02, kernel_eval, sc, oper, env);
8422 #if USE_TRACING
8423       if (sc->tracing)
8424         {
8425           CONTIN_3 (dcrry_4dotALL, kernel_mapeval, sc, K_NIL, args, env);
8426           CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, args);
8427           putstr (sc, "\nApply to: ");
8428           return K_T;
8429         }
8430       else
8431 #endif
8432         { return kernel_mapeval (sc, K_NIL, args, env); }
8433     }
8434   else
8435     {
8436       KERNEL_ERROR_1 (sc, "eval: can't apply:", functor);
8437     }
8438 }
8439 /*_   , Eval mappers */
8440 /*_    . kernel_mapeval */
8441 /* Evaluate each datum in list arg2, Kernel-returning a list of the results. */
8442 SIG_CHKARRAY(kernel_mapeval) =
8443 { REF_OPER(is_finite_list), REF_OPER(is_finite_list), REF_OPER(is_environment), };
8444 DEF_SIMPLE_DESTR(kernel_mapeval);
8445 DEF_CFUNC (ps0a3, kernel_mapeval, REF_DESTR(kernel_mapeval),0)
8446 {
8447   WITH_REPORTER(0);
8448   WITH_3_ARGS(accum, args, env);
8449   assert (is_environment (env));
8450   /* Arguments:
8451      accum:
8452      * The list of evaluated arguments, in reverse order.
8453      * Purpose: Used as an accumulator.
8454
8455      args: list of forms to be evaluated.
8456      * Precondition: Must be a proper list (is_list must give true)
8457      * When called by itself: The forms that remain yet to be evaluated
8458
8459      env: The environment to evaluate in.
8460   */
8461
8462   /* If there are remaining arguments, arrange to evaluate one,
8463      add the result to accumulator, and return control here. */
8464   if (is_pair (args))
8465     {
8466       /* This can't be converted to a loop because we don't know
8467          whether kernel_eval_aux will create more frames. */
8468       CONTIN_3 (dcrry_3CVLLA01dotAX1,
8469                 kernel_mapeval, sc, accum, cdr (args), env);
8470       return kernel_eval (sc, car (args), env);
8471     }
8472   /* If there are no remaining arguments, reverse the accumulator
8473      and return it.  Can't reverse in place because other
8474      continuations might re-use the same accumulator state.  */
8475   else if (args == K_NIL)
8476     { return reverse (sc, accum); }
8477   else
8478     {
8479       /* This shouldn't be reachable because we check for it being
8480          a list beforehand in kernel_eval_aux. */
8481       errx (4, "mapeval: arguments must be a list:");
8482     }
8483 }
8484
8485 RGSTR(ground,"$bad-sequence",REF_OPER(kernel_sequence))
8486 SIG_CHKARRAY(kernel_sequence) =
8487 { REF_KEY(K_TYCH_DOT), REF_OPER(is_countable_list), };
8488 DEF_SIMPLE_CFUNC(ps0a1,kernel_sequence,0)
8489 {
8490   WITH_1_ARGS(forms);
8491   /* Ultimately return #inert */
8492   /* $$IMPROVE ME This shouldn't accumulate args only to discard
8493      them. */
8494   CONTIN_0_RAW(mk_curried(dcrry_NdotALL, K_INERT, 0), sc);
8495   return kernel_mapeval(sc,K_NIL,forms,sc->envir);
8496 }
8497
8498 /*_    . kernel_mapand_aux */
8499 /* Call proc on each datum in args, Kernel-returning true if all
8500    succeed, otherwise false. */
8501 SIG_CHKARRAY(kernel_mapand_aux) =
8502 { REF_OPER(is_bool),
8503   REF_OPER(is_combiner),
8504   REF_OPER(is_finite_list),
8505 };
8506 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapand_aux,0)
8507 {
8508   WITH_REPORTER(0);
8509   WITH_3_ARGS(ok, proc, args);
8510   /* Arguments:
8511      * succeeded:
8512        * Whether the last invocation of this succeeded.  Initialize with
8513          K_T.
8514
8515      * proc: A boolean combiner (predicate) to apply to these objects
8516
8517      * args: list of objects to apply proc to
8518        * Precondition: Must be a proper list
8519   */
8520   if(ok == K_F)
8521     { return K_F; }
8522   if(ok != K_T)
8523     { KERNEL_ERROR_1(sc, "kernel_mapand_aux: Must be boolean: ", ok); }
8524   /* If there are remaining arguments, arrange to evaluate one and
8525      return control here. */
8526   if (is_pair (args))
8527     {
8528       /* This can't be converted to a loop because we don't know
8529          whether kernel_eval_aux will create more frames. */
8530       CONTIN_2 (dcrry_3VLLdotALL,
8531                 kernel_mapand_aux, sc, proc, cdr (args));
8532       return kernel_eval_aux (sc, proc, car (args), sc->envir);
8533     }
8534   /* If there are no remaining arguments, return true.  */
8535   else if (args == K_NIL)
8536     { return K_T; }
8537   else
8538     {
8539       /* This shouldn't be reachable because we check for it being a
8540          list beforehand. */
8541       errx (4, "mapbool: arguments must be a list:");
8542     }
8543 }
8544
8545 /*_    . kernel_mapand */
8546 SIG_CHKARRAY(kernel_mapand) =
8547 { REF_OPER(is_combiner),
8548   REF_OPER(is_finite_list),
8549 };
8550 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapand,0,simple, "every?/2-xary")
8551 {
8552   WITH_2_ARGS(proc, args);
8553   /* $$IMPROVE ME  Get list metrics here and if we get a circular
8554      list, treat it correctly (How is TBD). */
8555   return kernel_mapand_aux(sc,REF_KEY(K_T), proc, args);
8556 }
8557 /*_    . kernel_mapor_aux */
8558 /* Call proc on each datum in args, Kernel-returning true if all
8559    succeed, otherwise false. */
8560 SIG_CHKARRAY(kernel_mapor_aux) =
8561 { REF_OPER(is_bool),
8562   REF_OPER(is_combiner),
8563   REF_OPER(is_finite_list),
8564 };
8565 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapor_aux,0)
8566 {
8567   WITH_REPORTER(0);
8568   WITH_3_ARGS(ok, proc, args);
8569   /* Arguments:
8570      * succeeded:
8571        * Whether the last invocation of this succeeded.  Initialize with
8572          K_T.
8573
8574      * proc: A boolean combiner (predicate) to apply to these objects
8575
8576      * args: list of objects to apply proc to
8577        * Precondition: Must be a proper list
8578   */
8579   if(ok == K_T)
8580     { return K_T; }
8581   if(ok != K_F)
8582     { KERNEL_ERROR_1(sc, "kernel_mapor_aux: Must be boolean: ", ok); }
8583   /* If there are remaining arguments, arrange to evaluate one and
8584      return control here. */
8585   if (is_pair (args))
8586     {
8587       /* This can't be converted to a loop because we don't know
8588          whether kernel_eval_aux will create more frames. */
8589       CONTIN_2 (dcrry_3VLLdotALL,
8590                 kernel_mapor_aux, sc, proc, cdr (args));
8591       return kernel_eval_aux (sc, proc, car (args), sc->envir);
8592     }
8593   /* If there are no remaining arguments, return false.  */
8594   else if (args == K_NIL)
8595     { return K_F; }
8596   else
8597     {
8598       /* This shouldn't be reachable because we check for it being a
8599          list beforehand. */
8600       errx (4, "mapbool: arguments must be a list:");
8601     }
8602 }
8603 /*_    . kernel_mapor */
8604 SIG_CHKARRAY(kernel_mapor) =
8605 { REF_OPER(is_combiner),
8606   REF_OPER(is_finite_list),
8607 };
8608 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapor,0,simple, "some?/2-xary")
8609 {
8610   WITH_2_ARGS(proc, args);
8611   /* $$IMPROVE ME  Get list metrics here and if we get a circular
8612      list, treat it correctly (How is TBD). */
8613   return kernel_mapor_aux(sc,REF_KEY(K_F), proc, args);
8614 }
8615
8616 /*_   , Kernel combiners */
8617 /*_    . $and? */
8618 /* $$IMPROVE ME  Make referring to curried operatives neater. */
8619 RGSTR(ground, "$and?", REF_OBJ(k_oper_andp))
8620 DEF_BOXED_CURRIED(k_oper_andp,
8621                   dcrry_2ALLVLL,
8622                   REF_OPER(kernel_internal_eval),
8623                   REF_OPER(kernel_mapand));
8624
8625 /*_    . $or? */
8626 RGSTR(ground, "$or?", REF_OBJ(k_oper_orp))
8627 DEF_BOXED_CURRIED(k_oper_orp,
8628                   dcrry_2ALLVLL,
8629                   REF_OPER(kernel_internal_eval),
8630                   REF_OPER(kernel_mapor));
8631
8632 /*_   , map */
8633 /*_    . k_counted_map_aux */
8634 /* $$USE ME MORE Export both to simple: "counted-map1-car"
8635    "counted-map1-cdr" */
8636 pko
8637 k_counted_map_car(klink * sc, int count, pko list, _kt_tag t_enum)
8638 {
8639   int i;
8640   pko rv_result = K_NIL;
8641   for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8642     {
8643       assert(is_pair(list));
8644       pko obj = pair_car(0, list);
8645       rv_result = v2cons (t_enum, pair_car(sc, obj), rv_result);
8646     }
8647
8648   /* Reverse the list in place. */
8649   return unsafe_v2reverse_in_place(K_NIL, rv_result);
8650 }
8651
8652 pko
8653 k_counted_map_cdr(klink * sc, int count, pko list, _kt_tag t_enum)
8654 {
8655   int i;
8656   pko rv_result = K_NIL;
8657   for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8658     {
8659       assert(is_pair(list));
8660       pko obj = pair_car(0, list);
8661       rv_result = v2cons (t_enum, pair_cdr(sc, obj), rv_result);
8662     }
8663
8664   /* Reverse the list in place. */
8665   return unsafe_v2reverse_in_place(K_NIL, rv_result);
8666 }
8667
8668 /* Evaluate COUNT datums in list ARGS, Kernel-returning a list of the
8669    results. */
8670 SIG_CHKARRAY(k_counted_map_aux) =
8671 { REF_OPER(is_finite_list),
8672   REF_OPER(is_integer),
8673   REF_OPER(is_integer),
8674   REF_OPER(is_operative),
8675   REF_OPER(is_finite_list),
8676 };
8677 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_map_aux, 0,simple, "counted-map/5")
8678 {
8679   WITH_5_ARGS(accum, count, len, oper, args);
8680   assert (is_integer (count));
8681   /* $$IMPROVE ME  Check the other args too */
8682
8683   /* Arguments:
8684      accum:
8685      * The list of evaluated arguments, in reverse order.
8686      * Purpose: Used as an accumulator.
8687
8688      count:
8689      * The number of arguments remaining
8690
8691      len:
8692      * The effective length of args.
8693
8694      oper
8695      * An xary operative
8696
8697      args: list of lists of arguments to this.
8698
8699      * Precondition: Must be a proper list (is_finite_list must give
8700        true).  args will not be cyclic, we'll check for and handle
8701        encycling outside of here.
8702   */
8703
8704   /* If there are remaining arguments, arrange to operate on one, cons
8705      the result to accumulator, and return control here. */
8706   if (ivalue (count) > 0)
8707     {
8708       assert(is_pair(args));
8709       int len_v = ivalue(len);
8710       /* This can't be converted to a loop because we don't know
8711          whether kernel_eval_aux will create more frames.
8712
8713          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8714       */
8715       CONTIN_5 (dcrry_5CVLLA01dotAX1,
8716                 k_counted_map_aux, sc, accum,
8717                 mk_integer(ivalue(count) - 1),
8718                 len,
8719                 oper,
8720                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8721
8722       return kernel_eval_aux (sc,
8723                               oper,
8724                               k_counted_map_car(sc, len_v, args, T_PAIR),
8725                               sc->envir);
8726     }
8727   /* If there are no remaining arguments, reverse the accumulator
8728      and return it.  Can't reverse in place because other
8729      continuations might re-use the same accumulator state.  */
8730   else
8731     { return reverse (sc, accum); }
8732 }
8733
8734 /*_   , every? */
8735 /*_    . counted-every?/5 */
8736 SIG_CHKARRAY(k_counted_every) =
8737 { REF_OPER(is_bool),
8738   REF_OPER(is_integer),
8739   REF_OPER(is_integer),
8740   REF_OPER(is_operative),
8741   REF_OPER(is_finite_list),
8742 };
8743 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_every,0,simple,"counted-every?/5")
8744 {
8745   WITH_5_ARGS(ok, count, len, oper, args);
8746   assert (is_bool (ok));
8747   assert (is_integer (count));
8748   assert (is_integer (len));
8749
8750   /* Arguments:
8751      * succeeded:
8752        * Whether the last invocation of this succeeded.  Initialize with
8753          K_T.
8754
8755      count:
8756      * The number of arguments remaining
8757
8758      len:
8759      * The effective length of args.
8760
8761      oper
8762      * An xary operative
8763
8764      args: list of lists of arguments to this.
8765
8766      * Precondition: Must be a proper list (is_finite_list must give
8767        true).  args will not be cyclic, we'll check for and handle
8768        encycling outside of here.
8769   */
8770
8771   if(ok == K_F)
8772     { return K_F; }
8773   if(ok != K_T)
8774     { KERNEL_ERROR_1(sc, "k_counted_every: Must be boolean: ", ok); }
8775
8776   /* If there are remaining arguments, arrange to evaluate one and
8777      return control here. */
8778   if (ivalue (count) > 0)
8779     {
8780       assert(is_pair(args));
8781       int len_v = ivalue(len);
8782       /* This can't be converted to a loop because we don't know
8783          whether kernel_eval_aux will create more frames.
8784
8785          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8786       */
8787       CONTIN_4 (dcrry_4VLLdotALL,
8788                 k_counted_every, sc,
8789                 mk_integer(ivalue(count) - 1),
8790                 len,
8791                 oper,
8792                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8793
8794       return kernel_eval_aux (sc,
8795                               oper,
8796                               k_counted_map_car(sc, len_v, args, T_PAIR),
8797                               sc->envir);
8798     }
8799   /* If there are no remaining arguments, return true.  */
8800   else
8801     { return K_T; }
8802 }
8803
8804 /*_   , some? */
8805 /*_    . counted-some?/5 */
8806 SIG_CHKARRAY(k_counted_some) =
8807 { REF_OPER(is_bool),
8808   REF_OPER(is_integer),
8809   REF_OPER(is_integer),
8810   REF_OPER(is_operative),
8811   REF_OPER(is_finite_list),
8812 };
8813 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_some,0,simple,"counted-some?/5")
8814 {
8815   WITH_5_ARGS(ok, count, len, oper, args);
8816   assert (is_bool (ok));
8817   assert (is_integer (count));
8818   assert (is_integer (len));
8819
8820   if(ok == K_T)
8821     { return K_T; }
8822   if(ok != K_F)
8823     { KERNEL_ERROR_1(sc, "k_counted_some: Must be boolean: ", ok); }
8824
8825   /* If there are remaining arguments, arrange to evaluate one and
8826      return control here. */
8827   if (ivalue (count) > 0)
8828     {
8829       assert(is_pair(args));
8830       int len_v = ivalue(len);
8831       /* This can't be converted to a loop because we don't know
8832          whether kernel_eval_aux will create more frames.
8833
8834          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8835       */
8836       CONTIN_4 (dcrry_4VLLdotALL,
8837                 k_counted_some, sc,
8838                 mk_integer(ivalue(count) - 1),
8839                 len,
8840                 oper,
8841                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8842
8843       return kernel_eval_aux (sc,
8844                               oper,
8845                               k_counted_map_car(sc, len_v, args, T_PAIR),
8846                               sc->envir);
8847     }
8848   /* If there are no remaining arguments, return false.  */
8849   else
8850     { return K_F; }
8851 }
8852
8853
8854 /*_  . Klink top level */
8855 /*_   , kernel_repl */
8856 DEF_CFUNC(ps0a0, kernel_repl, K_NO_TYPE,0)
8857 {
8858   /* If we reached the end of file, this loop is done. */
8859   port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
8860
8861   if (pt->kind & port_saw_EOF)
8862     { return K_INERT; }
8863
8864   putstr (sc, "\n");
8865   putstr (sc, prompt);
8866
8867   assert (is_environment (sc->envir));
8868
8869   /* Arrange another iteration */
8870   CONTIN_0 (kernel_repl, sc);
8871   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
8872   klink_push_cont(sc, REF_OBJ(print_value));
8873 #if USE_TRACING
8874   CONTIN_1 (dcrry_2A01VLL, tracing_say, sc, mk_string("\nGives: "));
8875 #endif
8876   CONTIN_0 (kernel_internal_eval, sc);
8877   CONTIN_0 (kernel_read_internal, sc);
8878   return K_INERT;
8879 }
8880
8881 /*_   , kernel_rel */
8882 static const kt_vector rel_chain =
8883   {
8884     3,
8885     ((pko[])
8886     {
8887       REF_OPER(kernel_read_internal),
8888         REF_OPER(kernel_internal_eval),
8889         REF_OPER(kernel_rel),
8890         }),
8891   };
8892
8893 DEF_CFUNC(ps0a0, kernel_rel, K_NO_TYPE,0)
8894 {
8895   /* If we reached the end of file, this loop is done. */
8896   port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
8897
8898   if (pt->kind & port_saw_EOF)
8899     { return K_INERT; }
8900
8901   assert (is_environment (sc->envir));
8902
8903 #if 1
8904   schedule_chain( sc, &rel_chain);
8905 #else
8906   /* Arrange another iteration */
8907   CONTIN_0 (kernel_rel, sc);
8908   CONTIN_0 (kernel_internal_eval, sc);
8909   CONTIN_0 (kernel_read_internal, sc);
8910 #endif
8911   return K_INERT;
8912 }
8913
8914 /*_   , kernel_internal_eval */
8915 /* Convert the aftermath of kernel_read_internal to something kernel_eval
8916    can accept.  */
8917 /* $$IMPROVE ME realize this as a currier.  But it's not a curried
8918    object as such because it carries no internal data.  */
8919 DEF_CFUNC (ps0a1, kernel_internal_eval, K_ANY,0)
8920 {
8921   pko value = arg1;
8922   if( sc->new_tracing )
8923     { klink_push_dyn_binding( sc, K_TRACING, K_T ); }
8924   return kernel_eval (sc, value, sc->envir);
8925 }
8926
8927 /*_  . Constructing environments */
8928 /*_   , Declarations for built-in environments */
8929 /* These are initialized before they are registered. */
8930 static pko print_lookup_env = 0;
8931 static pko all_builtins_env = 0;
8932 static pko ground_env       = 0;
8933 #define unsafe_env ground_env
8934 #define simple_env ground_env
8935 static pko typecheck_env_syms = 0;
8936
8937 /*_   , What to include */
8938 #ifndef COLLECT_RGSTRS          /* If we're collecting, these files may not
8939                                    have been generated yet */
8940 const kernel_registerable preregister[] =
8941   {
8942     /* $$MOVE ME These others will move into dedicated arrays, and be
8943        combined so that they can all be seen in init.krn but not in
8944        ground env. */
8945 #include "registerables/ground.inc"
8946 #include "registerables/unsafe.inc"
8947 #include "registerables/simple.inc"
8948     /* $$TRANSITIONAL */
8949     { "type?",                       REF_APPL(typecheck),                },
8950     { "do-destructure",              REF_APPL(do_destructure),           },
8951   };
8952
8953 const kernel_registerable all_builtins[] =
8954   {
8955 #include "registerables/all-builtins.inc"
8956   };
8957
8958 const kernel_registerable print_lookup_rgsts[] =
8959 {
8960   { "#f",      REF_KEY(K_F),       },
8961   { "#t",      REF_KEY(K_T),       },
8962   { "#inert",  REF_KEY(K_INERT),   },
8963   { "#ignore", REF_KEY(K_IGNORE),  },
8964
8965   { "$quote",  REF_OPER(arg1),     },
8966
8967   /* $$IMPROVE ME  Add the other quote-like symbols here. */
8968   /* quasiquote, unquote, unquote-splicing */
8969
8970 };
8971
8972 const kernel_registerable typecheck_syms_rgsts[] =
8973   {
8974 #include "registerables/type-keys.inc"
8975   };
8976 #endif
8977
8978
8979 /*_   , How to add */
8980
8981 /* Bind each of an array of kernel_registerables into env. */
8982 void
8983 k_register_list (const kernel_registerable * list, int count, pko env)
8984 {
8985   int i;
8986   assert(list);
8987   assert (is_environment (env));
8988   for (i = 0; i < count; i++)
8989     {
8990       kernel_define (env, mk_symbol (list[i].name), list[i].data);
8991     }
8992 }
8993
8994 /*_   , k_regstrs_to_env */
8995 pko
8996 k_regstrs_to_env(const kernel_registerable * list, int count)
8997 {
8998   pko env = make_new_frame(K_NIL);
8999   k_register_list (list, count, env);
9000   return env;
9001 }
9002
9003 #define K_REGSTRS_TO_ENV(RGSTRS)\
9004   k_regstrs_to_env(RGSTRS, sizeof (RGSTRS) / sizeof (RGSTRS[0]))
9005 /*_   , setup_print_secondary_lookup */
9006 static pko print_lookup_unwraps = 0;
9007 static pko print_lookup_to_xary = 0;
9008 void
9009 setup_print_secondary_lookup(void)
9010 {
9011   /* Quick and dirty: Set up tables corresponding to the ground env
9012      and put the registering stuff in them. */
9013   /* What this really accomplishes is to make prepared lookup tables
9014      available for particular print operations.  Later we'll use a
9015      more general approach and this will become just a cache. */
9016   print_lookup_unwraps = make_new_frame(K_NIL);
9017   print_lookup_to_xary = make_new_frame(K_NIL);
9018   int i;
9019   const kernel_registerable * list = preregister;
9020   int count = sizeof (preregister) / sizeof (preregister[0]);
9021   for (i = 0; i < count; i++)
9022     {
9023       pko obj = list[i].data;
9024       if(is_applicative(obj))
9025         {
9026           kernel_define (print_lookup_unwraps,
9027                          mk_symbol (list[i].name),
9028                          unwrap(0,obj));
9029         }
9030       pko xary = k_to_trivpred(obj);
9031       if((xary != K_NIL) && xary != obj)
9032         {
9033           kernel_define (print_lookup_to_xary,
9034                          mk_symbol (list[i].name),
9035                          xary);
9036         }
9037     }
9038 }
9039
9040 /*_   , make-kernel-standard-environment */
9041 /* Though it would be neater for this to define ground environment if
9042    there is none, that would mean it would need the eval loop and so
9043    couldn't be done early.  So it relies on the ground environment
9044    being already defined.  */
9045 RGSTR(ground,"make-kernel-standard-environment", REF_OPER(mk_std_environment))
9046 DEF_CFUNC(p00a0, mk_std_environment, K_NO_TYPE,T_NO_K)
9047 {
9048   assert(ground_env);
9049   return make_new_frame(ground_env);
9050 }
9051
9052 /*_  . The eval cycle */
9053 /*_   , Helpers */
9054 /*_    . Make an error continuation */
9055 static void
9056 klink_record_error_cont (klink * sc, pko error_continuation)
9057 {
9058   /* Record error continuation. */
9059   kernel_define (sc->envir,
9060                  mk_symbol ("error-continuation"),
9061                  error_continuation);
9062   /* Also record it in interpreter, so built-ins can see it w/o
9063      lookup. */
9064   sc->error_continuation = error_continuation;
9065 }
9066
9067 /*_   , Entry points */
9068 /*_    . Eval cycle that restarts on error */
9069 static void
9070 klink_cycle_restarting (klink * sc, pko combiner)
9071 {
9072   assert(is_combiner(combiner));
9073   assert(is_environment(sc->envir));
9074   /* Arrange to stop if we ever reach where we started. */
9075   klink_push_cont (sc, REF_OPER (k_quit));
9076
9077   /* Grab root continuation. */
9078   kernel_define (sc->envir,
9079                  mk_symbol ("root-continuation"),
9080                  current_continuation (sc));
9081
9082   /* Make main continuation */
9083   klink_push_cont (sc, combiner);
9084
9085   /* Make error continuation on top of main continuation. */
9086   pko error_continuation =
9087     extend_continuation_aux(sc->dump, REF_OPER(kernel_err), sc->envir);
9088
9089   klink_record_error_cont(sc, error_continuation);
9090
9091   /* Conceptually sc->retcode is a keyed dynamic variable that
9092      kernel_err sets. */
9093   sc->retcode = 0;
9094   _klink_cycle (sc);
9095   /* $$RECONSIDER ME Maybe indicate quit value  */
9096 }
9097 /*_    . Eval cycle that terminates on error */
9098 static int
9099 klink_cycle_no_restart (klink * sc, pko combiner)
9100 {
9101   assert(is_combiner(combiner));
9102   assert(is_environment(sc->envir));
9103   /* Arrange to stop if we ever reach where we started. */
9104   klink_push_cont (sc, REF_OPER (k_quit));
9105
9106   /* Grab root continuation. */
9107   kernel_define (sc->envir,
9108                  mk_symbol ("root-continuation"),
9109                  current_continuation (sc));
9110
9111   /* Make error continuation that quits. */
9112   pko error_continuation =
9113     extend_continuation_aux(sc->dump, REF_OPER(kernel_err_return), sc->envir);
9114
9115   klink_record_error_cont(sc, error_continuation);
9116
9117   klink_push_cont (sc, combiner);
9118
9119   /* Conceptually sc->retcode is a keyed dynamic variable that
9120      kernel_err sets.  Actually it's entirely cached in the
9121      interpreter. */
9122   sc->retcode = 0;
9123   _klink_cycle (sc);
9124   return sc->retcode;
9125 }
9126
9127 /*_   , _klink_cycle (Don't use this directly) */
9128 static void
9129 _klink_cycle (klink * sc)
9130 {
9131   pko value = K_INERT;
9132
9133   sc->done = 0;
9134   while (!sc->done)
9135     {
9136       int i = setjmp (sc->pseudocontinuation);
9137       if (i == 0)
9138         {
9139           k_profiling_step();
9140           int got_new_frame = klink_pop_cont (sc);
9141           /* $$RETHINK ME  Is this test still needed?  Could be just
9142              an assertion. */
9143           if (got_new_frame)
9144             {
9145               /* $$IMPROVE ME Instead, a function that governs
9146                  whether to eval. */
9147               if (sc->new_tracing)
9148                 {
9149                   if(_get_type( sc->next_func ) == T_NOTRACE )
9150                     {
9151                       sc->next_func = notrace_comb( sc->next_func );
9152                       goto normal;
9153                     }
9154                   pko tracing =
9155                        klink_find_dyn_binding(sc, K_TRACING );
9156                   /* Now we know the other branch should have been
9157                      taken. */
9158                   if( !tracing || ( tracing == K_F ))
9159                     { goto normal; }
9160
9161                   /* Enqueue a version that will execute without
9162                      tracing.  Its descendants will be traced. */
9163                   CONTIN_0_RAW (mk_notrace(mk_curried(dcrry_1dotALL,
9164                                                       value,
9165                                                       mk_notrace(sc->next_func))),
9166                                  sc );
9167                   switch (_get_type (sc->next_func))
9168                     {
9169                     case T_LOAD:
9170                       putstr (sc, "\nLoad ");
9171                       break;
9172
9173                     case T_STORE:
9174                       putstr (sc, "\nStore ");
9175                       break;
9176
9177                     case T_CURRIED:
9178                       putstr (sc, "\nDecurry ");
9179                       break;
9180
9181                     default:
9182                       /* Print tracing */
9183                       {
9184                         /* Find and print current frame depth */
9185                         int depth = curr_frame_depth (sc->dump);
9186                         char * str = sc->strbuff;
9187                         snprintf (str, STRBUFFSIZE, "\n%d: ", depth);
9188                         putstr (sc, str);
9189                       }
9190                       klink_push_dyn_binding (sc, K_TRACING, K_F);
9191                       putstr (sc, "Eval: ");
9192                       value = kernel_print_sexp (sc,
9193                                                  cons (sc->next_func, value),
9194                                                  K_INERT);
9195                     }
9196                 }
9197               else
9198                 {
9199                 normal:
9200                   value = kernel_eval_aux (sc, sc->next_func, value, sc->envir);
9201                 }
9202
9203             }
9204           /* Stop looping if stack is empty. */
9205           else
9206             { break; }
9207         }
9208       else
9209         /* Otherwise something jumped to a continuation.  Get the
9210            value and keep looping.  */
9211         {
9212           value = sc->value;
9213         }
9214     }
9215   /* In case we're called nested in another _klink_cycle, don't
9216      affect it. */
9217   sc->done = 0;
9218 }
9219
9220 /*_  . Vtable interface */
9221 /* initialization of Klink */
9222 #if USE_INTERFACE
9223
9224 static struct klink_interface vtbl =
9225   {
9226     klink_define,
9227     mk_mutable_pair,
9228     mk_pair,
9229     mk_integer,
9230     mk_real,
9231     mk_symbol,
9232     mk_string,
9233     mk_counted_string,
9234     mk_character,
9235     mk_vector,
9236     putstr,
9237     putcharacter,
9238
9239     is_string,
9240     string_value,
9241     is_number,
9242     nvalue,
9243     ivalue,
9244     rvalue,
9245     is_integer,
9246     is_real,
9247     is_character,
9248     charvalue,
9249     is_finite_list,
9250     is_vector,
9251     list_length,
9252     vector_len,
9253     fill_vector,
9254     vector_elem,
9255     set_vector_elem,
9256     is_port,
9257
9258     is_pair,
9259     pair_car,
9260     pair_cdr,
9261     set_car,
9262     set_cdr,
9263
9264     is_symbol,
9265     symname,
9266
9267     is_continuation,
9268     is_environment,
9269     is_immutable,
9270     setimmutable,
9271
9272     klink_load_file,
9273     klink_load_string,
9274   };
9275 #if USE_DL
9276 /* $$MOVE ME  Later after I separate some headers
9277    This belongs in dynload.c, could be just:
9278    SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9279    DEF_SIMPLE_APPLICATIVE(ps0a1,klink_load_ext,0,ground, "load-extension") {...}
9280  */
9281 RGSTR(ground, "load-extension", REF_APPL(klink_load_ext))
9282 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9283 DEF_SIMPLE_DESTR(klink_load_ext);
9284 DEF_CFUNC_PSYCNAME(ps0a1,klink_load_ext, REF_DESTR(klink_load_ext),0);
9285 DEF_BOXED_APPLICATIVE(klink_load_ext, REF_OPER (klink_load_ext));
9286
9287 #endif
9288
9289 #endif
9290
9291 /*_  . Initializing Klink */
9292 /*_   , Allocate and initialize */
9293
9294 klink *
9295 klink_alloc_init (FILE * in, FILE * out)
9296 {
9297   klink *sc = (klink *) GC_MALLOC (sizeof (klink));
9298   if (!klink_init (sc, in, out))
9299     {
9300       GC_FREE (sc);
9301       return 0;
9302     }
9303   else
9304     {
9305       return sc;
9306     }
9307 }
9308
9309 /*_   , Initialization without allocation */
9310 int
9311 klink_init (klink * sc, FILE * in, FILE * out)
9312 {
9313   /* Init stack first, just in case something calls _klink_error_1. */
9314   dump_stack_initialize (sc);
9315   /* Initialize ports early in case something prints. */
9316   /* $$IMPROVE ME  Should accept general ports of appropriate in/out. */
9317   klink_set_input_port_file (sc, in);
9318   klink_set_output_port_file (sc, out);
9319
9320 #if USE_INTERFACE
9321   /* Why do we need this field if there is a static table? */
9322   sc->vptr = &vtbl;
9323 #endif
9324
9325   sc->tracing = 0;
9326   sc->new_tracing = 0;
9327
9328   if(!oblist)
9329     { oblist = oblist_initial_value (); }
9330
9331
9332   /* Add the Kernel built-ins */
9333   if(!print_lookup_env)
9334     {
9335       print_lookup_env = K_REGSTRS_TO_ENV(print_lookup_rgsts);
9336     }
9337   if(!all_builtins_env)
9338     {
9339       all_builtins_env = K_REGSTRS_TO_ENV(all_builtins);
9340     }
9341   if(!typecheck_env_syms)
9342     { typecheck_env_syms = K_REGSTRS_TO_ENV(typecheck_syms_rgsts); }
9343   if(!ground_env)
9344     {
9345       /** Register objects from hard-coded list. **/
9346       ground_env = K_REGSTRS_TO_ENV(preregister);
9347       /* $$TRANSITIONAL  Set up special lookup tables related to preregister. */
9348       setup_print_secondary_lookup();
9349       /** Bind certain objects that we make at init time.  **/
9350       kernel_define (ground_env,
9351                      mk_symbol ("print-lookup-env"),
9352                      print_lookup_env);
9353       kernel_define (unsafe_env,
9354                      mk_symbol ("typecheck-special-syms"),
9355                      typecheck_env_syms);
9356
9357       /** Read some definitions from a prolog **/
9358       /* We need an envir before klink_call, because that defines a
9359          few things.  Those bindings are specific to one instance of
9360          the interpreter so they do not belong in anything shared such
9361          as ground_env.  */
9362       /* $$IMPROVE ME Something in the call chain (klink_call?) should
9363          guarantee an environment.  Needn't have anything in it to
9364          begin with.  */
9365       sc->envir = make_new_frame(K_NIL);
9366
9367       /* Can't easily merge this with klink_load_named_file.  Two
9368          difficulties: it uses klink_cycle_restarting while klink_call
9369          uses klink_cycle_no_restart, and here we need to control the
9370          load environment.  */
9371       pko p = port_from_filename (InitFile, port_file | port_input);
9372       if (p == K_NIL) { return 0; }
9373
9374       /* We can't use k_get_mod_fm_port to manage parameters because
9375          later we will need the environment to have several parents:
9376          ground, simple, unsafe, possibly more. */
9377       /* Params: `into' =  ground environment */
9378       /* We can't share this with the previous frame-making, because
9379          it should not define in the same environment.  */
9380       pko params = make_new_frame(K_NIL);
9381       kernel_define (params, mk_symbol ("into"), ground_env);
9382       pko env = make_new_frame(ground_env);
9383       kernel_define (env, mk_symbol ("module-parameters"), params);
9384       int retcode = klink_call(sc,
9385                                REF_OPER(load_from_port),
9386                                LIST2(p, env));
9387       if(retcode) { return 0; }
9388
9389       /* The load will have written various things into ground
9390          environment.  sc->envir is unsuitable now because it is this
9391          load's environment. */
9392     }
9393
9394   assert (is_environment (ground_env));
9395   sc->envir = make_new_frame(ground_env);
9396
9397 #if 1                           /* Transitional.  Leave this on for the moment */
9398   /* initialization of global pointers to special symbols */
9399   sc->QUOTE = mk_symbol ("quote");
9400   sc->QQUOTE = mk_symbol ("quasiquote");
9401   sc->UNQUOTE = mk_symbol ("unquote");
9402   sc->UNQUOTESP = mk_symbol ("unquote-splicing");
9403   sc->COLON_HOOK = mk_symbol ("*colon-hook*");
9404   sc->SHARP_HOOK = mk_symbol ("*sharp-hook*");
9405 #endif
9406   return 1;
9407 }
9408
9409 /*_   , Deinit */
9410 void
9411 klink_deinit (klink * sc)
9412 {
9413   sc->envir = K_NIL;
9414   sc->value = K_NIL;
9415 }
9416 /*_  . Using Klink from C */
9417 /*_   , To set ports */
9418 void
9419 klink_set_input_port_file (klink * sc, FILE * fin)
9420 {
9421   klink_push_dyn_binding(sc,K_INPORT,port_from_file (fin, port_input));
9422 }
9423
9424 void
9425 klink_set_input_port_string (klink * sc, char *start, char *past_the_end)
9426 {
9427   klink_push_dyn_binding(sc,
9428                          K_INPORT,
9429                          port_from_string (start, past_the_end, port_input));
9430 }
9431
9432 void
9433 klink_set_output_port_file (klink * sc, FILE * fout)
9434 {
9435   klink_push_dyn_binding(sc,K_OUTPORT,port_from_file (fout, port_output));
9436 }
9437
9438 void
9439 klink_set_output_port_string (klink * sc, char *start, char *past_the_end)
9440 {
9441   klink_push_dyn_binding(sc,
9442                          K_OUTPORT,
9443                          port_from_string (start, past_the_end, port_output));
9444 }
9445 /*_   , To set external data */
9446 void
9447 klink_set_external_data (klink * sc, void *p)
9448 {
9449   sc->ext_data = p;
9450 }
9451
9452
9453 /*_   , To load */
9454 /*_    . Load file (C) */
9455 /*_     , Worker */
9456 void
9457 klink_load_port (klink * sc, pko p, int interactive)
9458 {
9459   if (p == K_NIL)
9460     {
9461       sc->retcode = 2;
9462       return;
9463     }
9464   else
9465     {
9466       klink_push_dyn_binding(sc,K_INPORT,p);
9467     }
9468
9469   {
9470     pko combiner =
9471       interactive ?
9472       REF_OPER (kernel_repl) :
9473       REF_OPER (kernel_rel);
9474     klink_cycle_restarting (sc, combiner);
9475   }
9476 }
9477
9478 /*_     , klink_load_file */
9479 void
9480 klink_load_file (klink * sc, FILE * fin)
9481 {
9482   klink_load_port (sc,
9483                    port_from_file (fin, port_file | port_input),
9484                    (fin == stdin));
9485 }
9486
9487 /*_     , klink_load_named_file */
9488 void
9489 klink_load_named_file (klink * sc, FILE * fin, const char *filename)
9490 {
9491   klink_load_port(sc,
9492                   port_from_filename (filename, port_file | port_input),
9493                   (fin == stdin));
9494 }
9495
9496 /*_    . load string (C) */
9497
9498 void
9499 klink_load_string (klink * sc, const char *cmd)
9500 {
9501   klink_load_port(sc,
9502                   port_from_string ((char *)cmd,
9503                                     (char *)cmd + strlen (cmd),
9504                                     port_input | port_string),
9505                   0);
9506 }
9507
9508 /*_   , Apply combiner */
9509 /* sc is presumed to be already set up.
9510    The final value or error argument is in sc->value.
9511    The return code is duplicated in sc->retcode.
9512  */
9513 int
9514 klink_call (klink * sc, pko func, pko args)
9515 {
9516   klink_cycle_no_restart (sc,
9517                           mk_curried(dcrry_NdotALL,args,func));
9518   return sc->retcode;
9519 }
9520
9521 /*_   , Eval form */
9522 /* This is completely unexercised. */
9523
9524 int
9525 klink_eval (klink * sc, pko obj)
9526 {
9527   klink_cycle_no_restart(sc,
9528                          mk_curried(dcrry_2dotALL,
9529                                     LIST2(obj,sc->envir),
9530                                     REF_OPER(kernel_eval)));
9531   return sc->retcode;
9532 }
9533
9534 /*_  . Main (if standalone) */
9535 #if STANDALONE
9536 /*_   , Mac */
9537 #if defined(__APPLE__) && !defined (OSX)
9538 int
9539 main ()
9540 {
9541   extern MacTS_main (int argc, char **argv);
9542   char **argv;
9543   int argc = ccommand (&argv);
9544   MacTS_main (argc, argv);
9545   return 0;
9546 }
9547
9548 /*_   , General */
9549 int
9550 MacTS_main (int argc, char **argv)
9551 {
9552 #else
9553 int
9554 main (int argc, char **argv)
9555 {
9556 #endif
9557   klink sc;
9558   FILE *fin = 0;
9559   char *file_name = 0;          /* Was InitFile */
9560   int retcode;
9561   int isfile = 1;
9562   GC_INIT ();
9563   if (argc == 1)
9564     {
9565       printf (banner);
9566     }
9567   if (argc == 2 && strcmp (argv[1], "-?") == 0)
9568     {
9569       printf ("Usage: klink -?\n");
9570       printf ("or:    klink [<file1> <file2> ...]\n");
9571       printf ("followed by\n");
9572       printf ("          -1 <file> [<arg1> <arg2> ...]\n");
9573       printf ("          -c <Kernel commands> [<arg1> <arg2> ...]\n");
9574       printf ("assuming that the executable is named klink.\n");
9575       printf ("Use - as filename for stdin.\n");
9576       return 1;
9577     }
9578
9579   /* Make error_continuation semi-safe until it's properly set.  */
9580   sc.error_continuation = 0;
9581   int i = setjmp (sc.pseudocontinuation);
9582   if (i == 0)
9583     {
9584       if (!klink_init (&sc, stdin, stdout))
9585         {
9586           fprintf (stderr, "Could not initialize!\n");
9587           return 2;
9588         }
9589     }
9590   else
9591     {
9592       fprintf (stderr, "Kernel error encountered while initializing!\n");
9593       return 3;
9594     }
9595   argv++;
9596   /* $$IMPROVE ME Maybe use get_opts instead. */
9597   while(1)
9598     {
9599       /* $$IMPROVE ME Add a principled way of sometimes including
9600          filename defined in environment.  Eg getenv
9601          ("KLINKINIT").  */
9602       file_name = *argv;
9603       argv++;
9604       if(!file_name) { break; }
9605       if (strcmp (file_name, "-") == 0)
9606         {
9607           fin = stdin;
9608         }
9609       else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
9610         {
9611           pko args = K_NIL;
9612           /* $$FACTOR ME This is a messy way to distinguish command
9613              string from filename string */
9614           isfile = (file_name[1] == '1');
9615           file_name = *argv++;
9616           if (strcmp (file_name, "-") == 0)
9617             {
9618               fin = stdin;
9619             }
9620           else if (isfile)
9621             {
9622               fin = fopen (file_name, "r");
9623             }
9624
9625           /* Put remaining command-line args into *args* in envir. */
9626           for (; *argv; argv++)
9627             {
9628               pko value = mk_string (*argv);
9629               args = mcons (value, args);
9630             }
9631           args = unsafe_v2reverse_in_place (K_NIL, args);
9632           /* Instead, use (command-line) as accessor and provide the
9633              whole command line as a list of strings.  */
9634           kernel_define (sc.envir, mk_symbol ("*args*"), args);
9635
9636         }
9637       else
9638         {
9639           fin = fopen (file_name, "r");
9640         }
9641       if (isfile && fin == 0)
9642         {
9643           fprintf (stderr, "Could not open file %s\n", file_name);
9644         }
9645       else
9646         {
9647           if (isfile)
9648             {
9649               /* $$IMPROVE ME Use klink_load_named_file, replacing the
9650                  file-opening code, so we can report filename  */
9651               klink_load_file (&sc, fin);
9652             }
9653           else
9654             {
9655               klink_load_string (&sc, file_name);
9656             }
9657           if (!isfile || fin != stdin)
9658             {
9659               if (sc.retcode != 0)
9660                 {
9661                   fprintf (stderr, "Errors encountered reading %s\n",
9662                            file_name);
9663                 }
9664               if (isfile)
9665                 {
9666                   fclose (fin);
9667                 }
9668             }
9669         }
9670     }
9671
9672   if (argc == 1)
9673     {
9674       /* $$MAKE ME CLEANER Quick and dirty for now, we make an
9675          environment for this but let everything else modify ground
9676          env.  I'd like to be more correct about that. */
9677       /* Make an interactive environment over ground_env. */
9678       new_frame_in_env (&sc, sc.envir);
9679       klink_load_file (&sc, stdin);
9680     }
9681   retcode = sc.retcode;
9682   klink_deinit (&sc);
9683
9684   return retcode;
9685 }
9686
9687 #endif
9688
9689 /*_ , Footers */
9690 /*
9691 Local variables:
9692 c-file-style: "gnu"
9693 mode: allout
9694 End:
9695 */