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