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, ps0a5, destructure_resume);
 698 FORWARD_DECL_PRED (extern, is_any);
 699 FORWARD_DECL_T_PRED (extern, is_environment);
 700 FORWARD_DECL_PRED (extern, is_integer);
 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 (LIST5 (mk_load_ix (1, 0),
2752                           mk_load_ix (0, 0),
2753                           typespec,
2754                           kernel_bool (saw_optional),
2755                           K_NIL)),
2756           mk_store (K_ANY, 1),
2757           /* V= forced-argobject */
2758           REF_OPER (force),
2759           /* ^V= (argobject) */
2760           mk_load (LIST1 (argobject)),
2761           mk_store (K_ANY, 4)
2762           /* ^V= result-so-far */
2763           );
2764 }
2765 /*_     , destructure_make_ops_to_bool */
2766 pko
2767 destructure_make_ops_to_bool
2768 (pko argobject, pko op_on_argobject)
2769 {
2770   assert (is_combiner (op_on_argobject));
2771   return
2772     /* Operations to run, in reverse order. */
2773     LIST6(
2774           /* ^V= result-so-far */
2775           REF_OPER (destructure_by_bool),
2776           /* V= (result-so-far bool spec) */
2777           mk_load (LIST3 (mk_load_ix (1, 0),
2778                           argobject,
2779                           mk_load_ix (0, 0))),
2780           mk_store (K_ANY, 1),
2781           /* V= bool */
2782           op_on_argobject,
2783           /* ^V= (argobject) */
2784           mk_load (LIST1 (argobject)),
2785           mk_store (K_ANY, 4)
2786           /* ^V= result-so-far */
2787           );
2788 }
2789 /*_     , destructure */
2790 /* Callers: past_end should point into the same array as *outarray.
2791    It will indicate the maximum number number of elements we may
2792    write.  The return value is the remainder of the outarray if
2793    successful, otherwise NULL.
2794    The meaning of extra_result depends on the return value:
2795    * On success, it's unused.
2796    * On destr_err, it will hold an error object.
2797    * On destr_must_call_k, it will hold a list of operations.
2798 */
2799 kt_destr_outcome
2800 destructure
2801 (klink * sc, pko argobject, pko typespec, pko ** outarray,
2802  pko * past_end, pko * extra_result, int saw_optional)
2803 {
2804   if(*outarray == past_end)
2805     {
2806       /* $$IMPROVE ME  Treat this error like other mismatches */
2807       KERNEL_ERROR_0 (sc, "destructure: past end of output array");
2808     }
2809   if(_get_type(typespec) == T_DESTRUCTURE)
2810     {
2811       WITH_UNBOXED_UNSAFE(pdata,kt_destr_list,typespec);
2812       pko * ar_typespec = pdata->cvec.els;
2813       int left = pdata->cvec.len;
2814       int el_num = 0;
2815       for( ; left; ar_typespec++, left--)
2816         {
2817           pko tych = *ar_typespec;
2818
2819           /**** Check for special keys ****/
2820           if(tych == REF_KEY(K_TYCH_DOT))
2821             {
2822               if(left != 2)
2823                 {
2824                   KERNEL_ERROR_0 (sc, "destructure: After dot there must "
2825                                   "be exactly one typespec");
2826                 }
2827               else
2828                 {
2829                   kt_destr_outcome outcome =
2830                     destructure(sc, argobject,
2831                                 ar_typespec[1],
2832                                 outarray,
2833                                 past_end,
2834                                 extra_result,
2835                                 0);
2836                   /* If there's error, contribute to describing its
2837                      location. */
2838                   if (outcome == destr_err)
2839                     {
2840                       *extra_result =
2841                         LISTSTAR3(mk_integer(el_num),
2842                                   mk_symbol("dot"),
2843                                   *extra_result);
2844                     }
2845                   return outcome;
2846                 }
2847             }
2848           if(tych == REF_KEY(K_TYCH_OPTIONAL))
2849             {
2850               if(saw_optional)
2851                 {
2852                   KERNEL_ERROR_0 (sc, "destructure: Can't have two optionals");
2853                 }
2854               else
2855                 {
2856                   saw_optional = 1;
2857                   continue;
2858                 }
2859             }
2860           /*** Manage stepping ***/
2861           if(!is_pair(argobject))
2862             {
2863               if(saw_optional)
2864                 {
2865                   *outarray[0] = K_INERT;
2866                   ++*outarray;
2867                 }
2868               else
2869                 if (is_promise (argobject))
2870                   {
2871                     WITH_BOX_TYPE(tag,typespec);
2872                     pko new_typespec =
2873                       mk_foresliced_basvector (typespec,
2874                                                pdata->cvec.len - left,
2875                                                *tag);
2876                     *extra_result =
2877                       destructure_make_ops (argobject,
2878                                             new_typespec,
2879                                             saw_optional);
2880                     return destr_must_call_k;
2881                   }
2882               else
2883                 {
2884                   /* $$IMPROVE ME These symbols should be made
2885                      only once. */
2886                   /* $$IMPROVE ME These location operations should be
2887                      encapped. */
2888                   *extra_result =
2889                     LIST2(mk_integer(el_num), mk_symbol("too-few"));
2890                   return destr_err;
2891                 }
2892             }
2893           else
2894             {
2895               pko c = pair_car(0,argobject);
2896               argobject = pair_cdr(0,argobject);
2897               el_num++;
2898               int outcome =
2899                 destructure (sc,
2900                              c,
2901                              tych,
2902                              outarray,
2903                              past_end,
2904                              extra_result,
2905                              0);
2906               switch (outcome)
2907                 {
2908                 case destr_success:
2909                   /* Success keeps exploring */
2910                   break;
2911                 case destr_err:
2912                   /* Simple error ends exploration */
2913                   /* Contribute to describing its location. */
2914                   *extra_result =
2915                     LISTSTAR2(mk_integer(el_num),*extra_result);
2916                   return destr_err;
2917                 case destr_must_call_k:
2918                   /* must-call-K schedules to resume in this state,
2919                      then returns. */
2920                   {
2921                     WITH_BOX_TYPE(tag,typespec);
2922                     /* $$IMPROVE ME If length = 0, this is just
2923                        REF_OPER (is_null) */
2924                     pko new_typespec =
2925                       mk_foresliced_basvector (typespec,
2926                                                pdata->cvec.len - left + 1,
2927                                                *tag);
2928                     pko raw_oplist = *extra_result;
2929                     *extra_result =
2930                       LISTSTAR4 (
2931                                  REF_OPER (destructure_resume),
2932                                  /* ^V= (result-so-far argobject spec
2933                                     optional?) */
2934                                  mk_load (LIST5 (mk_load_ix (0, 0),
2935                                                  argobject,
2936                                                  new_typespec,
2937                                                  kernel_bool (saw_optional),
2938                                                  K_NIL)),
2939                                  mk_store (K_ANY, 1),
2940                                  /* ^V= result-so-far */
2941                                  raw_oplist);
2942                     return destr_must_call_k;
2943                   }
2944                 default:
2945                   errx (7, "Unrecognized enumeration");
2946                 }
2947             }
2948         }
2949       if(argobject == K_NIL)
2950         { return destr_success; }
2951       else if (is_promise (argobject))
2952         {
2953           pko new_typespec = REF_OPER (is_null);
2954           *extra_result =
2955             destructure_make_ops (argobject,
2956                                   new_typespec,
2957                                   saw_optional);
2958           return destr_must_call_k;
2959         }
2960       else
2961         {
2962           *extra_result =
2963             LIST2(mk_integer(el_num), mk_symbol("too-many"));
2964           return destr_err;
2965         }
2966
2967     }
2968   else if (!no_call_k(typespec))
2969     {
2970       if (!is_combiner (typespec))
2971         {
2972           KERNEL_ERROR_0 (sc, "spec must be a combiner");
2973           /* NOTREACHED */
2974         }
2975
2976       *extra_result =
2977         destructure_make_ops_to_bool (argobject, typespec);
2978       return destr_must_call_k;
2979     }
2980   else if(typecheck(sc, argobject, typespec))
2981     {
2982       *outarray[0] = argobject;
2983       ++*outarray;
2984       return destr_success;
2985     }
2986   else if (is_promise (argobject))
2987     {
2988       *extra_result =
2989         destructure_make_ops (argobject,
2990                               typespec,
2991                               0);
2992       return destr_must_call_k;
2993     }
2994   else
2995     {
2996       pko result = where_typemiss(sc, argobject, typespec);
2997       result = result ? result : mk_string("Couldn't find the typemiss");
2998       *extra_result = result;
2999       return destr_err;
3000     }
3001 }
3002 /*_     , destructure_to_array */
3003 void
3004 destructure_to_array
3005 (klink * sc,
3006  pko obj,                      /* Object to extract values from */
3007  pko type,                     /* Type spec */
3008  pko * array,                  /* Array to be filled */
3009  size_t length,                /* Maximum length of that array */
3010  pko resume_op,             /* Combiner to schedule if we resume */
3011  pko resume_data            /* Extra data to the resume op */
3012  )
3013 {
3014   if (type == K_NO_TYPE)
3015     { return; }
3016   pko * orig_array = array;
3017   pko extra_result = 0;
3018   kt_destr_outcome outcome =
3019     destructure (sc, obj, type, &array, array + length, &extra_result, 0);
3020   switch (outcome)
3021     {
3022     case destr_success:
3023       return;
3024       /* NOTREACHED */
3025     case destr_err:
3026       {
3027         assert (extra_result);
3028         /* $$PUNT: For now, use resume_data as marker because it is
3029            often the cfunc being called. */
3030         _klink_error_1 (sc, "type mismatch:",
3031                         LIST2(resume_data, extra_result));
3032         return;
3033       }
3034       /* NOTREACHED */
3035
3036     case destr_must_call_k:
3037       {
3038         /* Arrange for a resume. */
3039         int read_len = array - orig_array;
3040         pko result_so_far = mk_destr_result (read_len, orig_array, K_NIL);
3041         assert (is_combiner (resume_op));
3042         CONTIN_0_RAW (resume_op, sc);
3043         /* ^^^V= (final-destr_result . resume_data) */
3044         CONTIN_0_RAW (mk_load (LISTSTAR2 (mk_load_ix (0, 0),
3045                                           resume_data)),
3046                       sc);
3047         CONTIN_0_RAW (mk_store (K_ANY, 1), sc);
3048         /* ^^^V= final-destr_result */
3049         schedule_rv_list (sc, extra_result);
3050         /* ^^^V= current-destr_result */
3051         /* $$ENCAPSULATE ME */
3052         sc->value = result_so_far;
3053         longjmp (sc->pseudocontinuation, 1);
3054       /* NOTREACHED */
3055         return;
3056       }
3057       /* NOTREACHED */
3058
3059     default:
3060       errx (7, "Unrecognized enumeration");
3061     }
3062 }
3063
3064 /*_     , destructure_resume */
3065 SIG_CHKARRAY (destructure_resume) =
3066 {
3067   REF_OPER (is_destr_result),
3068   K_ANY,
3069   K_TY_DESTRSPEC,
3070   REF_OPER (is_bool),
3071   K_ANY,
3072 };
3073 DEF_SIMPLE_CFUNC (ps0a5, destructure_resume, 0)
3074 {
3075   WITH_5_ARGS (destr_result, argobject, typespec, opt_p, err_val);
3076   const int max_args = 5;
3077   pko arg_array [max_args];
3078   pko * outarray = arg_array;
3079   pko extra_result = 0;
3080   kt_destr_outcome outcome =
3081     destructure (sc,
3082                  argobject,
3083                  typespec,
3084                  &outarray,
3085                  arg_array + max_args,
3086                  &extra_result,
3087                  (opt_p == K_T));
3088   switch (outcome)
3089     {
3090     case destr_success:
3091       {
3092         int new_len = outarray - arg_array;
3093         return
3094           mk_destr_result_add (destr_result, new_len, arg_array);
3095       }
3096       /* NOTREACHED */
3097     case destr_err:
3098       /* $$PUNT: For now, no marker, just location data. */
3099       KERNEL_ERROR_1 (sc, "type mismatch:", extra_result);
3100       /* NOTREACHED */
3101
3102     case destr_must_call_k:
3103       {
3104         /* Arrange for another force+resume. This will feed whatever
3105            was there before. */
3106         int read_len = outarray - arg_array;
3107         pko result_so_far =
3108           mk_destr_result_add (destr_result,
3109                                read_len,
3110                                arg_array);
3111         schedule_rv_list (sc, extra_result);
3112         return result_so_far;
3113       }
3114       /* NOTREACHED */
3115
3116     default:
3117       errx (7, "Unrecognized enumeration");
3118       /* NOTREACHED */
3119     }
3120 }
3121 /*_     , do-destructure */
3122 /* We don't have a typecheck typecheck predicate yet, so accept
3123    anything for arg2. Really it can be what typecheck accepts or
3124    T_DESTRUCTURE, checked recursively.  */
3125 SIG_CHKARRAY (do_destructure) = { K_ANY, K_ANY, };
3126 DEF_SIMPLE_APPLICATIVE (ps0a2, do_destructure,T_NO_K,unsafe,"do-destructure")
3127 {
3128   WITH_2_ARGS (argobject,typespec);
3129   int len = destructure_how_many (typespec);
3130   pko vec = mk_vector (len, K_NIL);
3131   WITH_UNBOXED_UNSAFE (pdata,kt_destr_list,vec);
3132   destructure_to_array
3133     (sc,
3134      argobject,
3135      typespec,
3136      pdata->cvec.els,
3137      len,
3138      REF_OPER (destr_result_to_vec),
3139      K_NIL);
3140
3141   return vec;
3142 }
3143
3144 /*_   , C functions as objects */
3145 /*_    . Structs */
3146 /*_     , store */
3147 typedef struct kt_opstore
3148 {
3149   pko destr;                    /* Often a T_DESTRUCTURE */
3150   int frame_depth;
3151 } kt_opstore;
3152
3153 /*_    . cfunc */
3154 DEF_T_PRED (is_cfunc, T_CFUNC,no,"");
3155
3156 #if 0
3157 /* For external use, if some code ever wants to make these objects
3158    dynamically. */
3159 /* $$MAKE ME SAFE Set type-check fields */
3160 pko
3161 mk_cfunc (const kt_cfunc * f)
3162 {
3163   typedef kt_boxed_cfunc TT;
3164   errx(4, "Don't use mk_cfunc yet")
3165   TT *pbox = GC_MALLOC (sizeof (TT));
3166   pbox->type = T_CFUNC;
3167   pbox->data = *f;
3168   return PTR2PKO(pbox);
3169 }
3170 #endif
3171
3172 INLINE const kt_cfunc *
3173 get_cfunc_func (pko p)
3174 {
3175   WITH_PSYC_UNBOXED(kt_cfunc,p,T_CFUNC,0)
3176   return pdata;
3177 }
3178 /*_    . cfunc_resume */
3179 /*_     , Create */
3180 /*_      . mk_cfunc_resume */
3181 pko
3182 mk_cfunc_resume (pko cfunc)
3183 {
3184   ALLOC_BOX_PRESUME (kt_cfunc, T_CFUNC_RESUME);
3185   pbox->data = *get_cfunc_func (cfunc);
3186   return PTR2PKO(pbox);
3187 }
3188
3189 /*_    . Curried functions */
3190 /*_     , About objects */
3191 static INLINE int
3192 is_curried (pko p)
3193 { return is_type (p, T_CURRIED); }
3194
3195 INLINE pko
3196 mk_curried (decurrier_f decurrier, pko args, pko next)
3197 {
3198   ALLOC_BOX(pbox,T_CURRIED,kt_boxed_curried);
3199   pbox->data.decurrier = decurrier;
3200   pbox->data.args      = args;
3201   pbox->data.next      = next;
3202   pbox->data.argcheck  = 0;
3203   return PTR2PKO(pbox);
3204 }
3205 /*_     , Operations */
3206 /*_      . call_curried */
3207 pko
3208 call_curried(klink * sc, pko curried, pko value)
3209 {
3210   WITH_PSYC_UNBOXED(kt_curried,curried,T_CURRIED,sc);
3211
3212   /* First schedule the next one if there is any */
3213   if(pdata->next)
3214     {
3215       klink_push_cont(sc, pdata->next);
3216     }
3217
3218   /* Then call the decurrier with the data field and the value,
3219      returning its result. */
3220   return pdata->decurrier (sc, pdata->args, value);
3221 }
3222
3223 /*_    . Chains */
3224 /*_     , Struct */
3225 typedef kt_vector kt_chain;
3226
3227 /*_     , Creating */
3228 /*_      . Statically */
3229 #define SIG_CHAIN(C_NAME) pko CHAIN_NAME(C_NAME)[]
3230 #define DEF_CHAIN(NAME, ARRAY_NAME)                     \
3231   DEF_VEC(T_CHAIN | T_IMMUTABLE, NAME, ARRAY_NAME)
3232
3233 #define DEF_SIMPLE_CHAIN(C_NAME)                        \
3234   RGSTR(all-builtins,"C-" #C_NAME, REF_OPER (C_NAME))   \
3235   DEF_CHAIN(OPER(C_NAME), CHAIN_NAME(C_NAME))
3236
3237
3238 /*_     , Operations */
3239 void
3240 schedule_chain(klink * sc, const kt_vector * chain)
3241 {
3242   _kt_spagstack dump = sc->dump;
3243   int i;
3244   for(i = chain->len - 1; i >= 0; i--)
3245     {
3246       pko comb = chain->els[i];
3247       /* If frame_depth is unassigned, assign it. */
3248       if(_get_type(comb) == T_STORE)
3249         {
3250           WITH_UNBOXED_UNSAFE( pdata, kt_opstore, comb );
3251           if(pdata->frame_depth < 0)
3252             { pdata->frame_depth = chain->len - 1 - i; }
3253         }
3254       /* Push it as a combiner */
3255       dump = klink_push_cont_aux(dump, comb, sc->envir);
3256     }
3257   sc->dump = dump;
3258 }
3259
3260 /*_      . eval_chain */
3261 pko
3262 eval_chain( klink * sc, pko functor, pko value )
3263 {
3264   WITH_PSYC_UNBOXED( kt_vector, functor, T_CHAIN, 0 );
3265   schedule_chain( sc, pdata);
3266   return value;
3267 }
3268 /*_      . schedule_rv_list */
3269 void
3270 schedule_rv_list (klink * sc, pko list)
3271 {
3272   WITH_REPORTER (sc);
3273   _kt_spagstack dump = sc->dump;
3274   for(; list != K_NIL; list = cdr (list))
3275     {
3276       pko comb = car (list);
3277       /* $$PUNT If frame_depth is unassigned, assign it. */
3278
3279       /* Push it as a combiner */
3280       dump = klink_push_cont_aux(dump, comb, sc->envir);
3281     }
3282   sc->dump = dump;
3283 }
3284 /*_    . No-trace */
3285 /*_     , Create */
3286 inline static pko
3287 mk_notrace( pko combiner )
3288 {
3289   ALLOC_BOX_PRESUME( pko, T_NOTRACE );
3290   *pdata = combiner;
3291   return PTR2PKO(pbox);
3292 }
3293
3294 /*_     , Parts */
3295 inline static pko
3296 notrace_comb( pko p )
3297 {
3298   WITH_PSYC_UNBOXED( pko, p, T_NOTRACE, 0 );
3299   return *pdata;
3300 }
3301 /*_    . Store */
3302 /*_     , Create */
3303 /*_      . statically */
3304 #define STORE_DEF(DATA)                         \
3305   { T_STORE | T_IMMUTABLE, { DATA, -1, }, }
3306
3307 #define ANON_STORE(DATA)                        \
3308   ANON_REF (kt_opstore, STORE_DEF(DATA))
3309
3310 /*_      . dynamically */
3311 pko
3312 mk_store (pko data, int depth)
3313 {
3314   ALLOC_BOX_PRESUME(kt_opstore, T_STORE | T_IMMUTABLE);
3315   pdata->destr       = data;
3316   pdata->frame_depth = depth;
3317   return PTR2PKO(pbox);
3318 }
3319
3320 /*_    . Load */
3321 /*_     , Struct */
3322 typedef pko kt_opload;
3323
3324 /*_     , Create */
3325 /*_      . statically */
3326 #define LOAD_DEF( DATA )                        \
3327   { T_LOAD | T_IMMUTABLE, DATA, }
3328
3329 #define ANON_LOAD( DATA )                       \
3330   ANON_REF( pko, LOAD_DEF( DATA ))
3331
3332 #define ANON_LOAD_IX( X, Y )             \
3333   ANON_PAIR(ANON_REF(num, INT_DEF( X )), \
3334             ANON_REF(num, INT_DEF( Y )))
3335 /*_      . dynamically */
3336 /*_       , mk_load_ix */
3337 pko
3338 mk_load_ix (int x, int y)
3339 {
3340   return cons (mk_integer (x), mk_integer (y));
3341 }
3342 /*_       , mk_load */
3343 pko
3344 mk_load (pko data)
3345 {
3346   ALLOC_BOX_PRESUME(kt_opload, T_LOAD | T_IMMUTABLE);
3347   *pdata = data;
3348   return PTR2PKO(pbox);
3349 }
3350
3351 /*_   , pairs proper */
3352 /*_    . Type */
3353 DEF_T_PRED (is_pair, T_PAIR,ground, "pair?/o1");
3354
3355 /*_    . Create */
3356 SIG_CHKARRAY(Xcons) = { K_ANY, K_ANY, };
3357 DEF_SIMPLE_DESTR(Xcons);
3358 DEF_APPLICATIVE_W_DESTR(p00a2,mk_pair, REF_DESTR(Xcons),T_NO_K,ground, "cons")
3359 {
3360   WITH_2_ARGS(a,b);
3361   return cons (a, b);
3362 }
3363
3364 DEF_APPLICATIVE_W_DESTR(p00a2,mk_mutable_pair, REF_DESTR(Xcons),T_NO_K,ground, "mcons")
3365 {
3366   WITH_2_ARGS(a,b);
3367   return mcons (a, b);
3368 }
3369
3370 /*_    . Parts and operations */
3371
3372 SIG_CHKARRAY(pair_cxr) = { REF_OPER(is_pair), };
3373 DEF_SIMPLE_DESTR(pair_cxr);
3374 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_car, REF_DESTR(pair_cxr),T_NO_K,ground, "car")
3375 {
3376   WITH_1_ARGS(p);
3377   return v2car(sc,T_PAIR,p);
3378 }
3379
3380 DEF_APPLICATIVE_W_DESTR(ps0a1,pair_cdr, REF_DESTR(pair_cxr),T_NO_K,ground, "cdr")
3381 {
3382   WITH_1_ARGS(p);
3383   return v2cdr(sc,T_PAIR,p);
3384 }
3385
3386 SIG_CHKARRAY(pair_set_cxr) = { REF_OPER(is_pair),  K_ANY, };
3387 DEF_SIMPLE_DESTR(pair_set_cxr);
3388 DEF_APPLICATIVE_W_DESTR(ps0a2,set_car, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-car!")
3389 {
3390   WITH_2_ARGS(p,q);
3391   v2set_car(sc,T_PAIR,p,q);
3392   return K_INERT;
3393 }
3394
3395 DEF_APPLICATIVE_W_DESTR(ps0a2,set_cdr, REF_DESTR(pair_set_cxr),T_NO_K,ground, "set-cdr!")
3396 {
3397   WITH_2_ARGS(p,q);
3398   v2set_cdr(sc,T_PAIR,p,q);
3399   return K_INERT;
3400 }
3401 /*_     , Normal (one arg) */
3402 /*_     , Values as pairs */
3403 DEF_CFUNC_RAW(OPER (valcar), ps0a1, pair_car, REF_OPER (is_pair), T_NO_K);
3404 DEF_CFUNC_RAW(OPER (valcdr), ps0a1, pair_cdr, REF_OPER (is_pair), T_NO_K);
3405
3406 /*_   , Strings */
3407 /*_    . Type */
3408 DEF_T_PRED (is_string, T_STRING,ground,"string?/o1");
3409 /*_    . Create */
3410
3411 INTERFACE INLINE pko
3412 mk_string (const char *str)
3413 {
3414   return mk_bastring (T_STRING, str, strlen (str), 0);
3415 }
3416
3417 INTERFACE INLINE pko
3418 mk_counted_string (const char *str, int len)
3419 {
3420   return mk_bastring (T_STRING, str, len, 0);
3421 }
3422
3423 INTERFACE INLINE pko
3424 mk_empty_string (int len, char fill)
3425 {
3426   return mk_bastring (T_STRING, 0, len, fill);
3427 }
3428 /*_    . Create static */
3429 /* $$WRITE ME  As for k_print_terminate_list macros */
3430
3431 /*_    . Accessors */
3432 INTERFACE INLINE char *
3433 string_value (pko p)
3434 {
3435   return bastring_value(0,T_STRING,p);
3436 }
3437
3438 INTERFACE INLINE int
3439 string_len (pko p)
3440 {
3441   return bastring_len(0,T_STRING,p);
3442 }
3443
3444 /*_   , Symbols */
3445 /*_    . Type */
3446 DEF_T_PRED(is_symbol, T_SYMBOL,ground,"symbol?/o1");
3447 /*_    . Create */
3448 static pko
3449 mk_symbol_obj (const char *name)
3450 {
3451   return mk_bastring (T_SYMBOL | T_IMMUTABLE, name, strlen (name), 0);
3452 }
3453
3454 /* We want symbol objects to be unique per name, so check an oblist of
3455    unique symbols. */
3456 INTERFACE pko
3457 mk_symbol (const char *name)
3458 {
3459   /* first check oblist */
3460   pko x = oblist_find_by_name (name);
3461   if (x != K_NIL)
3462     {
3463       return x;
3464     }
3465   else
3466     {
3467       x = oblist_add_by_name (name);
3468       return x;
3469     }
3470 }
3471 /*_    . oblist implementation */
3472 /*_     , Global object */
3473 static pko oblist = 0;
3474 /*_     , Oblist as hash table */
3475 #ifndef USE_OBJECT_LIST
3476
3477 static int hash_fn (const char *key, int table_size);
3478
3479 static pko
3480 oblist_initial_value ()
3481 {
3482   return mk_vector (461, K_NIL);
3483 }
3484
3485 /* returns the new symbol */
3486 static pko
3487 oblist_add_by_name (const char *name)
3488 {
3489   pko x = mk_symbol_obj (name);
3490   int location = hash_fn (name, vector_len (oblist));
3491   set_vector_elem (oblist, location,
3492                    cons (x, vector_elem (oblist, location)));
3493   return x;
3494 }
3495
3496 static INLINE pko
3497 oblist_find_by_name (const char *name)
3498 {
3499   int location;
3500   pko x;
3501   char *s;
3502   WITH_REPORTER(0);
3503
3504   location = hash_fn (name, vector_len (oblist));
3505   for (x = vector_elem (oblist, location); x != K_NIL; x = cdr (x))
3506     {
3507       s = symname (0,car (x));
3508       /* case-insensitive, per R5RS section 2. */
3509       if (stricmp (name, s) == 0)
3510         {
3511           return car (x);
3512         }
3513     }
3514   return K_NIL;
3515 }
3516
3517 static pko
3518 oblist_all_symbols (void)
3519 {
3520   int i;
3521   pko x;
3522   pko ob_list = K_NIL;
3523
3524   for (i = 0; i < vector_len (oblist); i++)
3525     {
3526       for (x = vector_elem (oblist, i); x != K_NIL; x = cdr (x))
3527         {
3528           ob_list = mcons (x, ob_list);
3529         }
3530     }
3531   return ob_list;
3532 }
3533
3534 /*_     , Oblist as list */
3535 #else
3536
3537 static pko
3538 oblist_initial_value ()
3539 {
3540   return K_NIL;
3541 }
3542
3543 static INLINE pko
3544 oblist_find_by_name (const char *name)
3545 {
3546   pko x;
3547   char *s;
3548   WITH_REPORTER(0);
3549   for (x = oblist; x != K_NIL; x = cdr (x))
3550     {
3551       s = symname (0,car (x));
3552       /* case-insensitive, per R5RS section 2. */
3553       if (stricmp (name, s) == 0)
3554         {
3555           return car (x);
3556         }
3557     }
3558   return K_NIL;
3559 }
3560
3561 /* returns the new symbol */
3562 static pko
3563 oblist_add_by_name (const char *name)
3564 {
3565   pko x = mk_symbol_obj (name);
3566   oblist = cons (x, oblist);
3567   return x;
3568 }
3569
3570 static pko
3571 oblist_all_symbols (void)
3572 {
3573   return oblist;
3574 }
3575
3576 #endif
3577
3578
3579 /*_    . Parts and operations */
3580 SIG_CHKARRAY(string_to_symbol) = { REF_OPER(is_string), };
3581 DEF_SIMPLE_APPLICATIVE(ps0a1,string_to_symbol,T_NO_K,ground, "string->symbol")
3582 {
3583   return mk_symbol(string_value(arg1));
3584 }
3585
3586 INTERFACE INLINE char *
3587 symname (sc_or_null sc, pko p)
3588 {
3589   return bastring_value (sc,T_SYMBOL, p);
3590 }
3591
3592
3593 /*_   , Vectors */
3594
3595 /*_    . Type */
3596 DEF_T_PRED (is_vector, T_VECTOR,unsafe,"vector?/o1");
3597
3598 /*_    . Create */
3599 /*_     , mk_vector (T_ level) */
3600 INTERFACE static pko
3601 mk_vector (int len, pko fill)
3602 { return mk_filled_basvector(len, fill, T_VECTOR); }
3603
3604 /*_     , k_mk_vector (K level) */
3605 /* $$RETHINK ME  This may not be wanted. */
3606 SIG_CHKARRAY(k_mk_vector) = { REF_OPER(is_integer), REF_KEY(K_TYCH_OPTIONAL), K_ANY, };
3607 DEF_SIMPLE_APPLICATIVE (ps0a2, k_mk_vector,T_NO_K,unsafe,"make-vector")
3608 {
3609   WITH_2_ARGS(k_len, fill);
3610
3611   int len = ivalue (k_len);
3612   if (fill == K_INERT)
3613     { fill = K_NIL; }
3614   return mk_vector (len, fill);
3615 }
3616
3617 /*_     , vector */
3618 /* K_ANY instead of REF_OPER(is_finite_list) because
3619    mk_basvector_w_args checks list-ness internally */
3620 DEF_APPLICATIVE_W_DESTR(ps0a1, vector, K_ANY,T_NO_K,unsafe,"vector")
3621 {
3622   WITH_1_ARGS(p);
3623   return mk_basvector_w_args(sc,p,T_VECTOR);
3624 }
3625
3626 /*_    . Operations (T_ level) */
3627 /*_     , fill_vector */
3628
3629 INTERFACE static void
3630 fill_vector (pko vec, pko obj)
3631 {
3632   assert(_get_type(vec) == T_VECTOR);
3633   unsafe_basvector_fill(vec,obj);
3634 }
3635
3636 /*_    . Parts of vectors (T_ level) */
3637
3638 INTERFACE static int
3639 vector_len (pko vec)
3640 {
3641   assert(_get_type(vec) == T_VECTOR);
3642   return basvector_len(vec);
3643 }
3644
3645 INTERFACE static pko
3646 vector_elem (pko vec, int ielem)
3647 {
3648   assert(_get_type(vec) == T_VECTOR);
3649   return basvector_elem(vec, ielem);
3650 }
3651
3652 INTERFACE static void
3653 set_vector_elem (pko vec, int ielem, pko a)
3654 {
3655   assert(_get_type(vec) == T_VECTOR);
3656   basvector_set_elem(vec, ielem, a);
3657   return;
3658 }
3659
3660 /*_   , Promises */
3661 /* T_PROMISE is essentially a handle, pointing to a pair of either
3662    (expression env) or (value #f).  We use #f, not nil, because nil is
3663    a possible environment. */
3664
3665 /*_    . Create */
3666 /*_     , $lazy */
3667 RGSTR(ground,"$lazy", REF_OPER(mk_promise_lazy))
3668 DEF_CFUNC(ps0a1, mk_promise_lazy, K_ANY_SINGLETON, T_NO_K)
3669 {
3670   WITH_1_ARGS(p);
3671   pko guts = mcons(p, mcons(sc->envir, mk_continuation(sc->dump)));
3672   return v2cons (T_PROMISE, guts, K_NIL);
3673 }
3674 /*_     , memoize */
3675 /* $$CHECK ME Is K_ANY correct?  Or K_ANY_SINGLETON?  */
3676 DEF_APPLICATIVE_W_DESTR(p00a1,mk_promise_memo,K_ANY,T_NO_K,ground,"memoize")
3677 {
3678   WITH_1_ARGS(p);
3679   pko guts = mcons(p, K_F);
3680   return v2cons (T_PROMISE, guts, K_NIL);
3681 }
3682 /*_    . Type */
3683
3684 DEF_T_PRED (is_promise,T_PROMISE,ground,"promise?/o1");
3685 /*_    . Helpers */
3686 /*_     , promise_schedule_eval */
3687 inline pko
3688 promise_schedule_eval(klink * sc, pko p)
3689 {
3690   WITH_REPORTER(sc);
3691   pko guts = unsafe_v2car(p);
3692   pko env     = car(cdr(guts));
3693   pko dynxtnt = cdr(cdr(guts));
3694   /* Arrange to eval the expression and pass the result to
3695      handle_promise_result */
3696   CONTIN_1R(dcrry_2ALLVLL,handle_promise_result,sc,p);
3697   /* $$ENCAP ME  This deals with continuation guts, so should be
3698      encapped.  As a special continuation-maker? */
3699   _kt_spagstack new_dump =
3700     special_dynxtnt (cont_dump(dynxtnt), sc->dump, env);
3701   sc->dump = new_dump;
3702   CONTIN_2(dcrry_2dotALL, kernel_eval, sc, car(guts), env);
3703   return K_INERT;
3704 }
3705 /*_     , handle_promise_result */
3706 SIG_CHKARRAY(handle_promise_result) = { REF_OPER(is_promise), K_ANY };
3707 DEF_SIMPLE_CFUNC(ps0a2,handle_promise_result,0)
3708 {
3709   /* guts are only made by C code so if they're wrong it's a C
3710      error */
3711   WITH_REPORTER(0);
3712   WITH_2_ARGS(p,value);
3713   pko guts = unsafe_v2car(p);
3714
3715   /* if p already has a result, return it */
3716   if(cdr(guts) == K_F)
3717     { return car(guts); }
3718   /* If value is again a promise, set this promise's guts to that
3719      promise's guts and force it again, which will force both (This is
3720      why we need promises to be 2-layer) */
3721   else if(is_promise(value))
3722     {
3723       unsafe_v2set_car (p, unsafe_v2car(value));
3724       return promise_schedule_eval(sc, p);
3725     }
3726   /* Otherwise set the value and return it. */
3727   else
3728     {
3729       unsafe_v2set_car (guts, value);
3730       unsafe_v2set_cdr (guts, K_F);
3731       return value;
3732     }
3733 }
3734 /*_    . Operations */
3735 /*_     , force */
3736 DEF_APPLICATIVE_W_DESTR (ps0a1, force, K_ANY_SINGLETON,T_NO_K,ground,"force")
3737 {
3738   /* guts are only made by this C code here, so if they're wrong it's
3739      a C error */
3740   WITH_REPORTER(0);
3741   WITH_1_ARGS(p);
3742   if(!is_promise(p))
3743     { return p; }
3744
3745   pko guts = unsafe_v2car(p);
3746   if(cdr(guts) == K_F)
3747     { return car(guts); }
3748   else
3749     { return promise_schedule_eval(sc,p); }
3750 }
3751
3752 /*_   , Ports */
3753 /*_    . Creating */
3754
3755 /* $$IMPROVE ME Just directly contain the port structure.  Possibly
3756    split port into several T_ types.  */
3757 static pko
3758 mk_port (port * pt)
3759 {
3760   ALLOC_BOX_PRESUME (port *, T_PORT);
3761   pbox->data = pt;
3762   return PTR2PKO(pbox);
3763 }
3764
3765 static port *
3766 port_rep_from_filename (const char *fn, int prop)
3767 {
3768   FILE *f;
3769   char *rw;
3770   port *pt;
3771   if (prop == (port_input | port_output))
3772     {
3773       rw = "a+";
3774     }
3775   else if (prop == port_output)
3776     {
3777       rw = "w";
3778     }
3779   else
3780     {
3781       rw = "r";
3782     }
3783   f = fopen (fn, rw);
3784   if (f == 0)
3785     {
3786       return 0;
3787     }
3788   pt = port_rep_from_file (f, prop);
3789   pt->rep.stdio.closeit = 1;
3790
3791 #if SHOW_ERROR_LINE
3792   if (fn)
3793     { pt->rep.stdio.filename = store_string (strlen (fn), fn, 0); }
3794
3795   pt->rep.stdio.curr_line = 0;
3796 #endif
3797   return pt;
3798 }
3799
3800 static pko
3801 port_from_filename (const char *fn, int prop)
3802 {
3803   port *pt;
3804   pt = port_rep_from_filename (fn, prop);
3805   if (pt == 0)
3806     {
3807       return K_NIL;
3808     }
3809   return mk_port (pt);
3810 }
3811
3812 static port *
3813 port_rep_from_file (FILE * f, int prop)
3814 {
3815   port *pt;
3816   pt = (port *) GC_MALLOC_ATOMIC (sizeof *pt);
3817   if (pt == NULL)
3818     {
3819       return NULL;
3820     }
3821   /* Don't care what goes in these but GC really wants to provide it
3822      so here are dummy objects to put it in. */
3823   GC_finalization_proc ofn;
3824   GC_PTR               ocd;
3825   GC_register_finalizer(pt, port_finalize_file, 0, &ofn, &ocd);
3826   pt->kind = port_file | prop;
3827   pt->rep.stdio.file = f;
3828   pt->rep.stdio.closeit = 0;
3829   return pt;
3830 }
3831
3832 static pko
3833 port_from_file (FILE * f, int prop)
3834 {
3835   port *pt;
3836   pt = port_rep_from_file (f, prop);
3837   if (pt == 0)
3838     {
3839       return K_NIL;
3840     }
3841   return mk_port (pt);
3842 }
3843
3844 static port *
3845 port_rep_from_string (char *start, char *past_the_end, int prop)
3846 {
3847   port *pt;
3848   pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3849   if (pt == 0)
3850     {
3851       return 0;
3852     }
3853   pt->kind = port_string | prop;
3854   pt->rep.string.start = start;
3855   pt->rep.string.curr = start;
3856   pt->rep.string.past_the_end = past_the_end;
3857   return pt;
3858 }
3859
3860 static pko
3861 port_from_string (char *start, char *past_the_end, int prop)
3862 {
3863   port *pt;
3864   pt = port_rep_from_string (start, past_the_end, prop);
3865   if (pt == 0)
3866     {
3867       return K_NIL;
3868     }
3869   return mk_port (pt);
3870 }
3871
3872 #define BLOCK_SIZE 256
3873
3874 static int
3875 realloc_port_string (port * p)
3876 {
3877   /* $$IMPROVE ME  Just use REALLOC. */
3878   char *start = p->rep.string.start;
3879   size_t new_size = p->rep.string.past_the_end - start + 1 + BLOCK_SIZE;
3880   char *str = GC_MALLOC_ATOMIC (new_size);
3881   if (str)
3882     {
3883       memset (str, ' ', new_size - 1);
3884       str[new_size - 1] = '\0';
3885       strcpy (str, start);
3886       p->rep.string.start = str;
3887       p->rep.string.past_the_end = str + new_size - 1;
3888       p->rep.string.curr -= start - str;
3889       return 1;
3890     }
3891   else
3892     {
3893       return 0;
3894     }
3895 }
3896
3897
3898 static port *
3899 port_rep_from_scratch (void)
3900 {
3901   port *pt;
3902   char *start;
3903   pt = (port *) GC_MALLOC_ATOMIC (sizeof (port));
3904   if (pt == 0)
3905     {
3906       return 0;
3907     }
3908   start = GC_MALLOC_ATOMIC (BLOCK_SIZE);
3909   if (start == 0)
3910     {
3911       return 0;
3912     }
3913   memset (start, ' ', BLOCK_SIZE - 1);
3914   start[BLOCK_SIZE - 1] = '\0';
3915   pt->kind = port_string | port_output | port_srfi6;
3916   pt->rep.string.start = start;
3917   pt->rep.string.curr = start;
3918   pt->rep.string.past_the_end = start + BLOCK_SIZE - 1;
3919   return pt;
3920 }
3921
3922 static pko
3923 port_from_scratch (void)
3924 {
3925   port *pt;
3926   pt = port_rep_from_scratch ();
3927   if (pt == 0)
3928     {
3929       return K_NIL;
3930     }
3931   return mk_port (pt);
3932 }
3933 /*_     , Interface */
3934 /*_      . open-input-file */
3935 SIG_CHKARRAY(k_open_input_file) =
3936   { REF_OPER(is_string), };
3937 DEF_SIMPLE_APPLICATIVE(ps0a1,k_open_input_file,0,ground, "open-input-file")
3938 {
3939   WITH_1_ARGS(filename);
3940   return port_from_filename (string_value(filename), port_file | port_input);
3941 }
3942
3943
3944 /*_    . Testing */
3945
3946 DEF_T_PRED (is_port, T_PORT,ground,"port?/o1");
3947
3948 DEF_SIMPLE_PRED (is_inport,T_NO_K,ground,"input-port?/o1")
3949 {
3950   WITH_1_ARGS(p);
3951   return is_port (p) && portvalue (p)->kind & port_input;
3952 }
3953
3954 DEF_SIMPLE_PRED (is_outport,T_NO_K,ground,"output-port?/o1")
3955 {
3956   WITH_1_ARGS(p);
3957   return is_port (p) && portvalue (p)->kind & port_output;
3958 }
3959
3960 /*_    . Values */
3961 INLINE port *
3962 portvalue (pko p)
3963 {
3964   WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3965   return *pdata;
3966 }
3967
3968 INLINE void
3969 set_portvalue (pko p, port * newport)
3970 {
3971   assert_mutable(0,p);
3972   WITH_PSYC_UNBOXED(port *,p,T_PORT,0);
3973   *pdata = newport;
3974   return;
3975 }
3976
3977 /*_    . reading from ports */
3978 static int
3979 inchar (port *pt)
3980 {
3981   int c;
3982
3983   if (pt->kind & port_saw_EOF)
3984     { return EOF; }
3985   c = basic_inchar (pt);
3986   if (c == EOF)
3987     { pt->kind |= port_saw_EOF; }
3988 #if SHOW_ERROR_LINE
3989   else if (c == '\n')
3990     {
3991       if (pt->kind & port_file)
3992         { pt->rep.stdio.curr_line++; }
3993     }
3994 #endif
3995
3996   return c;
3997 }
3998
3999 static int
4000 basic_inchar (port * pt)
4001 {
4002   if (pt->kind & port_file)
4003     {
4004       return fgetc (pt->rep.stdio.file);
4005     }
4006   else
4007     {
4008       if (*pt->rep.string.curr == 0 ||
4009           pt->rep.string.curr == pt->rep.string.past_the_end)
4010         {
4011           return EOF;
4012         }
4013       else
4014         {
4015           return *pt->rep.string.curr++;
4016         }
4017     }
4018 }
4019
4020 /* back character to input buffer */
4021 static void
4022 backchar (port * pt, int c)
4023 {
4024   if (c == EOF)
4025     { return; }
4026
4027   if (pt->kind & port_file)
4028     {
4029       ungetc (c, pt->rep.stdio.file);
4030 #if SHOW_ERROR_LINE
4031       if (c == '\n')
4032         {
4033           pt->rep.stdio.curr_line--;
4034         }
4035 #endif
4036     }
4037   else
4038     {
4039       if (pt->rep.string.curr != pt->rep.string.start)
4040         {
4041           --pt->rep.string.curr;
4042         }
4043     }
4044 }
4045
4046 /*_     , Interface */
4047
4048 /*_      . (get-char textual-input-port) */
4049 SIG_CHKARRAY(get_char) = { REF_OPER(is_inport), };
4050 DEF_SIMPLE_APPLICATIVE(p00a1,get_char,T_NO_K,ground, "get-char")
4051 {
4052   WITH_1_ARGS(port);
4053   assert(is_inport(port));
4054   int c = inchar(portvalue(port));
4055   if(c == EOF)
4056     { return K_EOF; }
4057   else
4058     { return mk_character(c); }
4059 }
4060
4061 /*_    . Finalization */
4062 static void
4063 port_finalize_file(GC_PTR obj, GC_PTR client_data)
4064 {
4065   port *pt = obj;
4066   if ((pt->kind & port_file) && pt->rep.stdio.closeit)
4067     { port_close_port (pt, port_input | port_output); }
4068 }
4069
4070 static void
4071 port_close (pko p, int flag)
4072 {
4073   assert(is_port(p));
4074   port_close_port(portvalue (p), flag);
4075 }
4076
4077 static void
4078 port_close_port (port * pt, int flag)
4079 {
4080   pt->kind &= ~flag;
4081   if ((pt->kind & (port_input | port_output)) == 0)
4082     {
4083       if (pt->kind & port_file)
4084         {
4085 #if SHOW_ERROR_LINE
4086           /* Cleanup is here so (close-*-port) functions could work too */
4087           pt->rep.stdio.curr_line = 0;
4088
4089 #endif
4090
4091           fclose (pt->rep.stdio.file);
4092         }
4093       pt->kind = port_free;
4094     }
4095 }
4096
4097
4098 /*_   , Encapsulation type */
4099
4100 SIG_CHKARRAY(is_encap) = { REF_OPER(is_key), K_ANY };
4101 DEF_SIMPLE_CFUNC(b00a2, is_encap,T_NO_K)
4102 {
4103   WITH_2_ARGS(type, p);
4104   if (is_type (p, T_ENCAP))
4105     {
4106       WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
4107       return (pdata->type == type);
4108     }
4109   else
4110     {
4111       return 0;
4112     }
4113 }
4114
4115 /* NOT directly part of the interface. */
4116 SIG_CHKARRAY(unencap) = { REF_OPER(is_key),  K_ANY};
4117 DEF_SIMPLE_CFUNC(ps0a2, unencap,T_NO_K)
4118 {
4119   WITH_2_ARGS(type, p);
4120   if (is_encap (type, p))
4121     {
4122       WITH_UNBOXED_UNSAFE(pdata,kt_encap,p);
4123       return pdata->value;
4124     }
4125   else
4126     {
4127       /* We have no type-name to give to the error message. */
4128       KERNEL_ERROR_0 (sc, "unencap: wrong type");
4129     }
4130 }
4131
4132 /* NOT directly part of the interface. */
4133 SIG_CHKARRAY(mk_encap) = { REF_OPER(is_key),  K_ANY};
4134 DEF_SIMPLE_CFUNC(p00a2, mk_encap,T_NO_K)
4135 {
4136   WITH_2_ARGS(type, value);
4137   ALLOC_BOX_PRESUME (kt_encap, T_ENCAP);
4138   pbox->data.type = type;
4139   pbox->data.value = value;
4140   return PTR2PKO(pbox);
4141 }
4142
4143 DEF_APPLICATIVE_W_DESTR (p00a0, mk_encapsulation_type, K_NO_TYPE,T_NO_K,ground, "make-encapsulation-type/raw")
4144 {
4145   /* A unique cell representing a type */
4146   pko type = mk_void();
4147   /* $$IMPROVE ME make typespecs for the curried objs.  trivpred is
4148      effectively that spec object.  */
4149   pko e   = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (mk_encap)));
4150   pko trivpred = mk_curried (dcrry_2ALLV01, type, REF_OPER (is_encap));
4151   pko d   = wrap (mk_curried (dcrry_2ALLV01, type, REF_OPER (unencap)));
4152   return LIST3 (e, trivpred, d);
4153 }
4154 /*_   , Listloop types */
4155 /*_    . Forward declarations */
4156 struct kt_listloop;
4157 /*_    . Enumerations */
4158 /*_     , Next-style */
4159 /* How to turn the current list into current value and next list. */
4160 typedef enum
4161 {
4162   lls_1list,
4163   lls_many,
4164   lls_neighbors,
4165   lls_max,
4166 } kt_loopstyle_step;
4167 typedef enum
4168 {
4169   lls_combiner,
4170   lls_count,
4171   lls_top_count,
4172   lls_stop_on,
4173   lls_num_args,
4174 } kt_loopstyle_argix;
4175
4176 /*_    . Function signatures. */
4177 typedef pko (* kt_listloop_mk_val)(pko value,  struct kt_listloop * pll);
4178 /*_    . Struct */
4179 typedef struct kt_listloop_style
4180 {
4181   pko                combiner;  /* Default combiner or NULL. */
4182   int                collect_p; /* Whether to collect a (reversed)
4183                                    list of the returns. */
4184   kt_loopstyle_step  step;
4185   kt_listloop_mk_val mk_val; /* From returned value+state -> passed value. */
4186   pko                destructurer; /* A destructurer contents */
4187   /* Selection of args.  Each entry correspond to one arg in "full
4188      args", and indexes something in the array of actual args that the
4189      destructurer retrieves. */
4190   int                arg_select[lls_num_args];
4191 } kt_listloop_style;
4192 typedef struct kt_listloop
4193 {
4194   pko combiner;                 /* The combiner to use repeatedly. */
4195   pko list;                     /* The list to loop over */
4196   int top_length;               /* Length of top element, for lls_many. */
4197   int countdown;                /* Num elements left, or negative if unused. */
4198   int countup;                  /* Upwards count from 0. */
4199   pko stop_on;                  /* Stop if return value is this. Can
4200                                    be 0 for unused. */
4201   kt_listloop_style * style;    /* Non-NULL pointer to style. */
4202 } kt_listloop;
4203 /*_     , Internal signatures */
4204 pko
4205 listloop_aux (klink * sc,
4206               kt_listloop_style * style_v,
4207               pko list,
4208               pko style_args[lls_num_args]);
4209 FORWARD_DECL_CFUNC (static, ps0a3, listloop_resume);
4210
4211 /*_    . Creating */
4212 /*_     , Listloop styles */
4213 /* Unused */
4214 pko
4215 mk_listloop_style
4216 (pko combiner,
4217  int collect_p,
4218  kt_loopstyle_step step,
4219  kt_listloop_mk_val mk_val)
4220 {
4221   ALLOC_BOX_PRESUME(kt_listloop_style,T_LISTLOOP_STYLE);
4222   pdata->combiner   = combiner;
4223   pdata->collect_p  = collect_p;
4224   pdata->step       = step;
4225   pdata->mk_val     = mk_val;
4226   return PTR2PKO(pbox);
4227 }
4228 /*_     , Listloops */
4229 pko
4230 mk_listloop
4231 (pko combiner,
4232  pko list,
4233  int top_length,
4234  int count,
4235  pko stop_on,
4236  kt_listloop_style * style)
4237 {
4238   ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
4239   pdata->combiner   = combiner;
4240   pdata->list       = list;
4241   pdata->top_length = top_length;
4242   pdata->countdown  = count;
4243   pdata->countup    = -1;
4244   pdata->stop_on    = stop_on;
4245   pdata->style      = style;
4246   return PTR2PKO(pbox);
4247 }
4248 /*_     , Copying */
4249 pko
4250 copy_listloop(const kt_listloop * orig)
4251 {
4252   ALLOC_BOX_PRESUME(kt_listloop,T_LISTLOOP);
4253   memcpy (pdata, orig, sizeof(kt_listloop));
4254   return PTR2PKO(pbox);
4255 }
4256 /*_    . Testing */
4257 /* Unused so far */
4258 DEF_T_PRED(is_listloop,       T_LISTLOOP,       no, "");
4259 DEF_T_PRED(is_listloop_style, T_LISTLOOP_STYLE, no, "");
4260 /*_    . Val-makers */
4261 /*_    . Pre-existing style objects */
4262 /*_     , listloop-style-sequence */
4263 RGSTR(simple,"listloop-style-sequence",REF_OBJ(sequence_style))
4264 static BOX_OF(kt_listloop_style) sequence_style =
4265 {
4266   T_LISTLOOP_STYLE,
4267   {
4268     REF_OPER(kernel_eval),
4269     0,
4270     lls_1list,
4271     0,
4272     K_NO_TYPE,                  /* No args contemplated */
4273     { [0 ... lls_num_args - 1] = -1, }
4274   }
4275 };
4276 /*_     , listloop-style-neighbors */
4277 RGSTR(simple,"listloop-style-neighbors",REF_OBJ(neighbor_style))
4278 SIG_CHKARRAY(neighbor_style) =
4279   {
4280     REF_OPER(is_integer),
4281   };
4282 DEF_SIMPLE_DESTR(neighbor_style);
4283 static BOX_OF(kt_listloop_style) neighbor_style =
4284 {
4285   T_LISTLOOP_STYLE,
4286   {
4287     REF_OPER(val2val),
4288     1,
4289     lls_neighbors,
4290     0,
4291     REF_DESTR(neighbor_style),
4292     /* See http://gcc.gnu.org/onlinedocs/gcc/Designated-Inits.html. */
4293     { [0 ... lls_num_args - 1] = -1, [lls_count] = 0, },
4294   }
4295 };
4296 /*_    . Operations */
4297 /*_     , listloop */
4298 /* Create a listloop object. */
4299 /* $$IMPROVE ME This may become what style operative T_ type calls.
4300    Rename it eval_listloop_style. */
4301 SIG_CHKARRAY(listloop) =
4302 {
4303   REF_OPER(is_listloop_style),
4304   REF_OPER(is_countable_list),
4305   REF_KEY(K_TYCH_DOT),
4306   K_ANY,
4307 };
4308
4309 DEF_SIMPLE_APPLICATIVE(ps0a3, listloop,0,ground, "listloop")
4310 {
4311   WITH_3_ARGS(style, list, args);
4312
4313   WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
4314   pko style_args[lls_num_args];
4315   /* Destructure the args by style */
4316   destructure_to_array(sc,
4317                        args,
4318                        style_v->destructurer,
4319                        style_args,
4320                        lls_num_args,
4321                        REF_OPER (listloop_resume),
4322                        LIST2 (style, list));
4323   return listloop_aux (sc, style_v, list, style_args);
4324 }
4325 /*_     , listloop_resume */
4326 SIG_CHKARRAY (listloop_resume) =
4327 {
4328   REF_OPER (is_destr_result),
4329   REF_OPER(is_listloop_style),
4330   REF_OPER(is_countable_list),
4331 };
4332 DEF_SIMPLE_CFUNC(ps0a3, listloop_resume, 0)
4333 {
4334   WITH_3_ARGS (destr_result, style, list);
4335   pko style_args[lls_num_args];
4336   destr_result_fill_array (destr_result, lls_num_args, style_args);
4337   WITH_UNBOXED_UNSAFE(style_v,kt_listloop_style, style);
4338   return listloop_aux (sc, style_v, list, style_args);
4339 }
4340 /*_     , listloop_aux */
4341 pko
4342 listloop_aux
4343 (klink * sc, kt_listloop_style * style_v, pko list, pko style_args[lls_num_args])
4344 {
4345   /*** Get the actual arg objects ***/
4346 #define GET_OBJ(_INDEX) \
4347   ((style_v->arg_select[_INDEX] < 0) ? K_INERT : style_args[style_v->arg_select[_INDEX]])
4348
4349   pko count      = GET_OBJ(lls_count);
4350   pko combiner   = GET_OBJ(lls_combiner);
4351   pko top_length = GET_OBJ(lls_top_count);
4352 #undef GET_OBJ
4353
4354   /*** Extract values from the objects, using defaults as needed ***/
4355   int countv      = (count      == K_INERT) ? -1L : ivalue(count);
4356   int top_lengthv = (top_length == K_INERT) ? 1 : ivalue(top_length);
4357   if(combiner == K_INERT)
4358     {
4359       combiner = style_v->combiner;
4360     }
4361
4362   /*** Make the loop object itself ***/
4363   pko ll = mk_listloop( combiner, list, top_lengthv, countv, 0, style_v );
4364   return ll;
4365 }
4366 /*_     , Evaluating one iteration */
4367 pko
4368 eval_listloop(klink * sc, pko functor, pko value)
4369 {
4370   WITH_REPORTER(sc);
4371   WITH_PSYC_UNBOXED(kt_listloop, functor, T_LISTLOOP, sc);
4372
4373   /*** Test whether done, maybe return current value. ***/
4374   /* If we're not checking, value will be NULL so this won't
4375      trigger.  pdata->countup is 0 for the first element. */
4376   if((pdata->countup >= 0) && (value == pdata->stop_on))
4377     {
4378       /* $$IMPROVE ME  This will ct an "abnormal return" value from
4379          this and the other data.  */
4380       return value;
4381     }
4382   /* If we're not counting down, value will be negative so this won't
4383      trigger.  */
4384   if(pdata->countdown == 0)
4385     {
4386       return value;
4387     }
4388   /* And if we run out of elements, we have to stop regardless. */
4389   if(pdata->list == K_NIL)
4390     {
4391       /* $$IMPROVE ME Error if we're counting down (ie, if count
4392          is positive). */
4393       return value;
4394     }
4395
4396   /*** Step list, getting new value ***/
4397   pko new_list, new_value;
4398
4399   switch(pdata->style->step)
4400     {
4401     case lls_1list:
4402       new_list  = cdr( pdata->list );
4403       /* We assume the common case of val as list. */
4404       new_value = LIST1(car( pdata->list ));
4405       break;
4406
4407     case lls_neighbors:
4408       /* $$IMPROVE ME Also test that next item (new_list) is non-empty */
4409       new_list  = cdr( pdata->list );
4410       new_value = LIST2(car( pdata->list ), car(new_list));
4411       break;
4412     case lls_many:
4413       new_list  = k_counted_map_cdr(sc, pdata->top_length, pdata->list, T_PAIR);
4414       new_value = k_counted_map_car(sc, pdata->top_length, pdata->list, T_PAIR);
4415       break;
4416     default:
4417       KERNEL_ERROR_0(sc,"I know nut-ting about that case");
4418     }
4419
4420   /* Convert it if applicable. */
4421   if(pdata->style->mk_val)
4422     {
4423       new_value = pdata->style->mk_val(new_value, pdata);
4424     }
4425
4426   /*** Arrange a new iteration. ***/
4427   /* We don't have to re-setup the final chain, if any, because it's
4428      still there from the earlier call.  Just the combiner (if any)
4429      and a fresh listloop operative.  */
4430   pko new_listloop = copy_listloop(pdata);
4431   {
4432     WITH_UNBOXED_UNSAFE(new_pdata,kt_listloop,new_listloop);
4433     new_pdata->list = new_list;
4434     if(new_pdata->countdown > 0)
4435       { new_pdata->countdown--; }
4436     new_pdata->countup++;
4437   }
4438
4439   if(pdata->style->collect_p)
4440     {
4441       CONTIN_0_RAW (mk_curried(dcrry_NVLLdotALL, value, new_listloop), sc);
4442     }
4443   else
4444     {
4445       CONTIN_0_RAW(new_listloop, sc);
4446     }
4447
4448   CONTIN_0_RAW(pdata->combiner, sc);
4449   return new_value;
4450 }
4451
4452 /*_  . Handling lists */
4453 /*_   , list* */
4454 DEF_APPLICATIVE_W_DESTR (ps0a1, list_star, REF_OPER(is_finite_list),T_NO_K,ground, "list*")
4455 {
4456   return v2list_star(sc, arg1, T_PAIR);
4457 }
4458 /*_   , reverse */
4459 SIG_CHKARRAY(reverse) = { REF_OPER(is_finite_list), };
4460 DEF_SIMPLE_APPLICATIVE (ps0a1, reverse,T_NO_K,ground, "reverse")
4461 {
4462   WITH_1_ARGS(a);
4463   return v2reverse(a,T_PAIR);
4464 }
4465 /*_    . reverse list -- in-place */
4466 /* Don't just use unsafe_v2reverse_in_place, it checks nothing.  This
4467    may be reserved for optimization only. */
4468
4469 /*_    . append list -- produce new list */
4470 /* $$IMPROVE ME  This defines append/2 but we'll want append/N.  Do
4471    that in init. */
4472 SIG_CHKARRAY(append) = { REF_OPER(is_finite_list), K_ANY, };
4473 DEF_SIMPLE_APPLICATIVE (ps0a2, append,T_NO_K,simple, "append")
4474 {
4475   WITH_2_ARGS(a,b);
4476   return v2append(sc,a,b,T_PAIR);
4477 }
4478 /*_   , is_finite_list */
4479 DEF_SIMPLE_PRED (is_finite_list,T_NO_K,ground, "finite-list?/o1")
4480 {
4481   WITH_1_ARGS(p);
4482   int4 metrics;
4483   get_list_metrics_aux(p, metrics);
4484   return (metrics[lm_num_nils] == 1);
4485 }
4486 /*_   , is_countable_list */
4487 DEF_SIMPLE_PRED (is_countable_list,T_NO_K,ground, "countable-list?/o1")
4488 {
4489   WITH_1_ARGS(p);
4490   int4 metrics;
4491   get_list_metrics_aux(p, metrics);
4492   return (metrics[lm_num_nils] || metrics[lm_cyc_len]);
4493 }
4494 /*_   , list_length */
4495 /* Result is:
4496    proper list: length
4497    circular list: -1
4498    not even a pair: -2
4499    dotted list: -2 minus length before dot
4500
4501    The extra meanings will change since callers can use
4502    get_list_metrics_aux now.  Return lm_acyc_len even for dotted
4503    lists, return positive infinity for circular lists.
4504 */
4505 /* $$OBSOLESCENT */
4506 int
4507 list_length (pko p)
4508 {
4509   int4 metrics;
4510   get_list_metrics_aux(p, metrics);
4511   /* A proper list */
4512   if(metrics[lm_num_nils] == 1)
4513     { return metrics[lm_acyc_len]; }
4514   /* A circular list */
4515   /* $$IMPROVE ME Return +oo.  First make a type and object for +oo  */
4516   if(metrics[lm_cyc_len] != 0)
4517     { return -1; }
4518   /* $$IMPROVE ME Return lm_acyc_len again, merge with the other
4519      case. */
4520   /* Otherwise it's dotted */
4521   return 2 - metrics[lm_acyc_len];
4522 }
4523 /*_   , list_length_k */
4524 DEF_APPLICATIVE_W_DESTR(p00a1, list_length_k, K_ANY_SINGLETON,T_NO_K,ground, "length")
4525 {
4526   WITH_1_ARGS(p);
4527   return mk_integer(list_length(p));
4528 }
4529
4530 /*_   , get_list_metrics */
4531 DEF_APPLICATIVE_W_DESTR(p00a1, get_list_metrics, K_ANY_SINGLETON,T_NO_K,ground, "get-list-metrics")
4532 {
4533   WITH_1_ARGS(p);
4534   int4 metrics;
4535   get_list_metrics_aux(p, metrics);
4536   return LIST4(mk_integer(metrics[0]),
4537                mk_integer(metrics[1]),
4538                mk_integer(metrics[2]),
4539                mk_integer(metrics[3]));
4540 }
4541 /*_   , get_list_metrics_aux */
4542 /* RESULTS must be an int4 (an array of 4 integers).  get_list_metrics_aux
4543    will fill it with (See enum lm_index):
4544
4545    * the number of pairs in a
4546    * the number of nil objects in a
4547    * the acyclic prefix length of a
4548    * the cycle length of a
4549 */
4550
4551 /* $$IMPROVE ME Take a flag so we can skip work such as finding
4552    prefix-length when we don't need to do it.  This will cause some
4553    result positions to be interpreted differently: when it's cycling,
4554    lm_acyc_len and lm_num_pairs may both overshoot (but never
4555    undershoot).
4556 */
4557
4558 void
4559 get_list_metrics_aux (pko a, int4 presults)
4560 {
4561   int * results = presults;     /* Make it easier to index. */
4562   int steps = 0;
4563   int power = 1;
4564   int loop_len = 1;
4565   pko slow, fast;
4566   WITH_REPORTER(0);
4567
4568   /* Use Brent's Algorithm, but we have to check for nil and non-pair
4569      too, so I rearranged the loop.  We also count steps, because in
4570      some cases we use number of steps directly. */
4571   slow = fast = a;
4572   while (1)
4573     {
4574       if (fast == K_NIL)
4575         {
4576           results[lm_num_pairs] = steps;
4577           results[lm_num_nils]  = 1;
4578           results[lm_acyc_len]  = steps;
4579           results[lm_cyc_len]   = 0;
4580           return;
4581         }
4582       if (!is_pair (fast))
4583         {
4584           results[lm_num_pairs] = steps;
4585           results[lm_num_nils]  = 0;
4586           results[lm_acyc_len]  = steps;
4587           results[lm_cyc_len]   = 0;
4588           return;
4589         }
4590       fast = cdr (fast);
4591       if (fast == slow)
4592         {
4593           /* The fast cursor has caught up with the slow cursor so the
4594              structure is circular and loop_len is the cycle length.
4595              We still need to find prefix length.
4596           */
4597           int prefix_len = 0;
4598           int i = 0;
4599           /* Restart the turtle from the beginning */
4600           slow = a;
4601           /* Restart the hare from position LOOP_LEN */
4602           for(i = 0, fast = a; i < loop_len; i++)
4603             { fast = cdr (fast); }
4604           /* Since hare has exactly a loop_len head start, when it
4605              goes around the loop exactly once it will be in the same
4606              position as turtle, so turtle will have only walked the
4607              acyclic prefix. */
4608           while(fast != slow)
4609             {
4610               fast = cdr (fast);
4611               slow = cdr (slow);
4612               prefix_len++;
4613             }
4614
4615           results[lm_num_pairs] = prefix_len + loop_len;
4616           results[lm_num_nils]  = 0;
4617           results[lm_acyc_len]  = prefix_len;
4618           results[lm_cyc_len]   = loop_len;
4619           return;
4620         }
4621       if(power == loop_len)
4622         {
4623           /* Re-plant the slow cursor */
4624           slow = fast;
4625           loop_len = 0;
4626           power *= 2;
4627         }
4628       ++loop_len;
4629       ++steps;
4630     }
4631 }
4632 /*_  . Handling trees */
4633 /*_   , copy_es_immutable */
4634 DEF_APPLICATIVE_W_DESTR (ps0a1, copy_es_immutable, K_ANY_SINGLETON,T_NO_K,ground, "copy-es-immutable")
4635 {
4636   WITH_1_ARGS(object);
4637   WITH_REPORTER(sc);
4638   if (is_pair (object))
4639     {
4640       /* If it's already immutable, can we assume it's immutable
4641        * all the way down and just return it? */
4642       return cons
4643         (copy_es_immutable (sc, car (object)),
4644          copy_es_immutable (sc, cdr (object)));
4645     }
4646   else
4647     {
4648       return object;
4649     }
4650 }
4651 /*_   , Get tree cycles */
4652 /*_    . Structs */
4653 /*_     , kt_recurrence_table */
4654 /* Really just a specialized resizeable lookup table from object to
4655    count.  Internals may change.  */
4656 /* $$IMPROVE ME Look up more efficiently.  Current GC is not
4657    compacting, so we can hash or sort addresses meaningfully.  */
4658 typedef struct
4659 {
4660   pko * objs;
4661   int     * counts;
4662   int table_size;
4663   int alloced_size;
4664 }
4665 kt_recurrence_table;
4666 /*_     , recur_entry */
4667 typedef struct
4668 {
4669   /* $$IMPROVE ME  These two fields may become one enumerated field */
4670   int count;
4671   int seen_in_walk;
4672   int index_in_walk;
4673 } recur_entry;
4674 /*_     , kt_recur_tracker */
4675 typedef struct
4676 {
4677   pko     * objs;
4678   recur_entry * entries;
4679   int table_size;
4680   int current_index;
4681 } kt_recur_tracker;
4682 /*_    . is_recurrence_table */
4683 DEF_T_PRED(is_recurrence_table,T_RECURRENCES,ground, "recurrence-table?/o1");
4684
4685 /*_    . is_recur_tracker */
4686 DEF_SIMPLE_PRED(is_recur_tracker,T_NO_K,ground, "recur-tracker?/o1")
4687 {
4688   WITH_1_ARGS(p);
4689   return (p == K_NIL) || is_type (p, T_RECUR_TRACKER);
4690 }
4691 /*_    . recurrences_to_recur_tracker */
4692 SIG_CHKARRAY(recurrences_to_recur_tracker) =
4693 { REF_OPER(is_recurrence_table), };
4694 DEF_SIMPLE_APPLICATIVE(p00a1,recurrences_to_recur_tracker,T_NO_K,ground, "recurrences->tracker")
4695 {
4696   WITH_1_ARGS(recurrences);
4697   assert_type(0,recurrences,T_RECURRENCES);
4698
4699   WITH_UNBOXED_UNSAFE(ptable, kt_recurrence_table,recurrences);
4700   /* $$IMPROVE ME Scan for counts > 1, and if there are none,
4701      return K_NIL. */
4702   if(ptable->table_size == 0)
4703     { return K_NIL; }
4704   {
4705     ALLOC_BOX_PRESUME(kt_recur_tracker,T_RECUR_TRACKER);
4706     /* $$MAKE ME SAFE This assumes that sharing is OK, recurrences
4707        won't mutate the LUT.  When we have COW or similar, make it
4708        safe.  At least check for immutability.  */
4709     pdata->objs       = ptable->objs;
4710     pdata->table_size = ptable->table_size;
4711     pdata->current_index = 0;
4712     pdata->entries =
4713       GC_MALLOC_ATOMIC(sizeof(recur_entry) * ptable->table_size);
4714     int i;
4715     for(i = 0; i < ptable->table_size; i++)
4716       {
4717         recur_entry * p_entry = &pdata->entries[i];
4718         p_entry->count = ptable->counts[i];
4719         p_entry->index_in_walk = 0;
4720         p_entry->seen_in_walk  = 0;
4721       }
4722     return PTR2PKO(pbox);
4723   }
4724 }
4725 /*_    . recurrences_list_objects */
4726 /* $$WRITE ME  Get a list of all objects and their recurrence counts */
4727 /*_    . objtable_get_index */
4728 int
4729 objtable_get_index
4730 (pko * objs, int table_size, pko obj)
4731 {
4732   int i;
4733   for(i = 0; i < table_size; i++)
4734     {
4735       if(obj == objs[i])
4736         { return i; }
4737     }
4738   return -1;
4739 }
4740 /*_    . recurrences_get_seen_count */
4741 /* Return the number of times OBJ has been seen before.  If "add" is
4742    non-zero, increment the count too (but return its previous
4743    value).  */
4744 int
4745 recurrences_get_seen_count
4746 (kt_recurrence_table * p_cycles_data, pko obj, int add)
4747 {
4748   int index = objtable_get_index(p_cycles_data->objs,
4749                                  p_cycles_data->table_size,
4750                                  obj);
4751   if(index >= 0)
4752     {
4753       int count = p_cycles_data->counts[index];
4754       /* Maybe record another sighting of this object. */
4755       if(add)
4756         { p_cycles_data->counts[index]++; }
4757       /* We've found our return value. */
4758       return count;
4759     }
4760
4761   /* We only get here if search didn't find anything. */
4762   /* Make sure we have enough space for this object. */
4763   if(add)
4764     {
4765       if(p_cycles_data->table_size == p_cycles_data->alloced_size)
4766         {
4767           p_cycles_data->alloced_size *= 2;
4768           p_cycles_data->counts = GC_REALLOC(p_cycles_data->counts, sizeof(int) * p_cycles_data->alloced_size);
4769           p_cycles_data->objs = GC_REALLOC(p_cycles_data->objs, sizeof(pko) * p_cycles_data->alloced_size);
4770         }
4771       int index = p_cycles_data->table_size;
4772       /* Record what it was */
4773       p_cycles_data->objs[index] = obj;
4774       /* We have now seen it once. */
4775       p_cycles_data->counts[index] = 1;
4776       p_cycles_data->table_size++;
4777     }
4778   return 0;
4779 }
4780 /*_    . recurrences_get_object_count */
4781 /* Given an object, list its count */
4782 SIG_CHKARRAY(recurrences_get_object_count) =
4783 { REF_OPER(is_recurrence_table), K_ANY, };
4784 DEF_SIMPLE_APPLICATIVE(p00a2, recurrences_get_object_count,T_NO_K,ground, "recurrences-get-object-count")
4785 {
4786   WITH_2_ARGS(table, obj);
4787   WITH_PSYC_UNBOXED(kt_recurrence_table,table, T_RECURRENCES, 0);
4788   int seen_count = recurrences_get_seen_count(pdata, obj, 0);
4789   return mk_integer(seen_count);
4790 }
4791 /*_    . init_recurrence_table */
4792 void
4793 init_recurrence_table(kt_recurrence_table * p_cycles_data, int initial_size)
4794 {
4795   p_cycles_data->objs   = initial_size ?
4796     GC_MALLOC(sizeof(pko) * initial_size) : 0;
4797   p_cycles_data->counts = initial_size ?
4798     GC_MALLOC(sizeof(int) * initial_size)     : 0;
4799   p_cycles_data->alloced_size = initial_size;
4800   p_cycles_data->table_size = 0;
4801 }
4802 /*_    . trace_tree_cycles */
4803 static void
4804 trace_tree_cycles
4805 (pko tree, kt_recurrence_table * p_cycles_data)
4806 {
4807   /* Special case for the "empty container", not because it's just a
4808      key but because "exploring" it does nothing. */
4809   if (tree == K_NIL)
4810     { return; }
4811   /* Maybe skip this object entirely */
4812   /* $$IMPROVE ME Parameterize this */
4813   switch(_get_type(tree))
4814     {
4815     case T_SYMBOL:
4816     case T_NUMBER:
4817       return;
4818     default:
4819       break;
4820     }
4821   if(recurrences_get_seen_count(p_cycles_data,tree, 1) != 0)
4822     { return; }
4823
4824   /* Switch on tree type */
4825   switch(_get_type(tree))
4826     {
4827     case T_PAIR:
4828       {
4829 #define _EXPLORE_FUNC(X) trace_tree_cycles(X, p_cycles_data)
4830         EXPLORE_v2(tree);
4831 #undef _EXPLORE_FUNC
4832         break;
4833       }
4834     default:
4835       break;
4836       /* Done this exploration */
4837     }
4838   return;
4839 }
4840
4841 /*_    . get_recurrences */
4842 SIG_CHKARRAY(get_recurrences) = { K_ANY, };
4843 DEF_SIMPLE_APPLICATIVE (ps0a1, get_recurrences,T_NO_K,ground, "get-recurrences")
4844 {
4845   WITH_1_ARGS(tree);
4846   /* No reason to even start exploring non-containers */
4847   /* $$IMPROVE ME  Allow containers other than pairs */
4848   int explore_p = (_get_type(tree) == T_PAIR);
4849   ALLOC_BOX_PRESUME(kt_recurrence_table, T_RECURRENCES);
4850   init_recurrence_table(pdata, explore_p ? 8 : 0);
4851   if(explore_p)
4852     { trace_tree_cycles(tree,pdata); }
4853   return PTR2PKO(pbox);
4854 }
4855
4856 /*_  . Reading */
4857
4858 /*_   , Making result objects */
4859
4860 /* make symbol or number atom from string */
4861 static pko
4862 mk_atom (klink * sc, char *q)
4863 {
4864   char c, *p;
4865   int has_dec_point = 0;
4866   int has_fp_exp = 0;
4867
4868 #if USE_COLON_HOOK
4869   if ((p = strstr (q, "::")) != 0)
4870     {
4871       *p = 0;
4872       return mcons (sc->COLON_HOOK,
4873                    mcons (mcons (sc->QUOTE,
4874                                mcons (mk_atom (sc, p + 2), K_NIL)),
4875                          mcons (mk_symbol (strlwr (q)), K_NIL)));
4876     }
4877 #endif
4878
4879   p = q;
4880   c = *p++;
4881   if ((c == '+') || (c == '-'))
4882     {
4883       c = *p++;
4884       if (c == '.')
4885         {
4886           has_dec_point = 1;
4887           c = *p++;
4888         }
4889       if (!isdigit (c))
4890         {
4891           return (mk_symbol (strlwr (q)));
4892         }
4893     }
4894   else if (c == '.')
4895     {
4896       has_dec_point = 1;
4897       c = *p++;
4898       if (!isdigit (c))
4899         {
4900           return (mk_symbol (strlwr (q)));
4901         }
4902     }
4903   else if (!isdigit (c))
4904     {
4905       return (mk_symbol (strlwr (q)));
4906     }
4907
4908   for (; (c = *p) != 0; ++p)
4909     {
4910       if (!isdigit (c))
4911         {
4912           if (c == '.')
4913             {
4914               if (!has_dec_point)
4915                 {
4916                   has_dec_point = 1;
4917                   continue;
4918                 }
4919             }
4920           else if ((c == 'e') || (c == 'E'))
4921             {
4922               if (!has_fp_exp)
4923                 {
4924                   has_dec_point = 1;    /* decimal point illegal
4925                                            from now on */
4926                   p++;
4927                   if ((*p == '-') || (*p == '+') || isdigit (*p))
4928                     {
4929                       continue;
4930                     }
4931                 }
4932             }
4933           return (mk_symbol (strlwr (q)));
4934         }
4935     }
4936   if (has_dec_point)
4937     {
4938       return mk_real (atof (q));
4939     }
4940   return (mk_integer (atol (q)));
4941 }
4942
4943 /* make constant */
4944 static pko
4945 mk_sharp_const (char *name)
4946 {
4947   long x;
4948   char tmp[STRBUFFSIZE];
4949
4950   if (!strcmp (name, "t"))
4951     return (K_T);
4952   else if (!strcmp (name, "f"))
4953     return (K_F);
4954   else if (!strcmp (name, "ignore"))
4955     return (K_IGNORE);
4956   else if (!strcmp (name, "inert"))
4957     return (K_INERT);
4958   else if (*name == 'o')
4959     {                           /* #o (octal) */
4960       snprintf (tmp, STRBUFFSIZE, "0%s", name + 1);
4961       sscanf (tmp, "%lo", &x);
4962       return (mk_integer (x));
4963     }
4964   else if (*name == 'd')
4965     {                           /* #d (decimal) */
4966       sscanf (name + 1, "%ld", &x);
4967       return (mk_integer (x));
4968     }
4969   else if (*name == 'x')
4970     {                           /* #x (hex) */
4971       snprintf (tmp, STRBUFFSIZE, "0x%s", name + 1);
4972       sscanf (tmp, "%lx", &x);
4973       return (mk_integer (x));
4974     }
4975   else if (*name == 'b')
4976     {                           /* #b (binary) */
4977       x = binary_decode (name + 1);
4978       return (mk_integer (x));
4979     }
4980   else if (*name == '\\')
4981     {                           /* #\w (character) */
4982       int c = 0;
4983       if (stricmp (name + 1, "space") == 0)
4984         {
4985           c = ' ';
4986         }
4987       else if (stricmp (name + 1, "newline") == 0)
4988         {
4989           c = '\n';
4990         }
4991       else if (stricmp (name + 1, "return") == 0)
4992         {
4993           c = '\r';
4994         }
4995       else if (stricmp (name + 1, "tab") == 0)
4996         {
4997           c = '\t';
4998         }
4999       else if (name[1] == 'x' && name[2] != 0)
5000         {
5001           int c1 = 0;
5002           if (sscanf (name + 2, "%x", &c1) == 1 && c1 < UCHAR_MAX)
5003             {
5004               c = c1;
5005             }
5006           else
5007             {
5008               return K_NIL;
5009             }
5010 #if USE_ASCII_NAMES
5011         }
5012       else if (is_ascii_name (name + 1, &c))
5013         {
5014           /* nothing */
5015 #endif
5016         }
5017       else if (name[2] == 0)
5018         {
5019           c = name[1];
5020         }
5021       else
5022         {
5023           return K_NIL;
5024         }
5025       return mk_character (c);
5026     }
5027   else
5028     return (K_NIL);
5029 }
5030
5031 /*_   , Reading strings */
5032 /* read characters up to delimiter, but cater to character constants */
5033 static char *
5034 readstr_upto (klink * sc, char *delim)
5035 {
5036   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5037
5038   char *p = sc->strbuff;
5039
5040   while ((p - sc->strbuff < sizeof (sc->strbuff)) &&
5041          !is_one_of (delim, (*p++ = inchar (pt))));
5042
5043   if (p == sc->strbuff + 2 && p[-2] == '\\')
5044     {
5045       *p = 0;
5046     }
5047   else
5048     {
5049       backchar (pt, p[-1]);
5050       *--p = '\0';
5051     }
5052   return sc->strbuff;
5053 }
5054
5055 /* skip white characters */
5056 static INLINE int
5057 skipspace (klink * sc)
5058 {
5059   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5060   int c = 0;
5061
5062   do
5063     { c = inchar (pt); }
5064   while (isspace (c));
5065   if (c != EOF)
5066     {
5067       backchar (pt, c);
5068       return 1;
5069     }
5070   else
5071     { return EOF; }
5072 }
5073
5074 /*_   , Utilities */
5075 /* check c is in chars */
5076 static INLINE int
5077 is_one_of (char *s, int c)
5078 {
5079   if (c == EOF)
5080     return 1;
5081   while (*s)
5082     if (*s++ == c)
5083       return (1);
5084   return (0);
5085 }
5086
5087 /*_   , Reading expressions */
5088 /* read string expression "xxx...xxx" */
5089 static pko
5090 readstrexp (klink * sc)
5091 {
5092   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5093   char *p = sc->strbuff;
5094   int c;
5095   int c1 = 0;
5096   enum
5097   { st_ok, st_bsl, st_x1, st_x2, st_oct1, st_oct2 } state = st_ok;
5098
5099   for (;;)
5100     {
5101       c = inchar (pt);
5102       if (c == EOF || p - sc->strbuff > sizeof (sc->strbuff) - 1)
5103         {
5104           return K_F;
5105         }
5106       switch (state)
5107         {
5108         case st_ok:
5109           switch (c)
5110             {
5111             case '\\':
5112               state = st_bsl;
5113               break;
5114             case '"':
5115               *p = 0;
5116               return mk_counted_string (sc->strbuff, p - sc->strbuff);
5117             default:
5118               *p++ = c;
5119               break;
5120             }
5121           break;
5122         case st_bsl:
5123           switch (c)
5124             {
5125             case '0':
5126             case '1':
5127             case '2':
5128             case '3':
5129             case '4':
5130             case '5':
5131             case '6':
5132             case '7':
5133               state = st_oct1;
5134               c1 = c - '0';
5135               break;
5136             case 'x':
5137             case 'X':
5138               state = st_x1;
5139               c1 = 0;
5140               break;
5141             case 'n':
5142               *p++ = '\n';
5143               state = st_ok;
5144               break;
5145             case 't':
5146               *p++ = '\t';
5147               state = st_ok;
5148               break;
5149             case 'r':
5150               *p++ = '\r';
5151               state = st_ok;
5152               break;
5153             case '"':
5154               *p++ = '"';
5155               state = st_ok;
5156               break;
5157             default:
5158               *p++ = c;
5159               state = st_ok;
5160               break;
5161             }
5162           break;
5163         case st_x1:
5164         case st_x2:
5165           c = toupper (c);
5166           if (c >= '0' && c <= 'F')
5167             {
5168               if (c <= '9')
5169                 {
5170                   c1 = (c1 << 4) + c - '0';
5171                 }
5172               else
5173                 {
5174                   c1 = (c1 << 4) + c - 'A' + 10;
5175                 }
5176               if (state == st_x1)
5177                 {
5178                   state = st_x2;
5179                 }
5180               else
5181                 {
5182                   *p++ = c1;
5183                   state = st_ok;
5184                 }
5185             }
5186           else
5187             {
5188               return K_F;
5189             }
5190           break;
5191         case st_oct1:
5192         case st_oct2:
5193           if (c < '0' || c > '7')
5194             {
5195               *p++ = c1;
5196               backchar (pt, c);
5197               state = st_ok;
5198             }
5199           else
5200             {
5201               if (state == st_oct2 && c1 >= 32)
5202                 return K_F;
5203
5204               c1 = (c1 << 3) + (c - '0');
5205
5206               if (state == st_oct1)
5207                 state = st_oct2;
5208               else
5209                 {
5210                   *p++ = c1;
5211                   state = st_ok;
5212                 }
5213             }
5214           break;
5215
5216         }
5217     }
5218 }
5219
5220
5221 /* get token */
5222 static int
5223 token (klink * sc)
5224 {
5225   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5226   int c;
5227   c = skipspace (sc);
5228   if (c == EOF)
5229     {
5230       return (TOK_EOF);
5231     }
5232   switch (c = inchar (pt))
5233     {
5234     case EOF:
5235       return (TOK_EOF);
5236     case '(':
5237       return (TOK_LPAREN);
5238     case ')':
5239       return (TOK_RPAREN);
5240     case '.':
5241       c = inchar (pt);
5242       if (is_one_of (" \n\t", c))
5243         {
5244           return (TOK_DOT);
5245         }
5246       else
5247         {
5248           backchar (pt, c);
5249           backchar (pt, '.');
5250           return TOK_ATOM;
5251         }
5252     case '\'':
5253       return (TOK_QUOTE);
5254     case ';':
5255       while ((c = inchar (pt)) != '\n' && c != EOF)
5256         {}
5257
5258       if (c == EOF)
5259         {
5260           return (TOK_EOF);
5261         }
5262       else
5263         {
5264           return (token (sc));
5265         }
5266     case '"':
5267       return (TOK_DQUOTE);
5268     case '`':
5269       return (TOK_BQUOTE);
5270     case ',':
5271       if ((c = inchar (pt)) == '@')
5272         {
5273           return (TOK_ATMARK);
5274         }
5275       else
5276         {
5277           backchar (pt, c);
5278           return (TOK_COMMA);
5279         }
5280     case '#':
5281       c = inchar (pt);
5282       if (c == '(')
5283         {
5284           return (TOK_VEC);
5285         }
5286       else if (c == '!')
5287         {
5288           while ((c = inchar (pt)) != '\n' && c != EOF)
5289             {}
5290
5291           if (c == EOF)
5292             {
5293               return (TOK_EOF);
5294             }
5295           else
5296             {
5297               return (token (sc));
5298             }
5299         }
5300       else
5301         {
5302           backchar (pt, c);
5303           /* $$UNHACKIFY ME!  This is a horrible hack. */
5304           if (is_one_of (" itfodxb\\", c))
5305             {
5306               return TOK_SHARP_CONST;
5307             }
5308           else
5309             {
5310               return (TOK_SHARP);
5311             }
5312         }
5313     default:
5314       backchar (pt, c);
5315       return (TOK_ATOM);
5316     }
5317 }
5318 /*_   , Nesting check */
5319 /*_    . create_nesting_check */
5320 void create_nesting_check(klink * sc)
5321 { klink_push_dyn_binding(sc,K_NEST_DEPTH,mk_integer(0)); }
5322 /*_    . nest_depth_ok_p */
5323 int nest_depth_ok_p(klink * sc)
5324 {
5325   pko nesting =
5326     klink_find_dyn_binding(sc,K_NEST_DEPTH);
5327   if(!nesting)
5328     { return 1; }
5329   return ivalue(nesting) == 0;
5330 }
5331 /*_    . change_nesting_depth */
5332 void change_nesting_depth(klink * sc, signed int change)
5333 {
5334   pko nesting =
5335     klink_find_dyn_binding(sc,K_NEST_DEPTH);
5336   add_to_ivalue(nesting,change);
5337 }
5338 /*_   , C-style entry points */
5339
5340 /*_    . kernel_read_internal */
5341 /* The only reason that this is separate from kernel_read_sexp is that
5342    it gets a token, which kernel_read_sexp does almost always, except
5343    once when a caller tricks it with TOK_LPAREN, and once when
5344    kernel_read_list effectively puts back a token it didn't decode.  */
5345 static
5346 DEF_APPLICATIVE_W_DESTR (ps0a0, kernel_read_internal, K_NO_TYPE,0,ground, "read")
5347 {
5348   token_t tok = token (sc);
5349   if (tok == TOK_EOF)
5350     {
5351       return K_EOF;
5352     }
5353   sc->tok = tok;
5354   create_nesting_check(sc);
5355   return kernel_read_sexp (sc);
5356 }
5357
5358 /*_    . kernel_read_sexp */
5359 DEF_CFUNC (ps0a0, kernel_read_sexp, K_NO_TYPE,0)
5360 {
5361   switch (sc->tok)
5362     {
5363     case TOK_EOF:
5364       return K_EOF;
5365       /* NOTREACHED */
5366     case TOK_VEC:
5367       CONTIN_0 (vector, sc);
5368
5369       /* fall through */
5370     case TOK_LPAREN:
5371       sc->tok = token (sc);
5372       if (sc->tok == TOK_RPAREN)
5373         {
5374           return K_NIL;
5375         }
5376       else if (sc->tok == TOK_DOT)
5377         {
5378           KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5379         }
5380       else
5381         {
5382           change_nesting_depth(sc, 1);
5383           CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, K_NIL);
5384           CONTIN_0 (kernel_read_sexp, sc);
5385           return K_INERT;
5386         }
5387     case TOK_QUOTE:
5388       {
5389         pko pquote = REF_OPER(arg1);
5390         CONTIN_1 (dcrry_2A01VLL, val2val, sc, pquote);
5391       }
5392       sc->tok = token (sc);
5393       CONTIN_0 (kernel_read_sexp, sc);
5394       return K_INERT;
5395
5396     case TOK_BQUOTE:
5397       sc->tok = token (sc);
5398       if (sc->tok == TOK_VEC)
5399         {
5400           /* $$CLEAN ME Do this more cleanly than by changing tokens
5401              to trick it.  Maybe factor the TOK_LPAREN treatment so we
5402              can schedule it. */
5403           klink_push_cont (sc, REF_OPER (kernel_treat_qquoted_vec));
5404           sc->tok = TOK_LPAREN;
5405           /* $$CLEANUP Seems like this could be combined with the part
5406              afterwards */
5407           CONTIN_0 (kernel_read_sexp, sc);
5408           return K_INERT;
5409         }
5410       else
5411         {
5412           /* Punt for now: Give quoted symbols rather than actual
5413              operators. ,Similarly sc->UNQUOTE, sc->UNQUOTESP */
5414           CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->QQUOTE);
5415         }
5416
5417       CONTIN_0 (kernel_read_sexp, sc);
5418       return K_INERT;
5419
5420     case TOK_COMMA:
5421       CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTE);
5422       sc->tok = token (sc);
5423       CONTIN_0 (kernel_read_sexp, sc);
5424       return K_INERT;
5425     case TOK_ATMARK:
5426       CONTIN_1 (dcrry_2A01VLL, val2val, sc, sc->UNQUOTESP);
5427       sc->tok = token (sc);
5428       CONTIN_0 (kernel_read_sexp, sc);
5429       return K_INERT;
5430     case TOK_ATOM:
5431       return mk_atom (sc, readstr_upto (sc, "();\t\n\r "));
5432     case TOK_DQUOTE:
5433       {
5434         pko x = readstrexp (sc);
5435         if (x == K_F)
5436           {
5437             KERNEL_ERROR_0 (sc, "Error reading string");
5438           }
5439         setimmutable (x);
5440         return x;
5441       }
5442     case TOK_SHARP:
5443       {
5444         pko sharp_hook = sc->SHARP_HOOK;
5445         pko f =
5446           is_symbol(sharp_hook)
5447           ? find_slot_in_env (sc->envir, sharp_hook, 1)
5448           : K_NIL;
5449         if (f == 0)
5450           {
5451             KERNEL_ERROR_0 (sc, "undefined sharp expression");
5452           }
5453         else
5454           {
5455             pko form = mcons (slot_value_in_env (f), K_NIL);
5456             return kernel_eval (sc, form, sc->envir);
5457           }
5458       }
5459     case TOK_SHARP_CONST:
5460       {
5461         pko x = mk_sharp_const (readstr_upto (sc, "();\t\n\r "));
5462         if (x == K_NIL)
5463           {
5464             KERNEL_ERROR_0 (sc, "undefined sharp expression");
5465           }
5466         else
5467           {
5468             return x;
5469           }
5470       }
5471     default:
5472       KERNEL_ERROR_0 (sc, "syntax error: illegal token");
5473     }
5474 }
5475
5476 /*_    . Read list */
5477 /* $$IMPROVE ME  Use currying ops instead of accumulating by hand */
5478 SIG_CHKARRAY(kernel_read_list) = { REF_OPER(is_finite_list),  K_ANY, };
5479 DEF_SIMPLE_CFUNC (ps0a2, kernel_read_list,0)
5480 {
5481   WITH_2_ARGS (old_accum,value);
5482   pko accum = mcons (value, old_accum);
5483   port * pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
5484   sc->tok = token (sc);
5485   if (sc->tok == TOK_EOF)
5486     {
5487       return (K_EOF);
5488     }
5489   else if (sc->tok == TOK_RPAREN)
5490     {
5491       /* $$RECONSIDER ME Why is this done?  To accept CR from user? */
5492       int c = inchar (pt);
5493       if (c != '\n')
5494         {
5495           backchar (pt, c);
5496         }
5497       change_nesting_depth(sc, -1);
5498       return (unsafe_v2reverse_in_place (K_NIL, accum));
5499     }
5500   else if (sc->tok == TOK_DOT)
5501     {
5502       CONTIN_1 (dcrry_2A01VLL, kernel_treat_dotted_list, sc, accum);
5503       sc->tok = token (sc);
5504       CONTIN_0 (kernel_read_sexp, sc);
5505       return K_INERT;
5506     }
5507   else
5508     {
5509       CONTIN_1 (dcrry_2A01VLL, kernel_read_list, sc, accum);
5510       CONTIN_0 (kernel_read_sexp, sc);
5511       return K_INERT;
5512     }
5513 }
5514
5515 /*_    . Treat end of dotted list */
5516 static
5517 DEF_CFUNC (ps0a2, kernel_treat_dotted_list, REF_DESTR(kernel_read_list),T_NO_K)
5518 {
5519   WITH_2_ARGS(args,value);
5520
5521   if (token (sc) != TOK_RPAREN)
5522     {
5523       KERNEL_ERROR_0 (sc, "syntax error: illegal dot expression");
5524     }
5525   else
5526     {
5527       change_nesting_depth(sc, -1);
5528       return (unsafe_v2reverse_in_place (value, args));
5529     }
5530 }
5531
5532 /*_    . Treat quasiquoted vector */
5533 static
5534 DEF_CFUNC (ps0a1, kernel_treat_qquoted_vec, K_ANY,T_NO_K)
5535 {
5536   pko value = arg1;
5537   /* $$IMPROVE ME Include vector applicative directly, not by applying
5538      symbol.  This does need to apply, though, so that backquote (now
5539      seeing a list) can be run on "value" first*/
5540   return (mcons (mk_symbol ("apply"),
5541                 mcons (mk_symbol ("vector"),
5542                       mcons (mcons (sc->QQUOTE, mcons (value, K_NIL)),
5543                             K_NIL))));
5544 }
5545 /*_   , Loading files */
5546 /*_    . load_from_port */
5547 /* $$RETHINK ME  This soon need no longer be a cfunc */
5548 SIG_CHKARRAY(load_from_port) = { REF_OPER(is_inport), REF_OPER(is_environment)};
5549 DEF_SIMPLE_CFUNC(ps0a2,load_from_port,0)
5550 {
5551   WITH_2_ARGS(inport,env);
5552   assert (is_port(inport));
5553   assert (is_environment(env));
5554   /* Print that we're loading (If there's an outport, and we may want
5555      to add a verbosity condition based on a dynamic variable) */
5556   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5557   if(the_outport && (the_outport != K_NIL))
5558     {
5559       port * pt = portvalue(inport);
5560       if(pt->kind & port_file)
5561         {
5562           const char *fname = pt->rep.stdio.filename;
5563           if (!fname)
5564             { fname = "<unknown>"; }
5565           putstr(sc,"Loading ");
5566           putstr(sc,fname);
5567           putstr(sc,"\n");
5568         }
5569     }
5570
5571   /* We will do the evals in ENV */
5572   sc->envir = env;
5573   klink_push_dyn_binding(sc,K_INPORT,inport);
5574   return kernel_rel(sc);
5575 }
5576 /*_    . load */
5577 /* $$OBSOLETE */
5578 SIG_CHKARRAY(k_load_file) = { REF_OPER(is_string), };
5579 DEF_SIMPLE_APPLICATIVE(ps0a1,k_load_file,0,ground, "load")
5580 {
5581   WITH_1_ARGS(filename_ob);
5582   const char * filename = string_value(filename_ob);
5583   pko p = port_from_filename (filename, port_file | port_input);
5584   if (p == K_NIL)
5585     {
5586       KERNEL_ERROR_1(sc,"unable to open", filename_ob);
5587     }
5588
5589   return load_from_port(sc,p,sc->envir);
5590 }
5591 /*_    . get-module-from-port */
5592 SIG_CHKARRAY(k_get_mod_fm_port) =
5593   { REF_OPER(is_port), REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5594 DEF_SIMPLE_APPLICATIVE(ps0a2,k_get_mod_fm_port,0,ground, "get-module-from-port")
5595 {
5596   WITH_2_ARGS(port, params);
5597   pko env = mk_std_environment();
5598   if(params != K_INERT)
5599     {
5600       assert(is_environment(params));
5601       kernel_define (env, mk_symbol ("module-parameters"), params);
5602     }
5603   /* Ultimately return that environment. */
5604   CONTIN_1R(dcrry_NdotALL,val2val,sc,env);
5605   return load_from_port(sc, port,env);
5606 }
5607
5608 /*_  . Printing */
5609 /*_   , Writing chars */
5610 INTERFACE void
5611 putstr (klink * sc, const char *s)
5612 {
5613   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5614   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5615
5616   if (pt->kind & port_file)
5617     {
5618       fputs (s, pt->rep.stdio.file);
5619     }
5620   else
5621     {
5622       for (; *s; s++)
5623         {
5624           if (pt->rep.string.curr != pt->rep.string.past_the_end)
5625             {
5626               *pt->rep.string.curr++ = *s;
5627             }
5628           else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5629             {
5630               *pt->rep.string.curr++ = *s;
5631             }
5632         }
5633     }
5634 }
5635
5636 static void
5637 putchars (klink * sc, const char *s, int len)
5638 {
5639   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5640   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5641
5642   if (pt->kind & port_file)
5643     {
5644       fwrite (s, 1, len, pt->rep.stdio.file);
5645     }
5646   else
5647     {
5648       for (; len; len--)
5649         {
5650           if (pt->rep.string.curr != pt->rep.string.past_the_end)
5651             {
5652               *pt->rep.string.curr++ = *s++;
5653             }
5654           else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5655             {
5656               *pt->rep.string.curr++ = *s++;
5657             }
5658         }
5659     }
5660 }
5661
5662 INTERFACE void
5663 putcharacter (klink * sc, int c)
5664 {
5665   pko the_outport = klink_find_dyn_binding(sc,K_OUTPORT);
5666   port *pt = portvalue (the_outport); /* $$MAKE ME SAFER - check for K_NIL */
5667
5668   if (pt->kind & port_file)
5669     {
5670       fputc (c, pt->rep.stdio.file);
5671     }
5672   else
5673     {
5674       if (pt->rep.string.curr != pt->rep.string.past_the_end)
5675         {
5676           *pt->rep.string.curr++ = c;
5677         }
5678       else if (pt->kind & port_srfi6 && realloc_port_string (pt))
5679         {
5680           *pt->rep.string.curr++ = c;
5681         }
5682     }
5683 }
5684
5685 #define   ok_abbrev(x)   (is_pair(x) && cdr(x) == K_NIL)
5686
5687 static void
5688 printslashstring (klink * sc, char *p, int len)
5689 {
5690   int i;
5691   unsigned char *s = (unsigned char *) p;
5692   putcharacter (sc, '"');
5693   for (i = 0; i < len; i++)
5694     {
5695       if (*s == 0xff || *s == '"' || *s < ' ' || *s == '\\')
5696         {
5697           putcharacter (sc, '\\');
5698           switch (*s)
5699             {
5700             case '"':
5701               putcharacter (sc, '"');
5702               break;
5703             case '\n':
5704               putcharacter (sc, 'n');
5705               break;
5706             case '\t':
5707               putcharacter (sc, 't');
5708               break;
5709             case '\r':
5710               putcharacter (sc, 'r');
5711               break;
5712             case '\\':
5713               putcharacter (sc, '\\');
5714               break;
5715             default:
5716               {
5717                 int d = *s / 16;
5718                 putcharacter (sc, 'x');
5719                 if (d < 10)
5720                   {
5721                     putcharacter (sc, d + '0');
5722                   }
5723                 else
5724                   {
5725                     putcharacter (sc, d - 10 + 'A');
5726                   }
5727                 d = *s % 16;
5728                 if (d < 10)
5729                   {
5730                     putcharacter (sc, d + '0');
5731                   }
5732                 else
5733                   {
5734                     putcharacter (sc, d - 10 + 'A');
5735                   }
5736               }
5737             }
5738         }
5739       else
5740         {
5741           putcharacter (sc, *s);
5742         }
5743       s++;
5744     }
5745   putcharacter (sc, '"');
5746 }
5747
5748 /*_   , Printing atoms */
5749 static void
5750 printatom (klink * sc, pko l)
5751 {
5752   char *p;
5753   int len;
5754   atom2str (sc, l, &p, &len);
5755   putchars (sc, p, len);
5756 }
5757
5758
5759 /* Uses internal buffer unless string pointer is already available */
5760 static void
5761 atom2str (klink * sc, pko l, char **pp, int *plen)
5762 {
5763   WITH_REPORTER(sc);
5764   char *p;
5765   pko p_escapes = klink_find_dyn_binding(sc,K_PRINT_FLAG);
5766   int escapes = (p_escapes == K_T) ? 1 : 0;
5767
5768   if (l == K_NIL)
5769     {
5770       p = "()";
5771     }
5772   else if (l == K_T)
5773     {
5774       p = "#t";
5775     }
5776   else if (l == K_F)
5777     {
5778       p = "#f";
5779     }
5780   else if (l == K_INERT)
5781     {
5782       p = "#inert";
5783     }
5784   else if (l == K_IGNORE)
5785     {
5786       p = "#ignore";
5787     }
5788   else if (l == K_EOF)
5789     {
5790       p = "#<EOF>";
5791     }
5792   else if (is_port (l))
5793     {
5794       p = sc->strbuff;
5795       snprintf (p, STRBUFFSIZE, "#<PORT>");
5796     }
5797   else if (is_number (l))
5798     {
5799       p = sc->strbuff;
5800       if (num_is_integer (l))
5801         {
5802           snprintf (p, STRBUFFSIZE, "%ld", ivalue (l));
5803         }
5804       else
5805         {
5806           snprintf (p, STRBUFFSIZE, "%.10g", rvalue (l));
5807         }
5808     }
5809   else if (is_string (l))
5810     {
5811       if (!escapes)
5812         {
5813           p = string_value (l);
5814         }
5815       else
5816         {                       /* Hack, uses the fact that printing is needed */
5817           *pp = sc->strbuff;
5818           *plen = 0;
5819           printslashstring (sc, string_value (l), string_len (l));
5820           return;
5821         }
5822     }
5823   else if (is_character (l))
5824     {
5825       int c = charvalue (l);
5826       p = sc->strbuff;
5827       if (!escapes)
5828         {
5829           p[0] = c;
5830           p[1] = 0;
5831         }
5832       else
5833         {
5834           switch (c)
5835             {
5836             case ' ':
5837               snprintf (p, STRBUFFSIZE, "#\\space");
5838               break;
5839             case '\n':
5840               snprintf (p, STRBUFFSIZE, "#\\newline");
5841               break;
5842             case '\r':
5843               snprintf (p, STRBUFFSIZE, "#\\return");
5844               break;
5845             case '\t':
5846               snprintf (p, STRBUFFSIZE, "#\\tab");
5847               break;
5848             default:
5849 #if USE_ASCII_NAMES
5850               if (c == 127)
5851                 {
5852                   snprintf (p, STRBUFFSIZE, "#\\del");
5853                   break;
5854                 }
5855               else if (c < 32)
5856                 {
5857                   snprintf (p, STRBUFFSIZE, "#\\%s", charnames[c]);
5858                   break;
5859                 }
5860 #else
5861               if (c < 32)
5862                 {
5863                   snprintf (p, STRBUFFSIZE, "#\\x%x", c);
5864                   break;
5865                   break;
5866                 }
5867 #endif
5868               snprintf (p, STRBUFFSIZE, "#\\%c", c);
5869               break;
5870               break;
5871             }
5872         }
5873     }
5874   else if (is_symbol (l))
5875     {
5876       p = symname (sc,l);
5877     }
5878
5879
5880   else if (is_environment (l))
5881     {
5882       p = "#<ENVIRONMENT>";
5883     }
5884   else if (is_continuation (l))
5885     {
5886       p = "#<CONTINUATION>";
5887     }
5888   else if (is_operative (l)
5889            /* $$TRANSITIONAL  When these can be launched by
5890               themselves, this check will be folded into is_operative */
5891            || is_type (l, T_DESTRUCTURE)
5892            || is_type (l, T_TYPECHECK)
5893            || is_type (l, T_TYPEP))
5894     {
5895       /* $$TRANSITIONAL  This logic will move, probably into
5896          k_print_special_and_balk_p, and become more general. */
5897       pko slot =
5898         print_lookup_unwraps ?
5899         reverse_find_slot_in_env_aux(print_lookup_unwraps,l) :
5900         0;
5901       if(slot)
5902         {
5903           p = sc->strbuff;
5904           snprintf (p, STRBUFFSIZE, ",(unwrap #,%s)", symname(0, car(slot)));
5905         }
5906       else
5907         {
5908           pko slot =
5909             print_lookup_to_xary ?
5910             reverse_find_slot_in_env_aux(print_lookup_to_xary,l) :
5911             0;
5912           if(slot)
5913             {
5914               /* We don't say it's the tree-ary version, because the
5915                  tree-ary conversion is not exposed. */
5916               p = symname(0, car(slot));
5917             }
5918           else
5919             {
5920               pko slot =
5921                 all_builtins_env ?
5922                 reverse_find_slot_in_env_aux(all_builtins_env, l) :
5923                 0;
5924               if(slot)
5925                 {
5926                   p = symname(0, car(slot));
5927                 }
5928               else
5929                 { p = "#<OPERATIVE>"; }}
5930         }
5931     }
5932   else if (is_promise (l))
5933     {
5934       p = "#<PROMISE>";
5935     }
5936   else if (is_applicative (l))
5937     {
5938       p = "#<APPLICATIVE>";
5939     }
5940   else if (is_type (l, T_ENCAP))
5941     {
5942       p = "#<ENCAPSULATION>";
5943     }
5944   else if (is_type (l, T_KEY))
5945     {
5946       p = "#<KEY>";
5947     }
5948   else if (is_type (l, T_RECUR_TRACKER))
5949     {
5950       p = "#<RECURRENCE TRACKER>";
5951     }
5952   else if (is_type (l, T_RECURRENCES))
5953     {
5954       p = "#<RECURRENCE TABLE>";
5955     }
5956   else
5957     {
5958       p = sc->strbuff;
5959       snprintf (p, STRBUFFSIZE, "#<ERROR %d>", _get_type(l));
5960     }
5961   *pp = p;
5962   *plen = strlen (p);
5963 }
5964
5965 /*_   , C-style entry points */
5966 /*_    . Print sexp */
5967 /*_     , kernel_print_sexp */
5968 SIG_CHKARRAY(kernel_print_sexp) =
5969 { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
5970 static
5971 DEF_SIMPLE_CFUNC (ps0a2, kernel_print_sexp,0)
5972 {
5973   WITH_2_ARGS(sexp, lookup_env);
5974   pko recurrences = get_recurrences(sc, sexp);
5975   pko tracker = recurrences_to_recur_tracker(recurrences);
5976   /* $$IMPROVE ME Default to an environment that knows sharp
5977      constants */
5978   return kernel_print_sexp_aux
5979     (sc, sexp,
5980      tracker,
5981      ((lookup_env == K_INERT) ? ground_env : lookup_env));
5982 }
5983 /*_     , k_print_special_and_balk_p */
5984 /* Possibly print a replacement or prefix.  Return 1 if we should now
5985    skip printing sexp (Because it's shared), 0 otherwise. */
5986 static int
5987 k_print_special_and_balk_p
5988 (klink * sc, pko tracker, pko lookup_env, pko sexp)
5989 {
5990   WITH_REPORTER(0);
5991   /* If this object is directly known to printer, print its symbol. */
5992   if(lookup_env != K_NIL)
5993     {
5994       pko slot = reverse_find_slot_in_env_aux(lookup_env,sexp);
5995       if(slot)
5996         {
5997           putstr (sc, "#,");    /* Reader is to convert the symbol */
5998           printatom (sc, car(slot));
5999           return 1;
6000         }
6001     }
6002   if(tracker == K_NIL)
6003     { return 0; }
6004
6005   /* $$IMPROVE ME Parameterize this and share that parameterization
6006      with get_recurrences */
6007   switch(_get_type(sexp))
6008     {
6009     case T_SYMBOL:
6010     case T_NUMBER:
6011       return 0;
6012     default:
6013       break;
6014     }
6015
6016   WITH_PSYC_UNBOXED(kt_recur_tracker,tracker, T_RECUR_TRACKER, sc);
6017   int index = objtable_get_index(pdata->objs,pdata->table_size,sexp);
6018   if(index < 0) { return 0; }
6019   recur_entry * slot = &pdata->entries[index];
6020   if(slot->count <= 1) { return 0; }
6021
6022   if(slot->seen_in_walk)
6023     {
6024       char *p = sc->strbuff;
6025       snprintf (p, STRBUFFSIZE, "#%d", slot->index_in_walk);
6026       putchars (sc, p, strlen (p));
6027       return 1;         /* Skip printing the object */
6028     }
6029   else
6030     {
6031       slot->seen_in_walk = 1;
6032       slot->index_in_walk = pdata->current_index;
6033       pdata->current_index++;
6034       char *p = sc->strbuff;
6035       snprintf (p, STRBUFFSIZE, "#%d=", slot->index_in_walk);
6036       putchars (sc, p, strlen (p));
6037       return 0;         /* Still should print the object */
6038     }
6039 }
6040 /*_     , kernel_print_sexp_aux */
6041 SIG_CHKARRAY(kernel_print_sexp_aux) =
6042 { K_ANY, REF_OPER(is_recur_tracker), REF_OPER(is_environment), };
6043 static
6044 DEF_SIMPLE_CFUNC (ps0a3, kernel_print_sexp_aux,0)
6045 {
6046   WITH_3_ARGS(sexp, recur_tracker, lookup_env);
6047   WITH_REPORTER(0);
6048   if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
6049     { return K_INERT; }
6050   if (is_vector (sexp))
6051     {
6052       putstr (sc, "#(");
6053       CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, sexp,
6054                 mk_integer (0), recur_tracker, lookup_env);
6055       return K_INERT;
6056     }
6057   else if (!is_pair (sexp))
6058     {
6059       printatom (sc, sexp);
6060       return K_INERT;
6061     }
6062   /* $$FIX ME Recognize quote etc.
6063
6064      That is hard since the quote operative is not currently defined
6065      as such and we no longer have syntax.
6066    */
6067   else if (car (sexp) == sc->QUOTE && ok_abbrev (cdr (sexp)))
6068     {
6069       putstr (sc, "'");
6070       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6071     }
6072   else if (car (sexp) == sc->QQUOTE && ok_abbrev (cdr (sexp)))
6073     {
6074       putstr (sc, "`");
6075       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6076     }
6077   else if (car (sexp) == sc->UNQUOTE && ok_abbrev (cdr (sexp)))
6078     {
6079       putstr (sc, ",");
6080       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6081     }
6082   else if (car (sexp) == sc->UNQUOTESP && ok_abbrev (cdr (sexp)))
6083     {
6084       putstr (sc, ",@");
6085       return kernel_print_sexp_aux (sc, cadr (sexp), recur_tracker, lookup_env);
6086     }
6087   else
6088     {
6089       putstr (sc, "(");
6090       CONTIN_0_RAW(REF_OBJ(k_print_terminate_list), sc);
6091       CONTIN_3 (dcrry_2dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
6092       return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
6093     }
6094 }
6095 /*_     , print_value */
6096 DEF_BOXED_CURRIED(print_value,
6097                   dcrry_1VLL,
6098                   REF_KEY(K_NIL),
6099                   REF_OPER (kernel_print_sexp));
6100 /*_    . k_print_string */
6101 SIG_CHKARRAY(k_print_string) = { REF_OPER(is_string), };
6102 static
6103 DEF_SIMPLE_CFUNC (ps0a1, k_print_string,T_NO_K)
6104 {
6105   WITH_1_ARGS(str);
6106   putstr (sc, string_value(str));
6107   return K_INERT;
6108 }
6109 /*_    . k_print_terminate_list */
6110 /* $$RETHINK ME  This may be the long way to do it. */
6111 static
6112 BOX_OF(kt_string) _k_string_rpar =
6113 { T_STRING | T_IMMUTABLE,
6114   { ")", sizeof(")"), },
6115 };
6116 static
6117 BOX_OF(kt_vec2) _k_list_string_rpar =
6118 { T_PAIR | T_IMMUTABLE,
6119   { REF_OBJ(_k_string_rpar), REF_KEY(K_NIL)}
6120 };
6121 static
6122 DEF_BOXED_CURRIED(k_print_terminate_list,
6123                   dcrry_1dotALL,
6124                   REF_OBJ(_k_list_string_rpar),
6125                   REF_OPER(k_print_string));
6126 /*_    . k_newline */
6127 RGSTR(ground, "newline", REF_OBJ(k_newline))
6128 static
6129 BOX_OF(kt_string) _k_string_newline =
6130 { T_STRING | T_IMMUTABLE,
6131   { "\n", sizeof("\n"), }, };
6132 static
6133 BOX_OF(kt_vec2) _k_list_string_newline =
6134 { T_PAIR | T_IMMUTABLE,
6135   { REF_OBJ(_k_string_newline), REF_KEY(K_NIL)}
6136 };
6137 static
6138 DEF_BOXED_CURRIED(k_newline,
6139                   dcrry_1dotALL,
6140                   REF_OBJ(_k_list_string_newline),
6141                   REF_OPER(k_print_string));
6142
6143 /*_    .  kernel_print_list */
6144 static
6145 DEF_CFUNC (ps0a3, kernel_print_list, REF_DESTR(kernel_print_sexp_aux),0)
6146 {
6147   WITH_REPORTER(0);
6148   WITH_3_ARGS(sexp, recur_tracker, lookup_env);
6149   if(is_pair (sexp))  { putstr (sc, " "); }
6150   else if (sexp != K_NIL) { putstr (sc, " . "); }
6151   else { }
6152
6153   if(k_print_special_and_balk_p(sc, recur_tracker, lookup_env, sexp))
6154     { return K_INERT; }
6155   if (is_pair (sexp))
6156     {
6157       CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, cdr (sexp), recur_tracker, lookup_env);
6158       return kernel_print_sexp_aux (sc, car (sexp), recur_tracker, lookup_env);
6159     }
6160   if (is_vector (sexp))
6161     {
6162       /* $$RETHINK ME What does this even print? */
6163       CONTIN_3 (dcrry_3dotALL, kernel_print_list, sc, K_NIL, recur_tracker, lookup_env);
6164       return kernel_print_sexp_aux (sc, sexp, recur_tracker, lookup_env);
6165     }
6166
6167   if (sexp != K_NIL)
6168     {
6169       printatom (sc, sexp);
6170     }
6171   return K_INERT;
6172 }
6173
6174
6175 /*_    .  kernel_print_vec_from */
6176 SIG_CHKARRAY(kernel_print_vec_from) =
6177 { K_ANY,
6178   REF_OPER(is_integer),
6179   REF_OPER(is_recur_tracker),
6180   REF_OPER(is_environment), };
6181 DEF_SIMPLE_CFUNC (ps0a4, kernel_print_vec_from,0)
6182 {
6183   WITH_4_ARGS(vec,k_i, recur_tracker, lookup_env);
6184   int i = ivalue (k_i);
6185   int len = vector_len (vec);
6186   if (i == len)
6187     {
6188       putstr (sc, ")");
6189       return K_INERT;
6190     }
6191   else
6192     {
6193       pko elem = vector_elem (vec, i);
6194       set_ivalue (k_i, i + 1);
6195       CONTIN_4 (dcrry_4dotALL, kernel_print_vec_from, sc, vec, arg2, recur_tracker, lookup_env);
6196       putstr (sc, " ");
6197       return kernel_print_sexp_aux (sc, elem, recur_tracker, lookup_env);
6198     }
6199 }
6200 /*_   , Kernel entry points */
6201 /*_    . write */
6202 DEF_APPLICATIVE_W_DESTR(ps0a1,k_write,K_ANY_SINGLETON,0,ground, "write")
6203 {
6204   WITH_1_ARGS(p);
6205   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
6206   return kernel_print_sexp(sc,p,K_INERT);
6207 }
6208
6209 /*_    . display */
6210 DEF_APPLICATIVE_W_DESTR(ps0a1,k_display,K_ANY_SINGLETON,0,ground, "display")
6211 {
6212   WITH_1_ARGS(p);
6213   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_F);
6214   return kernel_print_sexp(sc,p,K_INERT);
6215 }
6216
6217 /*_   , Tracing */
6218 /*_    . tracing_say */
6219 /* $$TRANSITIONAL  Until we have actual trace hook */
6220 SIG_CHKARRAY(tracing_say) = { REF_OPER(is_string),  K_ANY, };
6221 DEF_SIMPLE_CFUNC (ps0a2, tracing_say,T_NO_K)
6222 {
6223   WITH_2_ARGS(k_string, value);
6224   if (sc->tracing)
6225     {
6226       putstr (sc, string_value(k_string));
6227     }
6228   return value;
6229 }
6230
6231
6232 /*_  . Equivalence */
6233 /*_   , Equivalence of atoms */
6234 SIG_CHKARRAY(eqv) = { K_ANY, K_ANY, };
6235 DEF_SIMPLE_APPLICATIVE(b00a2,eqv,T_NO_K,simple,"equal?/2-atom-atom")
6236 {
6237   WITH_2_ARGS(a,b);
6238
6239   if (is_string (a))
6240     {
6241       if (is_string (b))
6242         {
6243           const char * a_str = string_value (a);
6244           const char * b_str = string_value (b);
6245           if (a_str == b_str) { return 1; }
6246           return !strcmp(a_str, b_str);
6247         }
6248       else
6249         { return (0); }
6250     }
6251   else if (is_number (a))
6252     {
6253       if (is_number (b))
6254         {
6255           if (num_is_integer (a) == num_is_integer (b))
6256             return num_eq (nvalue (a), nvalue (b));
6257         }
6258       return (0);
6259     }
6260   else if (is_character (a))
6261     {
6262       if (is_character (b))
6263         return charvalue (a) == charvalue (b);
6264       else
6265         return (0);
6266     }
6267   else if (is_port (a))
6268     {
6269       if (is_port (b))
6270         return a == b;
6271       else
6272         return (0);
6273     }
6274   else
6275     {
6276       return (a == b);
6277     }
6278 }
6279 /*_   , Equivalence of containers */
6280
6281 /*_  . Hash function */
6282 #if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST)
6283
6284 static int
6285 hash_fn (const char *key, int table_size)
6286 {
6287   unsigned int hashed = 0;
6288   const char *c;
6289   int bits_per_int = sizeof (unsigned int) * 8;
6290
6291   for (c = key; *c; c++)
6292     {
6293       /* letters have about 5 bits in them */
6294       hashed = (hashed << 5) | (hashed >> (bits_per_int - 5));
6295       hashed ^= *c;
6296     }
6297   return hashed % table_size;
6298 }
6299 #endif
6300
6301 /* Quick and dirty hash function for pointers */
6302 static int
6303 ptr_hash_fn(void * ptr, int table_size)
6304 { return (long)ptr % table_size; }
6305
6306 /*_  . binder/accessor maker */
6307 pko make_keyed_variable(pko gen_binder, pko gen_accessor)
6308 {
6309   /* Make a unique key object */
6310   pko key = mk_void();
6311   pko binder = wrap (mk_curried
6312                          (dcrry_3A01dotVLL,
6313                           LIST1(key),
6314                           gen_binder));
6315   pko accessor = wrap (mk_curried
6316                            (dcrry_1A01,
6317                             LIST1(key),
6318                             gen_accessor));
6319   /* Curry and wrap the two things. */
6320   return LIST2 (binder, accessor);
6321 }
6322
6323 /*_  . Environment implementation */
6324 /*_   , New-style environment objects */
6325
6326 /*_    . Types */
6327
6328 /*   T_ENV_FRAME is a vec2 used as a pair in the env tree.  It
6329      indicates a frame boundary.
6330 */
6331 /*   T_ENV_PAIR is another vec2 used as a pair in the env tree.  It
6332      indicates no frame boundary.
6333 */
6334
6335 /* Other types are (hackishly) still shared with the vanilla types:
6336
6337    A vector is interpeted as a hash table vector that is "as if" it
6338    were a list of T_ENV_PAIR.  Each element is an alist of bindings.
6339    It can only hold symbol bindings, not keyed bindings, because we
6340    can't hash keyed bindings.
6341
6342    A pair is interpreted as a binding of something and value.  That
6343    something can be either a symbol or a key (void object).  It is
6344    held directly by an T_ENV_FRAME or T_ENV_PAIR (or "as if", by the
6345    alists of a hash table vector).
6346
6347  */
6348
6349 /*_    . Object functions */
6350
6351 DEF_T_PRED (is_environment, T_ENV_FRAME,ground,"environment?/o1");
6352
6353 /*_   , New environment implementation */
6354
6355 #ifndef USE_ALIST_ENV
6356 static pko
6357 find_slot_in_env_vector (pko eobj, pko hdl)
6358 {
6359   for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
6360     {
6361       assert (is_pair (eobj));
6362       pko slot = unsafe_v2car (eobj);
6363       assert (is_pair (slot));
6364       if (unsafe_v2car (slot) == hdl)
6365         {
6366           return slot;
6367         }
6368     }
6369   return 0;
6370 }
6371
6372 static pko
6373 reverse_find_slot_in_env_vector (pko eobj, pko value)
6374 {
6375   for (; eobj != K_NIL; eobj = unsafe_v2cdr (eobj))
6376     {
6377       assert (is_pair (eobj));
6378       pko slot = unsafe_v2car (eobj);
6379       assert (is_pair (slot));
6380       if (unsafe_v2cdr (slot) == value)
6381         {
6382           return slot;
6383         }
6384     }
6385   return 0;
6386 }
6387 #endif
6388
6389 /*
6390  * If we're using vectors, each frame of the environment may be a hash
6391  * table: a vector of alists hashed by variable name.  In practice, we
6392  * use a vector only for the initial frame; subsequent frames are too
6393  * small and transient for the lookup speed to out-weigh the cost of
6394  * making a new vector.
6395  */
6396 static INLINE pko
6397 make_new_frame(pko old_env)
6398 {
6399   pko new_frame;
6400 #ifndef USE_ALIST_ENV
6401   /* $$IMPROVE ME  Make a better test for whether to make vector. */
6402   /* The interaction-environment has about 300 variables in it. */
6403   if (old_env == K_NIL)
6404     {
6405       new_frame = mk_vector (461, K_NIL);
6406     }
6407   else
6408 #endif
6409     {
6410       new_frame = K_NIL;
6411     }
6412
6413   return v2cons (T_ENV_FRAME, new_frame, old_env);
6414 }
6415
6416 static INLINE void
6417 new_slot_spec_in_env (pko env, pko variable, pko value)
6418 {
6419   assert(is_environment(env));
6420   assert(is_symbol(variable));
6421   pko slot = mcons (variable, value);
6422   pko car_env = unsafe_v2car (env);
6423 #ifndef USE_ALIST_ENV
6424   if (is_vector (car_env))
6425     {
6426       int location = hash_fn (symname (0,variable), vector_len (car_env));
6427
6428       set_vector_elem (car_env, location,
6429                        cons (slot,
6430                              vector_elem (car_env, location)));
6431     }
6432   else
6433 #endif
6434     {
6435       pko new_list = v2cons (T_ENV_PAIR, slot, car_env);
6436       unsafe_v2set_car (env, new_list);
6437     }
6438 }
6439
6440 enum env_frame_search_restriction
6441 {
6442   env_fsr_all,
6443   env_fsr_only_coming_frame,
6444   env_fsr_only_this_frame,
6445 };
6446
6447 /* This explores a tree of bindings, punctuated by frames past which
6448    we sometimes don't search. */
6449 static pko
6450 find_slot_in_env_aux (pko eobj, pko hdl, int restr)
6451 {
6452   if(eobj == K_NIL)
6453     { return 0; }
6454   _kt_tag type = _get_type (eobj);
6455   switch(type)
6456     {
6457       /* We have a slot (Which for now is just a pair) */
6458     case T_PAIR:
6459       if(unsafe_v2car (eobj) == hdl)
6460         { return eobj; }
6461       else
6462         { return 0; }
6463 #ifndef USE_ALIST_ENV
6464     case T_VECTOR:
6465       {
6466         /* Only for symbols. */
6467         if(!is_symbol (hdl)) { return 0; }
6468         int location = hash_fn (symname (0,hdl), vector_len (eobj));
6469         pko el = vector_elem (eobj, location);
6470         return find_slot_in_env_vector (el, hdl);
6471       }
6472 #endif
6473       /* We have some sort of env pair */
6474     case T_ENV_FRAME:
6475       /* Check whether we should keep looking. */
6476       switch(restr)
6477         {
6478         case env_fsr_all:
6479           break;
6480         case env_fsr_only_coming_frame:
6481           restr = env_fsr_only_this_frame;
6482           break;
6483         case env_fsr_only_this_frame:
6484           return 0;
6485         default:
6486           errx (3,
6487                "find_slot_in_env_aux: Bad restriction enum: %d", restr);
6488         }
6489       /* Fallthru */
6490     case T_ENV_PAIR:
6491       {
6492         /* Explore car before cdr */
6493         pko found = find_slot_in_env_aux (unsafe_v2car (eobj), hdl, restr);
6494         if(found) { return found; }
6495         return find_slot_in_env_aux (unsafe_v2cdr (eobj),hdl,restr);
6496       }
6497     default:
6498       /* No other type should be found */
6499       errx (3,
6500            "find_slot_in_env_aux: Bad type: %d", type);
6501       return 0;                 /* NOTREACHED */
6502     }
6503 }
6504
6505 static pko
6506 find_slot_in_env (pko env, pko hdl, int all)
6507 {
6508   assert(is_environment(env));
6509   enum env_frame_search_restriction restr =
6510     all ? env_fsr_all : env_fsr_only_coming_frame;
6511   return find_slot_in_env_aux(env,hdl,restr);
6512 }
6513 /*_   , Reverse find-slot */
6514 /*_    . env_confirm_slot */
6515 static int
6516 env_confirm_slot(pko env, pko slot)
6517 {
6518   assert(is_pair(slot));
6519   return
6520     (find_slot_in_env_aux(env,unsafe_v2car(slot),env_fsr_all) == slot);
6521 }
6522 /*_    . reverse_find_slot_in_env_aux2 */
6523 static pko
6524 reverse_find_slot_in_env_aux2(pko env, pko eobj, pko value)
6525 {
6526   if(eobj == K_NIL)
6527     { return 0; }
6528   _kt_tag type = _get_type (eobj);
6529   switch(type)
6530     {
6531       /* We have a slot (Which for now is just a pair) */
6532     case T_PAIR:
6533       if((unsafe_v2cdr (eobj) == value)
6534          && env_confirm_slot(env, eobj))
6535         { return eobj; }
6536       else
6537         { return 0; }
6538 #ifndef USE_ALIST_ENV
6539     case T_VECTOR:
6540       {
6541         /* $$IMPROVE ME Create a reverse-lookup vector if we come here
6542            and there is none.  */
6543         int i;
6544         for(i = 0; i < vector_len (eobj); ++i)
6545           {
6546             pko slot = reverse_find_slot_in_env_vector(vector_elem (eobj, i), value);
6547             if(slot &&
6548                env_confirm_slot(env, slot))
6549               { return slot; }
6550           }
6551         return 0;
6552       }
6553 #endif
6554       /* We have some sort of env pair */
6555     case T_ENV_FRAME:
6556       /* Fallthru */
6557     case T_ENV_PAIR:
6558       {
6559         /* Explore car before cdr */
6560         pko found =
6561           reverse_find_slot_in_env_aux2 (env, unsafe_v2car (eobj), value);
6562         if(found && env_confirm_slot(env, found))
6563           { return found; }
6564         found =
6565           reverse_find_slot_in_env_aux2 (env, unsafe_v2cdr (eobj), value);
6566         if(found && env_confirm_slot(env, found))
6567           { return found; }
6568         return 0;
6569       }
6570     default:
6571       /* No other type should be found */
6572       errx (3,
6573            "reverse_find_slot_in_env_aux2: Bad type: %d", type);
6574       return 0;                 /* NOTREACHED */
6575     }
6576 }
6577
6578 /*_    . reverse_find_slot_in_env_aux */
6579 static pko
6580 reverse_find_slot_in_env_aux (pko env, pko value)
6581 {
6582   assert(is_environment(env));
6583   return reverse_find_slot_in_env_aux2(env, env, value);
6584 }
6585
6586 /*_    . Entry point */
6587 /* Exposed for testing */
6588 /* NB, args are in different order than in the helpers */
6589 SIG_CHKARRAY(reverse_find_slot_in_env) =
6590 { K_ANY, REF_OPER(is_environment), };
6591 DEF_SIMPLE_APPLICATIVE (ps0a2, reverse_find_slot_in_env,T_NO_K,unsafe, "reverse-lookup")
6592 {
6593   WITH_2_ARGS(value,env);
6594   WITH_REPORTER(0);
6595   pko slot = reverse_find_slot_in_env_aux(env, value);
6596   if(slot) { return car(slot); }
6597   else
6598     {
6599       KERNEL_ERROR_0(sc, "reverse_find_slot_in_env: No match");
6600     }
6601 }
6602
6603 /*_    . reverse-binds?/2 */
6604 /* $$IMPROVE ME  Maybe combine these */
6605 DEF_APPLICATIVE_W_DESTR(b00a2,reverse_binds_p,
6606                         REF_DESTR(reverse_find_slot_in_env),
6607                         T_NO_K,simple,"reverse-binds?/2")
6608 {
6609   WITH_2_ARGS(value,env);
6610   return reverse_find_slot_in_env_aux(env, value) ? 1 : 0;
6611 }
6612 /*_   , Shared functions */
6613
6614 static INLINE void
6615 new_frame_in_env (klink * sc, pko old_env)
6616 {
6617   sc->envir = make_new_frame (old_env);
6618 }
6619
6620 static INLINE void
6621 set_slot_in_env (pko slot, pko value)
6622 {
6623   assert (is_pair (slot));
6624   set_cdr (0, slot, value);
6625 }
6626
6627 static INLINE pko
6628 slot_value_in_env (pko slot)
6629 {
6630   WITH_REPORTER(0);
6631   assert (is_pair (slot));
6632   return cdr (slot);
6633 }
6634
6635 /*_   , Keyed static bindings */
6636 /*_    . Support */
6637 /*_     , Making them */
6638 /* Make a new frame containing just the one keyed static variable. */
6639 static INLINE pko
6640 env_plus_keyed_var (pko key, pko value, pko old_env)
6641 {
6642   pko slot = cons (key, value);
6643   return v2cons (T_ENV_FRAME, slot, old_env);
6644 }
6645 /*_     , Finding them */
6646 /* find_slot_in_env works for this too. */
6647 /*_    . Interface */
6648 /*_     , Binder */
6649 SIG_CHKARRAY(klink_ksb_binder) =
6650 { REF_OPER(is_key),  K_ANY, REF_OPER(is_environment), };
6651 DEF_SIMPLE_CFUNC(ps0a3,klink_ksb_binder,T_NO_K)
6652 {
6653   WITH_3_ARGS(key, value, env);
6654   /* Check that env is in fact a environment. */
6655   if(!is_environment(env))
6656     {
6657       KERNEL_ERROR_1(sc,
6658                      "klink_ksb_binder: Arg 2 must be an environment: ",
6659                      env);
6660     }
6661   /* Return a new environment with just that binding. */
6662   return env_plus_keyed_var(key, value, env);
6663 }
6664
6665 /*_     , Accessor */
6666 SIG_CHKARRAY(klink_ksb_accessor) =
6667 { REF_OPER(is_key), };
6668 DEF_SIMPLE_CFUNC(ps0a1,klink_ksb_accessor,T_NO_K)
6669 {
6670   WITH_1_ARGS(key);
6671   pko value = find_slot_in_env(sc->envir,key,1);
6672   if(!value)
6673     {
6674       KERNEL_ERROR_0(sc, "klink_ksb_accessor: No binding found");
6675     }
6676
6677   return slot_value_in_env (value);
6678 }
6679
6680 /*_     , make_keyed_static_variable */
6681 RGSTR(ground, "make-keyed-static-variable", REF_OPER(make_keyed_static_variable))
6682 DEF_CFUNC(p00a0, make_keyed_static_variable,K_NO_TYPE,T_NO_K)
6683 {
6684   return make_keyed_variable(
6685                              REF_OPER(klink_ksb_binder),
6686                              REF_OPER (klink_ksb_accessor));
6687 }
6688 /*_   , Building environments */
6689 /* Argobject is checked internally, so K_ANY */
6690 DEF_APPLICATIVE_W_DESTR(ps0a1,make_environment,K_ANY,T_NO_K,ground, "make-environment")
6691 {
6692   WITH_1_ARGS(parents);
6693   /* $$IMPROVE ME Factor this so we only call get_list_metrics_aux
6694      once on this object. */
6695   int4 metrics;
6696   get_list_metrics_aux(parents, metrics);
6697   pko typecheck = REF_OPER(is_environment);
6698   /* This will reject dotted lists */
6699   if(!typecheck_repeat(sc,parents,&typecheck,1,1))
6700     {
6701       KERNEL_ERROR_0 (sc, "make_environment: argobject must be a list of environments");
6702     }
6703
6704   /* Collect the parent environments. */
6705   int i;
6706   pko rv_par_list = K_NIL;
6707   for(i = 0; i < metrics[lm_num_pairs]; ++i, parents = pair_cdr(0, parents))
6708     {
6709       pko pare = pair_car(0, parents);
6710       rv_par_list = v2cons (T_ENV_PAIR, pare, rv_par_list);
6711     }
6712
6713   /* Reverse the list in place. */
6714   pko par_list;
6715
6716   par_list = unsafe_v2reverse_in_place(K_NIL, rv_par_list);
6717
6718   /* $$IMPROVE ME Check for redundant environments and skip them.
6719      Check only *previous* environments, because we still need to
6720      search correctly.  When recurrences walks environments too, we
6721      can use that to find them. */
6722   /* $$IMPROVE ME Add to environment information to block rechecks. */
6723
6724   /* Return a new environment with all of those as parents. */
6725   return make_new_frame(par_list);
6726 }
6727 /*_   , bindsp_1 */
6728 RGSTR(simple,"$binds?/2", REF_OPER(bindsp_1))
6729 SIG_CHKARRAY(bindsp_1) =
6730 { REF_OPER(is_environment), REF_OPER(is_symbol), };
6731 DEF_SIMPLE_CFUNC(bs0a2,bindsp_1,T_NO_K)
6732 {
6733   WITH_2_ARGS(env, sym);
6734   return find_slot_in_env(env, sym, 1) ? 1 : 0;
6735 }
6736 /*_   , find-binding */
6737 DEF_APPLICATIVE_W_DESTR(ps0a2,find_binding,REF_DESTR(bindsp_1),T_NO_K,ground,"find-binding")
6738 {
6739   WITH_2_ARGS(env, sym);
6740   pko binding = find_slot_in_env(env, sym, 1);
6741   if(binding)
6742     {
6743       return cons(K_T,slot_value_in_env (binding));
6744     }
6745   else
6746     {
6747       return cons(K_F,K_INERT);
6748     }
6749 }
6750
6751 /*_  . Stack */
6752 /*_   , Enumerations */
6753 enum klink_stack_cell_types
6754 {
6755   ksct_invalid,
6756   ksct_frame,
6757   ksct_binding,
6758   ksct_entry_guards,
6759   ksct_exit_guards,
6760   ksct_profile,
6761   ksct_args,
6762   ksct_arg_barrier,             /* Barrier to propagating pseudo-env. */
6763 };
6764 /*_   , Structs */
6765
6766 struct dump_stack_frame
6767 {
6768   pko envir;
6769   pko ff;
6770 };
6771 struct stack_binding
6772 {
6773   pko key;
6774   pko value;
6775 };
6776
6777 struct stack_guards
6778 {
6779   pko guards;
6780   pko envir;
6781 };
6782
6783 struct stack_profiling
6784 {
6785   pko ff;
6786   int initial_count;
6787   int returned_p;
6788 };
6789
6790 struct stack_arg
6791 {
6792   pko vec;
6793   int frame_depth;
6794 };
6795
6796 typedef struct dump_stack_frame_cell
6797 {
6798   enum klink_stack_cell_types type;
6799   _kt_spagstack next;
6800   union
6801   {
6802     struct dump_stack_frame frame;
6803     struct stack_binding    binding;
6804     struct stack_guards     guards;
6805     struct stack_profiling  profiling;
6806     struct stack_arg        pseudoenv;
6807   } data;
6808 } dump_stack_frame_cell;
6809
6810 /*_   , Initialize */
6811
6812 static INLINE void
6813 dump_stack_initialize (klink * sc)
6814 {
6815   sc->dump = 0;
6816 }
6817
6818 static INLINE int
6819 stack_empty (klink * sc)
6820 { return sc->dump == 0; }
6821
6822 /*_   , Frames */
6823 static int
6824 klink_pop_cont (klink * sc)
6825 {
6826   _kt_spagstack rv_pseudoenvs = 0;
6827
6828   /* Always return frame, which sc->dump will be set to. */
6829   /* for(frame = sc->dump; frame != 0; frame = frame->next) */
6830   while(1)
6831     {
6832       if (sc->dump == 0)
6833         {
6834           return 0;
6835         }
6836       else
6837         {
6838           const _kt_spagstack frame = sc->dump;
6839           if(frame->type == ksct_frame)
6840             {
6841               const struct dump_stack_frame *pdata = &frame->data.frame;
6842               sc->next_func    = pdata->ff;
6843               sc->envir        = pdata->envir;
6844
6845               _kt_spagstack final_frame = frame->next;
6846
6847               /* Add the collected pseudo-env elements */
6848               while(rv_pseudoenvs)
6849                 {
6850                   _kt_spagstack el = rv_pseudoenvs;
6851                   _kt_spagstack new_top = rv_pseudoenvs->next;
6852                   el->next = final_frame;
6853                   final_frame = el;
6854                   rv_pseudoenvs = new_top;
6855                 }
6856               sc->dump = final_frame;
6857               return 1;
6858             }
6859 #ifdef PROFILING
6860           else
6861           if(frame->type == ksct_profile)
6862             {
6863               struct stack_profiling * pdata = &frame->data.profiling;
6864               k_profiling_done_frame(sc,pdata);
6865               sc->dump = frame->next;
6866             }
6867 #endif
6868           else if( frame->type == ksct_args )
6869             {
6870               struct stack_arg * old_pe = &frame->data.pseudoenv;
6871               if(old_pe->frame_depth > 0)
6872                 {
6873                   /* Make a copy, to be re-added lower down */
6874                   _kt_spagstack new_pseudoenv =
6875                     (_kt_spagstack)
6876                     GC_MALLOC (sizeof (dump_stack_frame_cell));
6877                   struct stack_arg * new_pe = &new_pseudoenv->data.pseudoenv;
6878                   new_pe->vec         = old_pe->vec;
6879                   new_pe->frame_depth = old_pe->frame_depth - 1;
6880
6881                   new_pseudoenv->type = ksct_args;
6882                   new_pseudoenv->next = rv_pseudoenvs;
6883                   rv_pseudoenvs = new_pseudoenv;
6884                 }
6885
6886               sc->dump = frame->next;
6887             }
6888           else if( frame->type == ksct_arg_barrier )
6889             {
6890               errx( 0, "Not allowed");
6891               rv_pseudoenvs = 0;
6892               sc->dump = frame->next;
6893             }
6894           else
6895             {
6896               sc->dump = frame->next;
6897             }
6898         }
6899     }
6900 }
6901
6902 static _kt_spagstack
6903 klink_push_cont_aux
6904 (_kt_spagstack old_frame, pko ff, pko env)
6905 {
6906   _kt_spagstack frame =
6907     (_kt_spagstack)
6908     GC_MALLOC (sizeof (dump_stack_frame_cell));
6909   struct dump_stack_frame * pdata = &frame->data.frame;
6910   pdata->ff           = ff;
6911   pdata->envir        = env;
6912
6913   frame->type = ksct_frame;
6914   frame->next = old_frame;
6915   return frame;
6916 }
6917
6918 /* $$MOVE ME */
6919 static void
6920 klink_push_cont (klink * sc, pko ff)
6921 { sc->dump = klink_push_cont_aux(sc->dump, ff, sc->envir); }
6922
6923 /*_   , Dynamic bindings */
6924
6925 /* We do not pop dynamic bindings, only frames. */
6926 /* We deal with dynamic bindings in the context of the interpreter so
6927    that in the future we can cache them. */
6928 static void
6929 klink_push_dyn_binding (klink * sc, pko key, pko value)
6930 {
6931   _kt_spagstack frame =
6932     (_kt_spagstack)
6933     GC_MALLOC (sizeof (dump_stack_frame_cell));
6934   struct stack_binding *pdata = &frame->data.binding;
6935
6936   pdata->key           = key;
6937   pdata->value        = value;
6938
6939   frame->type = ksct_binding;
6940   frame->next = sc->dump;
6941   sc->dump = frame;
6942 }
6943
6944
6945 static pko
6946 klink_find_dyn_binding(klink * sc, pko key)
6947 {
6948   _kt_spagstack frame = sc->dump;
6949   while(1)
6950     {
6951       if (frame == 0)
6952         {
6953           return 0;
6954         }
6955       else
6956         {
6957           if(frame->type == ksct_binding)
6958             {
6959               const struct stack_binding *pdata = &frame->data.binding;
6960               if(pdata->key == key)
6961                 { return pdata->value; }
6962             }
6963           frame = frame->next;
6964         }
6965     }
6966 }
6967 /*_   , Guards */
6968 /*_    . klink_push_guards */
6969 static _kt_spagstack
6970 klink_push_guards
6971 (_kt_spagstack old_frame, pko guards, pko envir, int exit)
6972 {
6973   _kt_spagstack frame =
6974     (_kt_spagstack)
6975     GC_MALLOC (sizeof (dump_stack_frame_cell));
6976   struct stack_guards * pdata = &frame->data.guards;
6977   pdata->guards = guards;
6978   pdata->envir  = envir;
6979
6980   frame->type = exit ? ksct_exit_guards : ksct_entry_guards;
6981   frame->next = old_frame;
6982   return frame;
6983 }
6984 /*_    . get_guards_lo1st */
6985 /* Get a list of guard entries, root-most on top. */
6986 static pko
6987 get_guards_lo1st(_kt_spagstack frame)
6988 {
6989   pko list = K_NIL;
6990   for(; frame != 0; frame = frame->next)
6991     {
6992       if((frame->type == ksct_entry_guards) ||
6993          (frame->type == ksct_exit_guards))
6994         {
6995           list = cons(mk_continuation(frame), list);
6996         }
6997     }
6998
6999   return list;
7000 }
7001 /*_   , Args */
7002 /*_    . Misc */
7003 /*_     , set_nth_arg */
7004 #if 0
7005 /* Set the nth arg */
7006 /* Unused, probably for a while, probably will never be used in this
7007    form. */
7008 int
7009 set_nth_arg(klink * sc, int n, pko value)
7010 {
7011   _kt_spagstack frame = sc->dump;
7012   int i = 0;
7013   for(frame = sc->dump; frame != 0; frame = frame->next)
7014     {
7015       if(frame->type == ksct_args)
7016         {
7017           if( i == n )
7018             {
7019               frame->data.arg = value;
7020               return 1;
7021             }
7022           else
7023             { i++; }
7024         }
7025     }
7026   /* If we got here we never encountered the target. */
7027   return 0;
7028 }
7029 #endif
7030 /*_    . Store from value */
7031 /*_     , push_arg_raw */
7032 _kt_spagstack
7033 push_arg_raw(_kt_spagstack old_frame, pko value, int frame_depth)
7034 {
7035   _kt_spagstack frame =
7036     (_kt_spagstack)
7037     GC_MALLOC (sizeof (dump_stack_frame_cell));
7038
7039   frame->data.pseudoenv.vec = value;
7040   frame->data.pseudoenv.frame_depth = frame_depth;
7041   frame->type = ksct_args;
7042   frame->next = old_frame;
7043   return frame;
7044 }
7045 /*_     , k_do_store */
7046 /* T_STORE */
7047 pko
7048 k_do_store(klink * sc, pko functor, pko value)
7049 {
7050   WITH_PSYC_UNBOXED( kt_opstore, functor, T_STORE, sc );
7051   /* $$MAKE ME SAFE do_destructure must be safe vs resuming.  Error if
7052      not T_NO_K.  Don't try to maybe resume, because so far we never
7053      have to do that.
7054    */
7055   pko vec = do_destructure( sc, value, pdata->destr );
7056   /* Push that as arg */
7057   sc->dump = push_arg_raw (sc->dump, vec, pdata->frame_depth);
7058   return K_INERT;
7059 }
7060 /*_    . Load to value */
7061 /*_     , get_nth_arg */
7062 pko
7063 get_nth_arg( _kt_spagstack frame, int n )
7064 {
7065   int i = 0;
7066   for(; frame != 0; frame = frame->next)
7067     {
7068       if(frame->type == ksct_args)
7069         {
7070           if( i == n )
7071             { return frame->data.pseudoenv.vec; }
7072           else
7073             { i++; }
7074         }
7075     }
7076   /* If we got here we never encountered the target. */
7077   return 0;
7078 }
7079
7080 /*_     , k_load_recurse */
7081 /* $$IMPROVE ME Add a shortcut for accessing value without ever
7082    storing it. */
7083 pko
7084 k_load_recurse( _kt_spagstack frame, pko tree )
7085 {
7086   if(_get_type( tree) == T_PAIR)
7087     {
7088       WITH_PSYC_UNBOXED( kt_vec2, tree, T_PAIR, 0 );
7089       if( is_integer( pdata->_car ) && is_integer( pdata->_cdr ))
7090         {
7091           /* Pair of integers: Look up that item, look up secondary
7092              index, return it */
7093           const int n = ivalue( pdata->_car );
7094           const int m = ivalue( pdata->_cdr );
7095           pko vec = get_nth_arg( frame, n );
7096           assert( vec );
7097           assert( is_vector( vec ));
7098           pko value = basvector_elem( vec, m );
7099           assert( value );
7100           return value;
7101         }
7102       else
7103         {
7104           /* Pair, not integers: Explore car and cdr, return cons of them. */
7105           return cons(
7106                       k_load_recurse( frame, pdata->_car ),
7107                       k_load_recurse( frame, pdata->_cdr ));
7108         }
7109     }
7110   else
7111     {
7112       /* Anything else: Return it literally. */
7113       return tree;
7114     }
7115 }
7116
7117 /*_     , k_do_load */
7118 /* T_LOAD C-destructures as a singleton.  It will contain a tree */
7119 /* This may largely take over for decurriers. */
7120 pko
7121 k_do_load(klink * sc, pko functor, pko value)
7122 {
7123   WITH_PSYC_UNBOXED( pko, functor, T_LOAD, sc );
7124   return k_load_recurse( sc->dump, *pdata );
7125 }
7126
7127 /*_   , Stack ancestry */
7128 /*_    . frame_is_ancestor_of */
7129 int frame_is_ancestor_of(_kt_spagstack frame, _kt_spagstack other)
7130 {
7131   /* Walk from other towards root.  Return 1 if we ever encounter
7132      frame, otherwise 0. */
7133   for(; other != 0; other = other->next)
7134     {
7135       if(other == frame)
7136         { return 1; }
7137     }
7138   return 0;
7139 }
7140 /*_    . special_dynxtnt */
7141 /* Make a child of dynamic extent OUTER that evals with dynamic
7142    environment ENVIR continues normally to PROX_DEST. */
7143 _kt_spagstack special_dynxtnt
7144 (_kt_spagstack outer, _kt_spagstack prox_dest, pko envir)
7145 {
7146   return
7147     klink_push_cont_aux(outer,
7148                         mk_curried(dcrry_2A01VLL,
7149                                    LIST1(mk_continuation(prox_dest)),
7150                                    REF_OPER(invoke_continuation)),
7151                         envir);
7152 }
7153 /*_    . curr_frame_depth */
7154 int curr_frame_depth(_kt_spagstack frame)
7155 {
7156   /* Walk towards root, counting. */
7157   int count = 0;
7158   for(; frame != 0; frame = frame->next, count++)
7159     { }
7160   return count;
7161 }
7162 /*_   , Continuations */
7163 /*_    . Struct */
7164 typedef struct
7165 {
7166   _kt_spagstack frame;
7167 }
7168   continuation_t;
7169
7170 /*_    . Type */
7171 DEF_T_PRED (is_continuation, T_CONTINUATION,ground, "continuation?/o1");
7172 /*_    . Create */
7173 static pko
7174 mk_continuation (_kt_spagstack frame)
7175 {
7176   ALLOC_BOX_PRESUME (continuation_t, T_CONTINUATION);
7177   pdata->frame        = frame;
7178   return PTR2PKO(pbox);
7179 }
7180 /*_    . Parts */
7181 static _kt_spagstack
7182 cont_dump (pko p)
7183 {
7184   WITH_PSYC_UNBOXED(continuation_t,p,T_CONTINUATION,0);
7185   return pdata->frame;
7186 }
7187
7188 /*_    . Continuations WRT interpreter */
7189 /*_     , current_continuation */
7190 static pko
7191 current_continuation (klink * sc)
7192 {
7193   return mk_continuation (sc->dump);
7194 }
7195 /*_    . Operations */
7196 /*_     , invoke_continuation */
7197 /* DOES NOT RETURN */
7198 /* Control is resumed at _klink_cycle */
7199
7200 /* Static and not directly available to Kernel, it's the eventual
7201    target of continuation_to_applicative. */
7202 SIG_CHKARRAY(invoke_continuation) =
7203 { REF_OPER(is_continuation), K_ANY, };
7204 DEF_SIMPLE_CFUNC(vs0a2,invoke_continuation,T_NO_K)
7205 {
7206   WITH_2_ARGS (p, value);
7207   assert(is_continuation(p));
7208   if(p)
7209     { sc->dump = cont_dump (p); }
7210   sc->value = value;
7211   longjmp (sc->pseudocontinuation, 1);
7212 }
7213 /*_     , add_guard */
7214 /* Add the appropriate guard, if any, and return the new proximate
7215    destination. */
7216 _kt_spagstack
7217 add_guard
7218 (_kt_spagstack prox_dest, _kt_spagstack to_contain,
7219  pko guard_list, pko envir, _kt_spagstack outer)
7220 {
7221   WITH_REPORTER(0);
7222   pko x;
7223   for(x = guard_list; x != K_NIL; x = cdr(x))
7224     {
7225       pko selector = car(car(x));
7226       assert(is_continuation(selector));
7227       if(frame_is_ancestor_of(cont_dump(selector), to_contain))
7228         {
7229           /* Call has to take place in the dynamic extent of the
7230              next frame around this set of guards, so that the
7231              interceptor has access to dynamic bindings, but then
7232              control has to continue normally to the next guard or
7233              finally to the destination.
7234
7235              So we extend the next frame with a call to
7236              invoke_continuation, currying the next destination in the
7237              chain.  That does not check guards, so in effect it
7238              continues normally.  Then we extend that with a call to
7239              the interceptor, currying an continuation->applicative of
7240              the guards' outer continuation.
7241
7242              NB, continuation->applicative is correct.  It would be
7243              wrong to shortcircuit it.  Although there are no guards
7244              between there and the outer continuation, the
7245              continuation we pass might be called from another dynamic
7246              context.  But it needs to be unwrapped.
7247           */
7248           pko wrapped_interceptor = cadr(car(x));
7249           assert(is_applicative(wrapped_interceptor));
7250           pko interceptor = unwrap(0,wrapped_interceptor);
7251           assert(is_operative(interceptor));
7252
7253           _kt_spagstack med_frame =
7254             special_dynxtnt(outer, prox_dest, envir);
7255           prox_dest =
7256             klink_push_cont_aux(med_frame,
7257                                 mk_curried(dcrry_2VLLdotALL,
7258                                            LIST1(continuation_to_applicative(mk_continuation(outer))),
7259                                            interceptor),
7260                                 envir);
7261
7262           /* We use only the first match so end the loop. */
7263           break;
7264         }
7265     }
7266   return prox_dest;
7267 }
7268 /*_     , add_guard_chain */
7269 _kt_spagstack
7270 add_guard_chain
7271 (_kt_spagstack prox_dest, pko guard_frame_list, _kt_spagstack to_contain, int exit)
7272 {
7273   WITH_REPORTER(0);
7274   const enum klink_stack_cell_types tag
7275     = exit ? ksct_exit_guards : ksct_entry_guards ;
7276   for( ; guard_frame_list != K_NIL ; guard_frame_list = cdr(guard_frame_list))
7277     {
7278       _kt_spagstack guard_frame = cont_dump(car(guard_frame_list));
7279       if(guard_frame->type == tag)
7280         {
7281           struct stack_guards * pguards = &guard_frame->data.guards;
7282           prox_dest =
7283             add_guard(prox_dest,
7284                       to_contain,
7285                       pguards->guards,
7286                       pguards->envir,
7287                       exit ? guard_frame->next : guard_frame);
7288         }
7289     }
7290   return prox_dest;
7291 }
7292 /*_     , continue_abnormally */
7293 /*** Arrange to "walk" from current continuation to c, passing control
7294      thru appropriate guards.  ***/
7295 SIG_CHKARRAY(continue_abnormally) =
7296 { REF_OPER(is_continuation), K_ANY, };
7297 /* I don't give this T_NO_K even though technically it longjmps
7298    rather than pushing into the eval loop.  In the future we may
7299    distinguish those two cases. */
7300 DEF_SIMPLE_CFUNC(ps0a2,continue_abnormally,0)
7301 {
7302   WITH_2_ARGS(c,value);
7303   WITH_REPORTER(0);
7304   _kt_spagstack source      = sc->dump;
7305   _kt_spagstack destination = cont_dump (c);
7306
7307   /*** Find the guard frames on the intermediate path. ***/
7308
7309   /* Control is exiting our current frame, so collect guards from
7310      there towards root.  What we get is lowest first. */
7311   pko exiting_lo1st = get_guards_lo1st(source);
7312   /* Control is entering c's frame, so collect guards from there
7313      towards root.  Again it's lowest first.  */
7314   pko entering_lo1st = get_guards_lo1st(destination);
7315
7316   /* Remove identical entries from the top, thus removing any merged
7317      part. */
7318   while((exiting_lo1st != K_NIL) &&
7319         (entering_lo1st != K_NIL) &&
7320         (cont_dump(car(exiting_lo1st)) == cont_dump(car(entering_lo1st))))
7321     {
7322       exiting_lo1st  = cdr(exiting_lo1st);
7323       entering_lo1st = cdr(entering_lo1st);
7324     }
7325
7326
7327
7328   /*** Construct a string of calls to the appropriate guards, ending
7329        at destination.  We collect in the reverse of the order that
7330        they will be run, so collect from "entering" first, from
7331        highest to lowest, then collect from "exiting", from lowest to
7332        highest. ***/
7333
7334   _kt_spagstack prox_dest = destination;
7335
7336   pko entering_hi1st = reverse(sc, entering_lo1st);
7337   prox_dest = add_guard_chain(prox_dest, entering_hi1st, destination, 0);
7338   prox_dest = add_guard_chain(prox_dest,  exiting_lo1st, source,      1);
7339
7340   invoke_continuation(sc, mk_continuation(prox_dest), value);
7341   return value;                 /* NOTREACHED */
7342 }
7343
7344 /*_    . Interface */
7345 /*_     , call_cc */
7346 SIG_CHKARRAY(call_cc) = { REF_OPER(is_combiner), };
7347 DEF_SIMPLE_APPLICATIVE(ps0a1,call_cc,0,ground, "call/cc")
7348 {
7349   WITH_1_ARGS(combiner);
7350   pko cc = current_continuation(sc);
7351   return kernel_eval_aux(sc,combiner,LIST1(cc),sc->envir);
7352 }
7353 /*_     , extend-continuation */
7354 /*_      . extend_continuation_aux */
7355 pko
7356 extend_continuation_aux(_kt_spagstack old_frame, pko a, pko env)
7357 {
7358   _kt_spagstack frame = klink_push_cont_aux(old_frame, a, env);
7359   return mk_continuation(frame);
7360 }
7361 /*_      . extend_continuation */
7362 SIG_CHKARRAY(extend_continuation) =
7363 { REF_OPER(is_continuation),
7364   REF_OPER(is_applicative),
7365   REF_KEY(K_TYCH_OPTIONAL),
7366   REF_OPER(is_environment),
7367 };
7368 DEF_SIMPLE_APPLICATIVE(ps0a3, extend_continuation,T_NO_K,ground, "extend-continuation")
7369 {
7370   WITH_3_ARGS(c, a, env);
7371   assert(is_applicative(a));
7372   if(env == K_INERT) { env = make_new_frame(K_NIL); }
7373   return extend_continuation_aux(cont_dump(c), unwrap(sc,a), env);
7374 }
7375 /*_     , continuation->applicative */
7376 SIG_CHKARRAY(continuation_to_applicative) = { REF_OPER(is_continuation), };
7377 DEF_SIMPLE_APPLICATIVE(p00a1,continuation_to_applicative,T_NO_K,ground, "continuation->applicative")
7378 {
7379   WITH_1_ARGS(c);
7380   return
7381     wrap(mk_curried (dcrry_2A01VLL, LIST1(c), REF_OPER(continue_abnormally)));
7382 }
7383
7384 /*_     , guard-continuation */
7385 /* Each guard list is repeat (list continuation applicative) */
7386 /* We'd like to spec that applicative take 2 args, a continuation and
7387    a value, and be wrapped exactly once. */
7388 SIG_CHKARRAY(guard_continuation) =
7389 { K_ANY, REF_OPER(is_continuation), K_ANY, };
7390 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_continuation,T_NO_K,ground, "guard-continuation")
7391 {
7392   WITH_3_ARGS(entry_guards, c, exit_guards);
7393   /* The spec wants an outer continuation to keeps sets of guards from
7394      being mixed together if there are two calls to guard_continuation
7395      with the same c.  But that happens naturally here, so it seems
7396      unneeded.  */
7397
7398   /* $$IMPROVE ME Copy the es of both lists of guards. */
7399   _kt_spagstack frame = cont_dump(c);
7400   if(entry_guards != K_NIL)
7401     {
7402       frame = klink_push_guards(frame, entry_guards, sc->envir, 0);
7403     }
7404   if(exit_guards != K_NIL)
7405     {
7406       frame = klink_push_guards(frame, exit_guards, sc->envir, 1);
7407     }
7408
7409   pko inner_cont = mk_continuation(frame);
7410   return inner_cont;
7411 }
7412
7413 /*_     , guard-dynamic-extent */
7414 SIG_CHKARRAY(guard_dynamic_extent) =
7415   {
7416     REF_OPER(is_finite_list),
7417     REF_OPER(is_applicative),
7418     REF_OPER(is_finite_list),
7419   };
7420   /* DOES NOT RETURN */
7421 DEF_SIMPLE_APPLICATIVE(ps0a3,guard_dynamic_extent,0,ground, "guard-dynamic-extent")
7422 {
7423   WITH_3_ARGS(entry,app,exit);
7424   pko cont = guard_continuation(sc,entry,current_continuation(sc),exit);
7425   pko cont2 = extend_continuation(sc,cont, app, sc->envir);
7426   /* Skip directly into the new continuation, don't invoke the
7427      guards */
7428   invoke_continuation(sc,cont2, K_NIL);
7429   /* NOTREACHED */
7430   return 0;
7431 }
7432
7433 /*_   , Keyed dynamic bindings */
7434 /*_    . klink_kdb_binder */
7435 SIG_CHKARRAY(klink_kdb_binder) =
7436 { REF_OPER(is_key), K_ANY, REF_OPER(is_combiner), };
7437 DEF_SIMPLE_CFUNC(ps0a3,klink_kdb_binder,T_NO_K)
7438 {
7439   WITH_3_ARGS(key, value, combiner);
7440   /* Check that combiner is in fact a combiner. */
7441   if(!is_combiner(combiner))
7442     {
7443       KERNEL_ERROR_1(sc,
7444                      "klink_kdb_binder: Arg 2 must be a combiner: ",
7445                      combiner);
7446     }
7447   /* Push the new binding. */
7448   klink_push_dyn_binding(sc, key, value);
7449   /* $$IMPROVE ME In general, should can control calling better than
7450      this.  Possibly do this thru invoke_continuation, except we're
7451      not arbitrarily changing continuations.  */
7452   /* $$IMPROVE ME Want a better way to control what environment to
7453      push in.  In fact, that's much like a dynamic variable. */
7454   /* $$IMPROVE ME Want a better and cheaper way to make empty
7455      environments. The vector thing should be controlled by a hint. */
7456   /* Make an empty static environment */
7457   new_frame_in_env(sc,K_NIL);
7458   /* Push combiner in that environment. */
7459   klink_push_cont(sc,combiner);
7460   /* And call it with no operands. */
7461   return K_NIL;
7462 }
7463 /* Combines with data to become "an applicative that takes two
7464   arguments, the second of which must be a oper. It calls its
7465   second argument with no operands (nil operand tree) in a fresh empty
7466   environment, and returns the result." */
7467 /*_    . klink_kdb_accessor */
7468 SIG_CHKARRAY(klink_kdb_accessor) =
7469 { REF_OPER(is_key), };
7470 DEF_SIMPLE_CFUNC(ps0a1,klink_kdb_accessor,T_NO_K)
7471 {
7472   WITH_1_ARGS(key);
7473   pko value = klink_find_dyn_binding(sc,key);
7474   if(!value)
7475     {
7476       KERNEL_ERROR_0(sc, "klink_kdb_accessor: No binding found");
7477     }
7478   return value;
7479 }
7480 /* Combines with data to become "an applicative that takes zero
7481   arguments. If the call to a occurs within the dynamic extent of a
7482   call to b, then a returns the value of the first argument passed to
7483   b in the smallest enclosing dynamic extent of a call to b. If the
7484   call to a is not within the dynamic extent of any call to b, an
7485   error is signaled."
7486  */
7487 /*_    . make_keyed_dynamic_variable */
7488 RGSTR(ground, "make-keyed-dynamic-variable", REF_OPER(make_keyed_dynamic_variable))
7489
7490 DEF_CFUNC(p00a0, make_keyed_dynamic_variable,K_NO_TYPE,T_NO_K)
7491 {
7492   return make_keyed_variable(
7493                              REF_OPER(klink_kdb_binder),
7494                              REF_OPER (klink_kdb_accessor));
7495 }
7496 /*_   , Profiling */
7497 #ifdef PROFILING
7498 /*_    . Structs */
7499 typedef struct profiling_data
7500 {
7501   int  num_calls;
7502   long num_evalloops;
7503 } profiling_data;
7504 typedef struct
7505 {
7506   pko     * objs;
7507   profiling_data * entries;
7508   int table_size;
7509   int alloced_size;
7510 } kt_profile_table;
7511 /*_    . Current data */
7512 /* This may be moved to per interpreter, or even more fine-grained. */
7513 /* This may not always be the way we get elapsed counts. */
7514 static long k_profiling_count = 0;
7515 static int k_profiling_p = 0;   /* Are we profiling now? */
7516 /* If we are profiling, init this if it's not initted */
7517 static kt_profile_table k_profiling_table = { 0 };
7518 /*_    . Dealing with table (All will be shared with other lookup tables) */
7519 /*_     , Init */
7520 void
7521 init_profile_table(kt_profile_table * p_table, int initial_size)
7522 {
7523   p_table->objs   = initial_size ?
7524     GC_MALLOC(sizeof(pko) * initial_size) : 0;
7525   p_table->entries = initial_size ?
7526     GC_MALLOC(sizeof(profiling_data) * initial_size)     : 0;
7527   p_table->alloced_size = initial_size;
7528   p_table->table_size = 0;
7529 }
7530 /*_     , Increase its size */
7531 void
7532 enlarge_profile_table(kt_profile_table * p_table)
7533 {
7534   if(p_table->table_size == p_table->alloced_size)
7535     {
7536       p_table->alloced_size *= 2;
7537       p_table->entries = GC_REALLOC(p_table->entries, sizeof(profiling_data) * p_table->alloced_size);
7538       p_table->objs = GC_REALLOC(p_table->objs, sizeof(pko) * p_table->alloced_size);
7539     }
7540
7541
7542 }
7543 /*_     , Searching in it */
7544 /* Use objtable_get_index */
7545 /*_    . On the stack */
7546 static struct stack_profiling *
7547 klink_find_profile_in_frame (_kt_spagstack frame, pko ff)
7548 {
7549   for( ;
7550       (frame != 0) && (frame->type != ksct_frame) ;
7551       frame = frame->next)
7552     {
7553       if(frame->type == ksct_profile)
7554         {
7555           struct stack_profiling *pdata = &frame->data.profiling;
7556           if(pdata->ff == ff) { return pdata; }
7557         }
7558     }
7559   return 0;
7560 }
7561 /*_    . Profile collection operations */
7562 /*_     , When eval loop steps */
7563 void
7564 k_profiling_step(void)
7565 { k_profiling_count++; }
7566 /*_     , When we begin executing a frame */
7567 /* Push a stack_profiling cell onto the frame.  */
7568
7569 void
7570 k_profiling_new_frame(klink * sc, pko ff)
7571 {
7572   if(!k_profiling_p) { return; }
7573   if(!is_operative(ff)) { return; }
7574   /* Do this only if ff is interesting (which for the moment means
7575      that it can be found in ground environment). */
7576   if(!reverse_binds_p(ff, ground_env)           &&
7577      !reverse_binds_p(ff, print_lookup_unwraps) &&
7578      !reverse_binds_p(ff, print_lookup_to_xary))
7579     { return; }
7580   struct stack_profiling * found_profile =
7581     klink_find_profile_in_frame (sc->dump, ff);
7582   /* If the same combiner is already being profiled in this frame,
7583      don't add another copy.  */
7584   if(found_profile)
7585     {
7586       /* $$IMPROVE ME Count tail calls */
7587     }
7588   else
7589     {
7590       /* Push a profiling frame */
7591       _kt_spagstack old_frame = sc->dump;
7592       _kt_spagstack frame =
7593         (_kt_spagstack)
7594         GC_MALLOC (sizeof (dump_stack_frame_cell));
7595       struct stack_profiling * pdata = &frame->data.profiling;
7596       pdata->ff            = ff;
7597       pdata->initial_count = k_profiling_count;
7598       pdata->returned_p    = 0;
7599       frame->type = ksct_profile;
7600       frame->next = old_frame;
7601       sc->dump = frame;
7602     }
7603 }
7604
7605 /*_     , When we pop a stack_profiling cell */
7606 void
7607 k_profiling_done_frame(klink * sc, struct stack_profiling * profile)
7608 {
7609   if(!k_profiling_p) { return; }
7610   profiling_data * pdata = 0;
7611   pko ff = profile->ff;
7612
7613   /* This stack_profiling cell is popped past but it might be used
7614      again if we re-enter, so mark it accordingly. */
7615   profile->returned_p = 1;
7616   if(k_profiling_table.alloced_size == 0)
7617     { init_profile_table(&k_profiling_table, 8); }
7618   else
7619     {
7620       int index = objtable_get_index(k_profiling_table.objs, k_profiling_table.table_size, ff);
7621       if(index >= 0)
7622         { pdata = &k_profiling_table.entries[index]; }
7623     }
7624
7625   /* Create it if needed */
7626   if(!pdata)
7627     {
7628       /* Increase size as needed */
7629       enlarge_profile_table(&k_profiling_table);
7630       /* Add entry */
7631       const int index = k_profiling_table.table_size;
7632       k_profiling_table.objs[index] = ff;
7633       k_profiling_table.table_size++;
7634       pdata = &k_profiling_table.entries[index];
7635       /* Initialize it here */
7636       pdata->num_calls     = 0;
7637       pdata->num_evalloops = 0;
7638     }
7639
7640   /* Add to its counts: Num calls.  Num eval-loops taken. */
7641   pdata->num_calls++;
7642   pdata->num_evalloops += k_profiling_count - profile->initial_count;
7643 }
7644 /*_    . Interface */
7645 /*_     , Turn profiling on */
7646 /* Maybe better as a command-line switch or binder. */
7647 SIG_CHKARRAY(profiling) = { REF_OPER(is_integer), };
7648 DEF_SIMPLE_APPLICATIVE (ps0a1, profiling,T_NO_K,ground, "profiling")
7649 {
7650   WITH_1_ARGS(profile_p);
7651   int pr = k_profiling_p;
7652   k_profiling_p = ivalue (profile_p);
7653   return mk_integer (pr);
7654 }
7655
7656 /*_     , Dumping profiling data */
7657 /* Return a list of the profiled combiners. */
7658 DEF_APPLICATIVE_W_DESTR(ps0a0,get_profiling_data,K_NO_TYPE,T_NO_K,ground,"get-profiling-data")
7659 {
7660   int index;
7661   pko result_list = K_NIL;
7662   for(index = 0; index < k_profiling_table.table_size; index++)
7663     {
7664       pko ff = k_profiling_table.objs[index];
7665       profiling_data * pdata = &k_profiling_table.entries[index];
7666
7667       /* Element format: (object num-calls num-evalloops) */
7668       result_list = cons(
7669                          LIST3(ff,
7670                                mk_integer(pdata->num_calls),
7671                                mk_integer(pdata->num_evalloops)),
7672                          result_list);
7673     }
7674   /* Don't care about order so no need to reverse the list. */
7675   return result_list;
7676 }
7677 /*_    . Reset profiling data */
7678 /*_   , Alternative definitions for no profiling */
7679 #else
7680 #define k_profiling_step()
7681 #define k_profiling_new_frame(DUMMY, DUMMY2)
7682 #endif
7683 /*_  . Error handling */
7684 /*_   , _klink_error_1 */
7685 static void
7686 _klink_error_1 (klink * sc, const char *s, pko a)
7687 {
7688 #if SHOW_ERROR_LINE
7689   const char *str = s;
7690   char sbuf[STRBUFFSIZE];
7691   pko the_inport = klink_find_dyn_binding(sc,K_INPORT);
7692   if (the_inport && (the_inport != K_NIL))
7693     {
7694       port * pt = portvalue(the_inport);
7695       /* Make sure error is not in REPL */
7696       if((pt->kind & port_file) && (pt->rep.stdio.file != stdin))
7697         {
7698           /* Count is 0-based but print it 1-based. */
7699           int ln = pt->rep.stdio.curr_line + 1;
7700           const char *fname = pt->rep.stdio.filename;
7701
7702           if (!fname)
7703             { fname = "<unknown>"; }
7704
7705           snprintf (sbuf, STRBUFFSIZE, "(%s : %i) %s", fname, ln, s);
7706
7707           str = (const char *) sbuf;
7708         }
7709     }
7710 #else
7711   const char *str = s;
7712 #endif
7713   {
7714     pko err_arg;
7715     pko err_string = mk_string (str);
7716     if (a != 0)
7717       {
7718         err_arg = mcons (a, K_NIL);
7719       }
7720     else
7721       {
7722         err_arg = K_NIL;
7723       }
7724     err_arg = mcons (err_string, err_arg);
7725     invoke_continuation (sc, sc->error_continuation, err_arg);
7726   }
7727   /* NOTREACHED */
7728   return;
7729 }
7730
7731 /*_   , Default cheap error handlers */
7732 /*_    .  kernel_err */
7733 DEF_CFUNC (ps0a1, kernel_err, K_ANY,0)
7734 {
7735   WITH_REPORTER(0);
7736   if(arg1 == K_NIL)
7737     {
7738       putstr (sc, "Error with no arguments.  I know nut-ting!");
7739       return K_INERT;
7740     }
7741   if(!is_finite_list(arg1))
7742     {
7743       putstr (sc, "kernel_err: arg must be a finite list");
7744       return K_INERT;
7745     }
7746
7747   assert(is_pair(arg1));
7748   int got_string = is_string (car (arg1));
7749   pko args_x = got_string ? cdr (arg1) : arg1;
7750   const char *message = got_string ? string_value (car (arg1)) : " -- ";
7751
7752   putstr (sc, "Error: ");
7753   putstr (sc, message);
7754   return kernel_err_x (sc, args_x);
7755 }
7756
7757 /*_    . kernel_err_x */
7758 DEF_CFUNC (ps0a1, kernel_err_x, K_ANY_SINGLETON,0)
7759 {
7760   WITH_1_ARGS(args);
7761   WITH_REPORTER(0);
7762   putstr (sc, " ");
7763   if (args != K_NIL)
7764     {
7765       assert(is_pair(args));
7766       CONTIN_1 (dcrry_1dotALL, kernel_err_x, sc, cdr (args));
7767       klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
7768       CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, car (args));
7769       return K_INERT;
7770     }
7771   else
7772     {
7773       putstr (sc, "\n");
7774       return K_INERT;
7775     }
7776 }
7777 /*_    . kernel_err_return */
7778 DEF_CFUNC(ps0a1,kernel_err_return, K_ANY,0)
7779 {
7780   /* This should not set sc->done, because when it's called it still
7781      must print the error, which may require more eval loops.  */
7782   sc->retcode = 1;
7783   return kernel_err(sc, arg1);
7784 }
7785 /*_   , Interface */
7786 /*_    . error */
7787 DEF_APPLICATIVE_W_DESTR(ps0a1,error,K_ANY,0,ground,"error")
7788 {
7789   WITH_1_ARGS(err_arg);
7790   invoke_continuation (sc, sc->error_continuation, err_arg);
7791   return 0;                     /* NOTREACHED */
7792 }
7793 /*_    . error-descriptor? */
7794 /* $$WRITE ME TO replace the punted version */
7795
7796 /*_  . Support for calling C functions */
7797
7798 /*_   , klink_call_cfunc_aux */
7799 static pko
7800 klink_call_cfunc_aux (klink * sc, const kt_cfunc * p_cfunc, pko * arg_array)
7801 {
7802   switch (p_cfunc->type)
7803     {
7804       /* For these macros, the arglist is parenthesized so is
7805          usable. */
7806
7807       /* ***************************************** */
7808       /* For function types returning bool as int (bXXaX) */
7809 #define CASE_CFUNCTYPE_bX(SUFFIX,ARGLIST)                       \
7810       case klink_ftype_##SUFFIX:                                \
7811         return kernel_bool(p_cfunc->func.f_##SUFFIX ARGLIST)
7812
7813       CASE_CFUNCTYPE_bX (b00a1, (arg_array[0]));
7814       CASE_CFUNCTYPE_bX (b00a2, (arg_array[0], arg_array[1]));
7815       CASE_CFUNCTYPE_bX (bs0a2, (sc, arg_array[0], arg_array[1]));
7816
7817 #undef CASE_CFUNCTYPE_bX
7818
7819
7820       /* ***************************************** */
7821       /* For function types returning pko (pXXaX) */
7822 #define CASE_CFUNCTYPE_pX(SUFFIX,ARGLIST)       \
7823       case klink_ftype_##SUFFIX:                \
7824         return p_cfunc->func.f_##SUFFIX ARGLIST
7825
7826       CASE_CFUNCTYPE_pX (p00a0, ());
7827       CASE_CFUNCTYPE_pX (p00a1, (arg_array[0]));
7828       CASE_CFUNCTYPE_pX (p00a2, (arg_array[0], arg_array[1]));
7829       CASE_CFUNCTYPE_pX (p00a3, (arg_array[0], arg_array[1], arg_array[2]));
7830
7831       CASE_CFUNCTYPE_pX (ps0a0, (sc));
7832       CASE_CFUNCTYPE_pX (ps0a1, (sc, arg_array[0]));
7833       CASE_CFUNCTYPE_pX (ps0a2, (sc, arg_array[0], arg_array[1]));
7834       CASE_CFUNCTYPE_pX (ps0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7835       CASE_CFUNCTYPE_pX (ps0a4, (sc, arg_array[0], arg_array[1],
7836                                  arg_array[2], arg_array[3]));
7837       CASE_CFUNCTYPE_pX (ps0a5, (sc, arg_array[0], arg_array[1], arg_array[2], arg_array[3], arg_array[4]));
7838
7839 #undef CASE_CFUNCTYPE_pX
7840
7841
7842       /* ***************************************** */
7843       /* For function types returning void (vXXaX) */
7844 #define CASE_CFUNCTYPE_vX(SUFFIX,ARGLIST)       \
7845       case klink_ftype_##SUFFIX:                \
7846         p_cfunc->func.f_##SUFFIX ARGLIST;       \
7847       return K_INERT
7848
7849       CASE_CFUNCTYPE_vX (vs0a2, (sc, arg_array[0], arg_array[1]));
7850       CASE_CFUNCTYPE_vX (vs0a3, (sc, arg_array[0], arg_array[1], arg_array[2]));
7851
7852 #undef CASE_CFUNCTYPE_vX
7853
7854     default:
7855       KERNEL_ERROR_0 (sc,
7856                       "kernel_call: About that function type, I know nut-ting!");
7857     }
7858 }
7859 /*_   , klink_call_cfunc */
7860 static pko
7861 klink_call_cfunc (klink * sc, pko functor, pko env, pko args)
7862 {
7863   const kt_cfunc * p_cfunc = get_cfunc_func (functor);
7864   assert(p_cfunc->argcheck);
7865   const int max_args = destructure_how_many (p_cfunc->argcheck);
7866   pko arg_array[max_args];
7867   destructure_to_array(sc,args,
7868                        p_cfunc->argcheck,
7869                        arg_array,
7870                        max_args,
7871                        REF_OPER (k_resume_to_cfunc),
7872                        functor);
7873   return klink_call_cfunc_aux (sc, p_cfunc, arg_array);
7874 }
7875 /*_   , k_resume_to_cfunc */
7876 SIG_CHKARRAY (k_resume_to_cfunc) =
7877 {
7878   REF_OPER (is_destr_result),
7879   REF_KEY (K_TYCH_DOT),
7880   REF_OPER (is_cfunc),
7881 };
7882 DEF_SIMPLE_CFUNC (ps0a2, k_resume_to_cfunc, 0)
7883 {
7884   WITH_2_ARGS (destr_result, functor);
7885   assert_type (0, functor, T_CFUNC);
7886   const int max_args = 5;
7887   pko arg_array[max_args];
7888   destr_result_fill_array (destr_result, max_args, arg_array);
7889   return klink_call_cfunc_aux (sc, get_cfunc_func (functor), arg_array);
7890 }
7891 /*_  . Some decurriers */
7892 static pko
7893 dcrry_2A01VLL (klink * sc, pko args, pko value)
7894 {
7895   WITH_REPORTER(sc);
7896   return LIST2(car (args), value);
7897 }
7898 static pko dcrry_3A01dotVLL (klink * sc, pko args, pko value)
7899 {
7900   WITH_REPORTER(sc);
7901   return cons (car (args), value);
7902 }
7903 static pko
7904 dcrry_2CA01VLLA02 (klink * sc, pko args, pko value)
7905 {
7906   WITH_REPORTER(sc);
7907   return LIST2( cons (car (args), value), cadr (args));
7908 }
7909 /* May not be needed */
7910 static pko
7911 dcrry_3A01A02VLL (klink * sc, pko args, pko value)
7912 {
7913   WITH_REPORTER(sc);
7914   return LIST3(car (args), cadr (args), value);
7915 }
7916 static pko
7917 dcrry_2ALLVLL (klink * sc, pko args, pko value)
7918 {
7919   return LIST2(args, value);
7920 }
7921 static pko dcrry_2ALLV01     (klink * sc, pko args, pko value)
7922 {
7923   WITH_REPORTER(sc);
7924   return LIST2(args, car (value));
7925 }
7926
7927 static pko
7928 dcrry_NCVLLA01dotAX1 (klink * sc, pko args, pko value)
7929 {
7930   WITH_REPORTER(sc);
7931   return cons(cons (value, car (args)), cdr (args));
7932 }
7933 static pko dcrry_NdotALL (klink * sc, pko args, pko value)
7934 { return args; }
7935
7936 static pko dcrry_1ALL (klink * sc, pko args, pko value)
7937 { return cons( args, K_NIL ); }
7938
7939 static pko dcrry_5ALLdotVLL (klink * sc, pko args, pko value)
7940 { return cons (args, value); }
7941
7942 static pko dcrry_NVLLdotALL (klink * sc, pko args, pko value)
7943 { return cons (value, args); }
7944
7945 static pko
7946 dcrry_1VLL (klink * sc, pko args, pko value)
7947 { return LIST1 (value); }
7948
7949 /*_  . Defining */
7950 /*_   , Internal functions */
7951 /*_    . kernel_define_tree_aux */
7952 kt_destr_outcome
7953 kernel_define_tree_aux
7954 (klink * sc, pko value, pko formal, pko env, pko * extra_result)
7955 {
7956   WITH_REPORTER(0);
7957   if (is_pair (formal))
7958     {
7959       if (is_pair (value))
7960         {
7961           kt_destr_outcome outcome =
7962             kernel_define_tree_aux (sc, car (value), car (formal), env,
7963                                     extra_result);
7964           switch (outcome)
7965             {
7966             case destr_success:
7967               /* $$IMPROVE ME On error, give a more accurate position. */
7968               return
7969                 kernel_define_tree_aux (sc, cdr (value), cdr (formal), env,
7970                                         extra_result);
7971             case destr_err:
7972               return destr_err;
7973             case destr_must_call_k:
7974               /* $$IMPROVE ME Also schedule to resume the cdr */
7975               /* Operations to run, in reverse order. */
7976               *extra_result =
7977                 LISTSTAR3(
7978                       /* ^V= #inert */
7979                       REF_OPER (kernel_define_tree),
7980                       /* V= (value formal env) */
7981                       mk_load (LIST3 (cdr (value),
7982                                       cdr (formal),
7983                                       env)),
7984                       *extra_result);
7985               return destr_must_call_k;
7986             default:
7987               errx (7, "Unrecognized enumeration");
7988             }
7989         }
7990       if (is_promise (value))
7991         {
7992           /* Operations to run, in reverse order. */
7993           *extra_result =
7994             LIST5(
7995                   /* ^V= #inert */
7996                   REF_OPER (kernel_define_tree),
7997                   /* V= (forced-value formal env) */
7998                   mk_load (LIST3 (mk_load_ix (0, 0),
7999                                   formal,
8000                                   env)),
8001                   mk_store (K_ANY, 1),
8002                   /* V= forced-argobject */
8003                   REF_OPER (force),
8004                   /* ^V= (value) */
8005                   mk_load (LIST1 (value)));
8006           return destr_must_call_k;
8007         }
8008       else
8009         {
8010           _klink_error_1 (sc,
8011                            "kernel_define_tree: value must be a pair: ", value);
8012           return destr_err;             /* NOTREACHED */
8013         }
8014     }
8015   /* We can encounter NIL at the end of a non-dotted list, so mustn't
8016      try to bind it, and value list must end here too. */
8017   else if (formal == K_NIL)
8018     {
8019       if(value != K_NIL)
8020         {
8021           _klink_error_1 (sc,
8022                            "kernel_define_tree: too many args: ", value);
8023           return destr_err;             /* NOTREACHED */
8024         }
8025       return destr_success;
8026     }
8027   /* If formal is #ignore, don't try to bind it, do nothing. */
8028   else if (formal == K_IGNORE)
8029     {
8030       return destr_success;
8031     }
8032   /* If it's a symbol, bind it.  Even a promise is bound thus. */
8033   else if (is_symbol (formal))
8034     {
8035       kernel_define (env, formal, value);
8036       return destr_success;
8037     }
8038   else
8039     {
8040       _klink_error_1 (sc,
8041                       "kernel_define_tree: can't bind to: ", formal);
8042       return destr_err;         /* NOTREACHED */
8043     }
8044 }
8045 /*_    . kernel_define_tree */
8046 /* This can no longer be assumed to be T_NO_K, in case promises must
8047    be forced. */
8048 SIG_CHKARRAY(kernel_define_tree) =
8049 { K_ANY,  K_ANY, REF_OPER(is_environment), };
8050 DEF_SIMPLE_CFUNC(vs0a3,kernel_define_tree,0)
8051 {
8052   WITH_3_ARGS(value, formal, env);
8053   pko extra_result;
8054   kt_destr_outcome outcome =
8055     kernel_define_tree_aux(sc, value, formal, env, &extra_result);
8056   switch (outcome)
8057     {
8058     case destr_success:
8059       break;
8060     case destr_err:
8061       /* Later this may raise the error */
8062       return;
8063     case destr_must_call_k:
8064       schedule_rv_list (sc, extra_result);
8065       return;
8066     default:
8067       errx (7, "Unrecognized enumeration");
8068     }
8069 }
8070 /*_    . kernel_define */
8071 SIG_CHKARRAY(kernel_define) =
8072 {
8073   REF_OPER(is_environment),
8074   REF_OPER(is_symbol),
8075   K_ANY,
8076 };
8077 DEF_SIMPLE_CFUNC(p00a3,kernel_define,T_NO_K)
8078 {
8079   WITH_3_ARGS(env, symbol, value);
8080   assert(is_symbol(symbol));
8081   pko x = find_slot_in_env (env, symbol, 0);
8082   if (x != 0)
8083     {
8084       set_slot_in_env (x, value);
8085     }
8086   else
8087     {
8088       new_slot_spec_in_env (env, symbol, value);
8089     }
8090   return K_INERT;
8091 }
8092 void klink_define (klink * sc, pko symbol, pko value)
8093 { kernel_define(sc->envir,symbol,value); }
8094
8095 /*_   , Supporting kernel registerables */
8096 /*_    . eval_define */
8097 RGSTR(ground, "$define!", REF_OPER(eval_define))
8098 SIG_CHKARRAY(eval_define) =
8099 { K_ANY, K_ANY, };
8100 DEF_SIMPLE_CFUNC(ps0a2,eval_define,0)
8101 {
8102   pko env = sc->envir;
8103   WITH_2_ARGS(formal, expr);
8104   CONTIN_2(dcrry_3VLLdotALL,kernel_define_tree,sc,formal,env);
8105   /* Using args functionality:
8106      BEFORE:
8107      make 2 new slots
8108      put formal in 2,
8109      put env in 3,
8110
8111      RUN, in reverse order
8112      kernel_define_tree (CONTIN_0)
8113      make arglist from 3 args ($$WRITE MY SUPPORT) - or from 2 args and value.
8114      (The 2 slots will go here)
8115      put return value in new slot ($$WRITE MY SUPPORT)
8116      kernel_eval
8117
8118
8119      Possibly "make arglist" will be an array of integers, -1 meaning
8120      the current value.  And on its own it could do decurrying.
8121    */
8122   return kernel_eval(sc,expr,env);
8123 }
8124 /*_    . set */
8125 RGSTR(ground, "$set!", REF_OPER(set))
8126 SIG_CHKARRAY(set) =
8127 { K_ANY, K_ANY, K_ANY, };
8128 DEF_SIMPLE_CFUNC(ps0a3,set,0)
8129 {
8130   pko env = sc->envir;
8131   WITH_3_ARGS(env_expr, formal, expr);
8132   /* Using args functionality:
8133
8134      RUN, in reverse order
8135      kernel_define_tree (CONTIN_0)
8136      make arglist from 3 args - or from 2 args and value.
8137      put return value in new slot
8138      kernel_eval
8139      make arglist from 1 arg
8140      env_expr in slot
8141      formal in slot
8142      put return value in new slot
8143      kernel_eval
8144      expr (Passed directly)
8145
8146    */
8147
8148   CONTIN_0(kernel_define_tree,sc);
8149   return
8150     kernel_mapeval(sc, K_NIL,
8151                    LIST3(expr,
8152                          LIST2(REF_OPER (arg1), formal),
8153                          env_expr),
8154                    env);
8155 }
8156
8157 /*_  . Misc Kernel functions */
8158 /*_   , tracing */
8159
8160 SIG_CHKARRAY(tracing) = { REF_OPER(is_integer), };
8161 DEF_SIMPLE_APPLICATIVE (ps0a1, tracing,T_NO_K,ground, "tracing")
8162 {
8163   WITH_1_ARGS(trace_p);
8164   int tr = sc->tracing;
8165   sc->tracing = ivalue (trace_p);
8166   return mk_integer (tr);
8167 }
8168
8169 /*_   , new_tracing */
8170
8171 SIG_CHKARRAY(new_tracing) = { REF_OPER(is_integer), };
8172 DEF_SIMPLE_APPLICATIVE (ps0a1, new_tracing,T_NO_K,ground, "new-tracing")
8173 {
8174   WITH_1_ARGS(trace_p);
8175   int tr = sc->new_tracing;
8176   sc->new_tracing = ivalue (trace_p);
8177   return mk_integer (tr);
8178 }
8179
8180
8181 /*_   , get-current-environment */
8182 DEF_APPLICATIVE_W_DESTR (ps0a0, get_current_environment, K_NO_TYPE,T_NO_K,ground, "get-current-environment")
8183 { return sc->envir; }
8184
8185 /*_   , arg1, $quote, list */
8186 DEF_APPLICATIVE_W_DESTR (ps0a1, arg1, K_ANY_SINGLETON,T_NO_K,ground, "identity")
8187 {
8188   WITH_1_ARGS(p);
8189   return p;
8190 }
8191 /* Same, unwrapped */
8192 RGSTR(ground, "$quote",   REF_OPER(arg1))
8193
8194 /*_   , val2val */
8195 RGSTR(ground, "list", REF_APPL(val2val))
8196 /* The underlying C function here is "arg1", but it's called with
8197    the whole argobject as arg1 */
8198 /* K_ANY instead of REF_OPER(is_finite_list) because we deliberately allow
8199    non-lists and improper lists. */
8200 DEF_CFUNC_RAW(OPER(val2val),ps0a1,arg1,K_ANY,T_NO_K);
8201 DEF_BOXED_APPLICATIVE(val2val, REF_OPER (val2val));
8202
8203 /*_   , k_quit */
8204 RGSTR(ground,"exit",REF_OPER(k_quit))
8205 DEF_CFUNC(ps0a0,k_quit,K_NO_TYPE,0)
8206 {
8207   if(!nest_depth_ok_p(sc))
8208     { sc->retcode = 1; }
8209
8210   sc->done = 1;
8211   return K_INERT;               /* Value is unused anyways */
8212 }
8213 /*_   , gc */
8214 RGSTR(ground,"gc",REF_OPER(k_gc))
8215 DEF_CFUNC(ps0a0,k_gc,K_NO_TYPE,0)
8216 {
8217   GC_gcollect();
8218   return K_INERT;
8219 }
8220
8221 /*_   , k_if */
8222
8223 RGSTR(ground, "$if", REF_OPER(k_if))
8224 FORWARD_DECL_CFUNC(static,ps0a3,k_if_literal);
8225 SIG_CHKARRAY(k_if) = { K_ANY, K_ANY, K_ANY, };
8226 DEF_SIMPLE_DESTR( k_if );
8227 SIG_CHAIN(k_if) =
8228   {
8229     /* Store (test consequent alternative) */
8230     ANON_STORE(REF_DESTR(k_if)),
8231
8232     ANON_LOAD(ANON_LIST1(ANON_LOAD_IX( 0, 0 ))),
8233     /* value = (test) */
8234
8235     REF_OPER(kernel_eval),
8236     /* test_result */
8237     /* Store (test_result) */
8238     ANON_STORE(K_ANY),
8239
8240     ANON_LOAD(ANON_LIST3(ANON_LOAD_IX( 0, 0 ),
8241                          ANON_LOAD_IX( 1, 1 ),
8242                          ANON_LOAD_IX( 1, 2 ))),
8243
8244     /* test_result, consequent, alternative */
8245     REF_OPER(k_if_literal),
8246   };
8247
8248 DEF_SIMPLE_CHAIN(k_if);
8249
8250 SIG_CHKARRAY(k_if_literal) = { REF_OPER(is_bool), K_ANY, K_ANY, };
8251 DEF_SIMPLE_CFUNC(ps0a3,k_if_literal,0)
8252 {
8253   WITH_3_ARGS(test, consequent, alternative);
8254   if(test == K_T) { return kernel_eval(sc, consequent, sc->envir); }
8255   if(test == K_F) { return kernel_eval(sc, alternative, sc->envir); }
8256   KERNEL_ERROR_1(sc,"Must be a boolean: ", test);
8257 }
8258
8259 /*_  . Routines for applicatives */
8260 BOX_OF_VOID (K_APPLICATIVE);
8261
8262 DEF_SIMPLE_PRED (is_applicative,T_NO_K,ground, "applicative?/o1")
8263 {
8264   WITH_1_ARGS(p);
8265   return is_encap (REF_KEY(K_APPLICATIVE), p);
8266 }
8267
8268 DEF_SIMPLE_PRED (is_combiner,T_NO_K,ground, "combiner?/o1")
8269 {
8270   WITH_1_ARGS(p);
8271   return is_applicative(p) || is_operative(p);
8272 }
8273
8274 SIG_CHKARRAY(wrap) = { REF_OPER(is_combiner) };
8275 DEF_SIMPLE_APPLICATIVE (p00a1, wrap,T_NO_K,ground, "wrap")
8276 {
8277   WITH_1_ARGS(p);
8278   return mk_encap (REF_KEY(K_APPLICATIVE), p);
8279 }
8280
8281 SIG_CHKARRAY(unwrap) = { REF_OPER(is_applicative) };
8282 DEF_SIMPLE_APPLICATIVE (ps0a1, unwrap,T_NO_K,ground, "unwrap")
8283 {
8284   WITH_1_ARGS(p);
8285   return unencap (sc, REF_KEY(K_APPLICATIVE), p);
8286 }
8287
8288 SIG_CHKARRAY(unwrap_all) = { REF_OPER(is_combiner) };
8289 DEF_SIMPLE_APPLICATIVE (p00a1, unwrap_all,T_NO_K,ground, "unwrap-all")
8290 {
8291   WITH_1_ARGS(p);
8292   /* Wrapping does not allowing circular wrapping, so this will
8293      terminate.  */
8294   while(is_encap (REF_KEY(K_APPLICATIVE), p))
8295     { p = unencap (0, REF_KEY(K_APPLICATIVE), p); }
8296   return p;
8297 }
8298
8299
8300 /*_  . Operatives */
8301 /*_   , is_operative */
8302 /* This can be hacked quicker by suppressing 1 more bit and testing
8303  * just once.  Requires keeping those T_ types co-ordinated, though. */
8304 DEF_SIMPLE_PRED (is_operative,T_NO_K,ground, "operative?/o1")
8305 {
8306   WITH_1_ARGS(p);
8307   return
8308        is_type (p, T_CFUNC)
8309     || is_type (p, T_CFUNC_RESUME)
8310     || is_type (p, T_CURRIED)
8311     || is_type (p, T_LISTLOOP)
8312     || is_type (p, T_CHAIN)
8313     || is_type (p, T_STORE)
8314     || is_type (p, T_LOAD)
8315     || is_type (p, T_TYPEP);
8316 }
8317
8318 /*_  . vau_1 */
8319 RGSTR(simple, "$vau/3", REF_OPER(vau_1))
8320
8321 /* This is a simple vau for bootstrap.  It handles just a single
8322    expression.  It's in ground for now, but will be only in
8323    low-for-optimization later */
8324
8325 /* $$IMPROVE ME Check that formals is a non-circular list with no
8326    duplicated symbols.  If this check is typical for
8327    kernel_define_tree (probably), pass that an initially blank
8328    environment and it can check for symbols and error if they are
8329    already defined.
8330
8331    eformal is almost REF_OPER(is_symbol) but must accept #ignore also.
8332 */
8333 SIG_CHKARRAY(vau_1) = { K_ANY, K_ANY, K_ANY };
8334 DEF_SIMPLE_CFUNC (ps0a3, vau_1,0)
8335 {
8336   pko env = sc->envir;
8337   WITH_3_ARGS(formals, eformal, expression);
8338   /* This defines a vau object.  Evaluating it is different.
8339      See 4.10.3 */
8340
8341   /* $$IMPROVE ME Could compile the expression now, but that's not so
8342      easy in Kernel. At least make a hook for that. */
8343
8344   /* Vau data is a list of the 4 things:
8345      The dynamic environment
8346      The eformal symbol
8347      An immutable copy of the formals es
8348      An immutable copy of the expression
8349
8350      $$IMPROVE ME Make not a list but a dedicated struct.
8351    */
8352   pko vau_data =
8353     LIST4(env,
8354           eformal,
8355           copy_es_immutable(sc, formals),
8356           copy_es_immutable (sc, expression));
8357   return
8358     mk_curried (dcrry_5VLLdotALL, vau_data, REF_OPER (eval_vau));
8359 }
8360
8361 /*_  . Evaluation, Kernel style */
8362 /*_   , Calling operatives */
8363 /*_    . eval_vau */
8364 /* Again, can't simply say REF_OPER(is_symbol) because it might be
8365    #ignore */
8366 SIG_CHKARRAY(eval_vau) =
8367 { K_ANY,
8368   REF_OPER(is_environment),
8369   K_ANY,
8370   K_ANY,
8371   K_ANY };
8372 DEF_SIMPLE_CFUNC (ps0a5, eval_vau,0)
8373 {
8374   pko env = sc->envir;
8375   WITH_5_ARGS(args, old_env, eformal, formals, expression);
8376
8377   /* Make a new environment, child of the static environment (which
8378      we get now while making the vau) and put it into the envir
8379      register. */
8380   new_frame_in_env (sc, old_env);
8381
8382   /* This will change in kernel_define, not here. */
8383   /* Bind the dynamic environment to the eformal symbol. */
8384   kernel_define_tree (sc, env, eformal, sc->envir);
8385
8386   /* Bind the formals (symbols) to the operands (values) treewise.  */
8387   pko extra_result;
8388   kt_destr_outcome outcome =
8389     kernel_define_tree_aux(sc, args, formals, sc->envir, &extra_result);
8390   switch (outcome)
8391     {
8392     case destr_success:
8393       break;
8394     case destr_err:
8395       /* Later this may raise the error */
8396       return K_INERT;
8397     case destr_must_call_k:
8398       CONTIN_2 (dcrry_2dotALL, kernel_eval, sc, expression, sc->envir);
8399       schedule_rv_list (sc, extra_result);
8400       return K_INERT;
8401     default:
8402       errx (7, "Unrecognized enumeration");
8403     }
8404
8405   /* Evaluate the expression. */
8406   return kernel_eval (sc, expression, sc->envir);
8407 }
8408
8409 /*_   , Kernel eval mutual callers */
8410 /*_    . kernel_eval */
8411
8412 /* Optionally define a tracing kernel_eval  */
8413 SIG_CHKARRAY(kernel_eval) = { K_ANY, REF_KEY(K_TYCH_OPTIONAL), REF_OPER(is_environment), };
8414 DEF_SIMPLE_DESTR(kernel_eval);
8415 #if USE_TRACING
8416 FORWARD_DECL_CFUNC(static,ps0a2,kernel_real_eval);
8417 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
8418 {
8419   WITH_2_ARGS(form, env);
8420   /* $$RETHINK ME  Set sc->envir here, remove arg from
8421      kernel_real_eval, and the tracing call will know its own env,
8422      it may just be a closure with form as value. */
8423   if(env == K_INERT)
8424     {
8425       env = sc->envir;
8426     }
8427   if (sc->tracing)
8428     {
8429       CONTIN_2 (dcrry_2dotALL, kernel_real_eval, sc, form, env);
8430       putstr (sc, "\nEval: ");
8431       CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, form);
8432       return K_INERT;
8433     }
8434   else
8435     {
8436       return kernel_real_eval (sc, form, env);
8437     }
8438 }
8439 #endif
8440
8441 /* Define either kernel_eval (if not defined above) or kernel_real_eval  */
8442 #if USE_TRACING
8443 /* $$IMPROVE MY DESIGN  Don't like the pointers being different
8444    levels of pointingness.  In fact, we always potentially have
8445    tracing (or w/e) so let's lose the preprocessor condition. */
8446
8447 DEF_CFUNC (ps0a2, kernel_real_eval, REF_DESTR(kernel_eval),0)
8448 #else
8449 DEF_APPLICATIVE_W_DESTR (ps0a2, kernel_eval, REF_DESTR(kernel_eval),0,ground, "eval")
8450 #endif
8451 {
8452   WITH_REPORTER(0);
8453   WITH_2_ARGS(form, env);
8454
8455   /* Evaluate form in env */
8456   /* Arguments:
8457      form: form to be evaluated
8458      env: environment to evaluate it in.
8459    */
8460   assert (form);
8461   assert (env);
8462   /* $$IMPROVE ME Let this be done in kernel_eval and lose the env
8463      argument, here just assert that we have an environment. */
8464   if(env != K_INERT)
8465     {
8466       if (is_environment (env))
8467         { sc->envir = env; }
8468       else
8469         {
8470           KERNEL_ERROR_0 (sc, "eval: Arg 2 must be an environment:");
8471         }
8472     }
8473   /* symbol */
8474   if (is_symbol (form))
8475     {
8476       pko x = find_slot_in_env (env, form, 1);
8477       if (x != 0)
8478         {
8479           return slot_value_in_env (x);
8480         }
8481       else
8482         {
8483           KERNEL_ERROR_1 (sc, "eval: unbound variable:", form);
8484         }
8485     }
8486   /* pair */
8487   else if (is_pair (form))
8488     {
8489       CONTIN_2 (dcrry_3VLLdotALL, kernel_eval_aux, sc, cdr (form), env);
8490       return kernel_eval (sc, car (form), env);
8491     }
8492   /* Otherwise return the object literally. */
8493   else
8494     {
8495       return form;
8496     }
8497 }
8498 /*_    . kernel_eval_aux */
8499 /* The stage of `eval' when we've already decided that we're to use a
8500    combiner and what that combiner is. */
8501 /* $$IMPROVE ME  Lose the env argument, it's always sc->envir */
8502 SIG_CHKARRAY(kernel_eval_aux) =
8503 { REF_OPER(is_combiner), K_ANY, REF_OPER(is_environment), };
8504 DEF_SIMPLE_DESTR(kernel_eval_aux);
8505 DEF_CFUNC (ps0a3, kernel_eval_aux, REF_DESTR(kernel_eval_aux),0)
8506 {
8507   WITH_3_ARGS(functor, args, env);
8508   assert (is_environment (env));
8509   /* Args:
8510      functor: what the car of the form has evaluated to.
8511      args: cdr of form, as yet unevaluated.
8512      env: environment to evaluate in.
8513    */
8514   k_profiling_new_frame(sc, functor);
8515   if(is_type(functor, T_CFUNC))
8516     {
8517       return klink_call_cfunc(sc, functor, env, args);
8518     }
8519   else if(is_type(functor, T_CURRIED))
8520     {
8521       return call_curried(sc, functor, args);
8522     }
8523   else if(is_type(functor, T_TYPEP))
8524     {
8525       /* $$MOVE ME Into something paralleling the other operative calls */
8526       /* $$IMPROVE ME  Check arg number */
8527       WITH_REPORTER(0);
8528       if(!is_pair(args))
8529         { KERNEL_ERROR_1 (sc, "Takes one arg: ", functor); }
8530       return kernel_bool(call_T_typecheck(functor,car(args)));
8531     }
8532   else if(is_type(functor, T_LISTLOOP))
8533     {
8534       return eval_listloop(sc, functor,args);
8535     }
8536   else if(is_type(functor, T_CHAIN))
8537     {
8538       return eval_chain( sc, functor, args );
8539     }
8540   else if ( is_type( functor, T_STORE ))
8541     {
8542       return k_do_store( sc, functor, args );
8543     }
8544   else if ( is_type( functor, T_LOAD ))
8545     {
8546       return k_do_load( sc, functor, args );
8547     }
8548   else if (is_applicative (functor))
8549     {
8550       /* Operation:
8551          Get the underlying operative.
8552          Evaluate arguments (may make frames)
8553          Use the oper on the arguments
8554        */
8555       pko oper = unwrap (sc, functor);
8556       assert (oper);
8557       int4 metrics;
8558       get_list_metrics_aux(args, metrics);
8559       if(metrics[lm_cyc_len] != 0)
8560         {
8561           KERNEL_ERROR_1 (sc, "kernel_eval_aux: Arguments must be a list", args);
8562         }
8563       sc->envir = env;          /* $$IMPROVE ME  Treat this cache better */
8564       CONTIN_2 (dcrry_2CA01VLLA02, kernel_eval, sc, oper, env);
8565 #if USE_TRACING
8566       if (sc->tracing)
8567         {
8568           CONTIN_3 (dcrry_4dotALL, kernel_mapeval, sc, K_NIL, args, env);
8569           CONTIN_1 (dcrry_1dotALL, kernel_print_sexp, sc, args);
8570           putstr (sc, "\nApply to: ");
8571           return K_T;
8572         }
8573       else
8574 #endif
8575         { return kernel_mapeval (sc, K_NIL, args, env); }
8576     }
8577   else
8578     {
8579       KERNEL_ERROR_1 (sc, "eval: can't apply:", functor);
8580     }
8581 }
8582 /*_   , Eval mappers */
8583 /*_    . kernel_mapeval */
8584 /* Evaluate each datum in list arg2, Kernel-returning a list of the results. */
8585 SIG_CHKARRAY(kernel_mapeval) =
8586 { REF_OPER(is_finite_list), REF_OPER(is_finite_list), REF_OPER(is_environment), };
8587 DEF_SIMPLE_DESTR(kernel_mapeval);
8588 DEF_CFUNC (ps0a3, kernel_mapeval, REF_DESTR(kernel_mapeval),0)
8589 {
8590   WITH_REPORTER(0);
8591   WITH_3_ARGS(accum, args, env);
8592   assert (is_environment (env));
8593   /* Arguments:
8594      accum:
8595      * The list of evaluated arguments, in reverse order.
8596      * Purpose: Used as an accumulator.
8597
8598      args: list of forms to be evaluated.
8599      * Precondition: Must be a proper list (is_list must give true)
8600      * When called by itself: The forms that remain yet to be evaluated
8601
8602      env: The environment to evaluate in.
8603   */
8604
8605   /* If there are remaining arguments, arrange to evaluate one,
8606      add the result to accumulator, and return control here. */
8607   if (is_pair (args))
8608     {
8609       /* This can't be converted to a loop because we don't know
8610          whether kernel_eval_aux will create more frames. */
8611       CONTIN_3 (dcrry_3CVLLA01dotAX1,
8612                 kernel_mapeval, sc, accum, cdr (args), env);
8613       return kernel_eval (sc, car (args), env);
8614     }
8615   /* If there are no remaining arguments, reverse the accumulator
8616      and return it.  Can't reverse in place because other
8617      continuations might re-use the same accumulator state.  */
8618   else if (args == K_NIL)
8619     { return reverse (sc, accum); }
8620   else
8621     {
8622       /* This shouldn't be reachable because we check for it being
8623          a list beforehand in kernel_eval_aux. */
8624       errx (4, "mapeval: arguments must be a list:");
8625     }
8626 }
8627
8628 RGSTR(ground,"$bad-sequence",REF_OPER(kernel_sequence))
8629 SIG_CHKARRAY(kernel_sequence) =
8630 { REF_KEY(K_TYCH_DOT), REF_OPER(is_countable_list), };
8631 DEF_SIMPLE_CFUNC(ps0a1,kernel_sequence,0)
8632 {
8633   WITH_1_ARGS(forms);
8634   /* Ultimately return #inert */
8635   /* $$IMPROVE ME This shouldn't accumulate args only to discard
8636      them. */
8637   CONTIN_0_RAW(mk_curried(dcrry_NdotALL, K_INERT, 0), sc);
8638   return kernel_mapeval(sc,K_NIL,forms,sc->envir);
8639 }
8640
8641 /*_    . kernel_mapand_aux */
8642 /* Call proc on each datum in args, Kernel-returning true if all
8643    succeed, otherwise false. */
8644 SIG_CHKARRAY(kernel_mapand_aux) =
8645 { REF_OPER(is_bool),
8646   REF_OPER(is_combiner),
8647   REF_OPER(is_finite_list),
8648 };
8649 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapand_aux,0)
8650 {
8651   WITH_REPORTER(0);
8652   WITH_3_ARGS(ok, proc, args);
8653   /* Arguments:
8654      * succeeded:
8655        * Whether the last invocation of this succeeded.  Initialize with
8656          K_T.
8657
8658      * proc: A boolean combiner (predicate) to apply to these objects
8659
8660      * args: list of objects to apply proc to
8661        * Precondition: Must be a proper list
8662   */
8663   if(ok == K_F)
8664     { return K_F; }
8665   if(ok != K_T)
8666     { KERNEL_ERROR_1(sc, "kernel_mapand_aux: Must be boolean: ", ok); }
8667   /* If there are remaining arguments, arrange to evaluate one and
8668      return control here. */
8669   if (is_pair (args))
8670     {
8671       /* This can't be converted to a loop because we don't know
8672          whether kernel_eval_aux will create more frames. */
8673       CONTIN_2 (dcrry_3VLLdotALL,
8674                 kernel_mapand_aux, sc, proc, cdr (args));
8675       return kernel_eval_aux (sc, proc, car (args), sc->envir);
8676     }
8677   /* If there are no remaining arguments, return true.  */
8678   else if (args == K_NIL)
8679     { return K_T; }
8680   else
8681     {
8682       /* This shouldn't be reachable because we check for it being a
8683          list beforehand. */
8684       errx (4, "mapbool: arguments must be a list:");
8685     }
8686 }
8687
8688 /*_    . kernel_mapand */
8689 SIG_CHKARRAY(kernel_mapand) =
8690 { REF_OPER(is_combiner),
8691   REF_OPER(is_finite_list),
8692 };
8693 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapand,0,simple, "every?/2-xary")
8694 {
8695   WITH_2_ARGS(proc, args);
8696   /* $$IMPROVE ME  Get list metrics here and if we get a circular
8697      list, treat it correctly (How is TBD). */
8698   return kernel_mapand_aux(sc,REF_KEY(K_T), proc, args);
8699 }
8700 /*_    . kernel_mapor_aux */
8701 /* Call proc on each datum in args, Kernel-returning true if all
8702    succeed, otherwise false. */
8703 SIG_CHKARRAY(kernel_mapor_aux) =
8704 { REF_OPER(is_bool),
8705   REF_OPER(is_combiner),
8706   REF_OPER(is_finite_list),
8707 };
8708 DEF_SIMPLE_CFUNC (ps0a3, kernel_mapor_aux,0)
8709 {
8710   WITH_REPORTER(0);
8711   WITH_3_ARGS(ok, proc, args);
8712   /* Arguments:
8713      * succeeded:
8714        * Whether the last invocation of this succeeded.  Initialize with
8715          K_T.
8716
8717      * proc: A boolean combiner (predicate) to apply to these objects
8718
8719      * args: list of objects to apply proc to
8720        * Precondition: Must be a proper list
8721   */
8722   if(ok == K_T)
8723     { return K_T; }
8724   if(ok != K_F)
8725     { KERNEL_ERROR_1(sc, "kernel_mapor_aux: Must be boolean: ", ok); }
8726   /* If there are remaining arguments, arrange to evaluate one and
8727      return control here. */
8728   if (is_pair (args))
8729     {
8730       /* This can't be converted to a loop because we don't know
8731          whether kernel_eval_aux will create more frames. */
8732       CONTIN_2 (dcrry_3VLLdotALL,
8733                 kernel_mapor_aux, sc, proc, cdr (args));
8734       return kernel_eval_aux (sc, proc, car (args), sc->envir);
8735     }
8736   /* If there are no remaining arguments, return false.  */
8737   else if (args == K_NIL)
8738     { return K_F; }
8739   else
8740     {
8741       /* This shouldn't be reachable because we check for it being a
8742          list beforehand. */
8743       errx (4, "mapbool: arguments must be a list:");
8744     }
8745 }
8746 /*_    . kernel_mapor */
8747 SIG_CHKARRAY(kernel_mapor) =
8748 { REF_OPER(is_combiner),
8749   REF_OPER(is_finite_list),
8750 };
8751 DEF_SIMPLE_APPLICATIVE (ps0a2, kernel_mapor,0,simple, "some?/2-xary")
8752 {
8753   WITH_2_ARGS(proc, args);
8754   /* $$IMPROVE ME  Get list metrics here and if we get a circular
8755      list, treat it correctly (How is TBD). */
8756   return kernel_mapor_aux(sc,REF_KEY(K_F), proc, args);
8757 }
8758
8759 /*_   , Kernel combiners */
8760 /*_    . $and? */
8761 /* $$IMPROVE ME  Make referring to curried operatives neater. */
8762 RGSTR(ground, "$and?", REF_OBJ(k_oper_andp))
8763 DEF_BOXED_CURRIED(k_oper_andp,
8764                   dcrry_2ALLVLL,
8765                   REF_OPER(kernel_internal_eval),
8766                   REF_OPER(kernel_mapand));
8767
8768 /*_    . $or? */
8769 RGSTR(ground, "$or?", REF_OBJ(k_oper_orp))
8770 DEF_BOXED_CURRIED(k_oper_orp,
8771                   dcrry_2ALLVLL,
8772                   REF_OPER(kernel_internal_eval),
8773                   REF_OPER(kernel_mapor));
8774
8775 /*_   , map */
8776 /*_    . k_counted_map_aux */
8777 /* $$USE ME MORE Export both to simple: "counted-map1-car"
8778    "counted-map1-cdr" */
8779 pko
8780 k_counted_map_car(klink * sc, int count, pko list, _kt_tag t_enum)
8781 {
8782   int i;
8783   pko rv_result = K_NIL;
8784   for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8785     {
8786       assert(is_pair(list));
8787       pko obj = pair_car(0, list);
8788       rv_result = v2cons (t_enum, pair_car(sc, obj), rv_result);
8789     }
8790
8791   /* Reverse the list in place. */
8792   return unsafe_v2reverse_in_place(K_NIL, rv_result);
8793 }
8794
8795 pko
8796 k_counted_map_cdr(klink * sc, int count, pko list, _kt_tag t_enum)
8797 {
8798   int i;
8799   pko rv_result = K_NIL;
8800   for(i = 0; i < count; ++i, list = pair_cdr(0, list))
8801     {
8802       assert(is_pair(list));
8803       pko obj = pair_car(0, list);
8804       rv_result = v2cons (t_enum, pair_cdr(sc, obj), rv_result);
8805     }
8806
8807   /* Reverse the list in place. */
8808   return unsafe_v2reverse_in_place(K_NIL, rv_result);
8809 }
8810
8811 /* Evaluate COUNT datums in list ARGS, Kernel-returning a list of the
8812    results. */
8813 SIG_CHKARRAY(k_counted_map_aux) =
8814 { REF_OPER(is_finite_list),
8815   REF_OPER(is_integer),
8816   REF_OPER(is_integer),
8817   REF_OPER(is_operative),
8818   REF_OPER(is_finite_list),
8819 };
8820 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_map_aux, 0,simple, "counted-map/5")
8821 {
8822   WITH_5_ARGS(accum, count, len, oper, args);
8823   assert (is_integer (count));
8824   /* $$IMPROVE ME  Check the other args too */
8825
8826   /* Arguments:
8827      accum:
8828      * The list of evaluated arguments, in reverse order.
8829      * Purpose: Used as an accumulator.
8830
8831      count:
8832      * The number of arguments remaining
8833
8834      len:
8835      * The effective length of args.
8836
8837      oper
8838      * An xary operative
8839
8840      args: list of lists of arguments to this.
8841
8842      * Precondition: Must be a proper list (is_finite_list must give
8843        true).  args will not be cyclic, we'll check for and handle
8844        encycling outside of here.
8845   */
8846
8847   /* If there are remaining arguments, arrange to operate on one, cons
8848      the result to accumulator, and return control here. */
8849   if (ivalue (count) > 0)
8850     {
8851       assert(is_pair(args));
8852       int len_v = ivalue(len);
8853       /* This can't be converted to a loop because we don't know
8854          whether kernel_eval_aux will create more frames.
8855
8856          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8857       */
8858       CONTIN_5 (dcrry_5CVLLA01dotAX1,
8859                 k_counted_map_aux, sc, accum,
8860                 mk_integer(ivalue(count) - 1),
8861                 len,
8862                 oper,
8863                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8864
8865       return kernel_eval_aux (sc,
8866                               oper,
8867                               k_counted_map_car(sc, len_v, args, T_PAIR),
8868                               sc->envir);
8869     }
8870   /* If there are no remaining arguments, reverse the accumulator
8871      and return it.  Can't reverse in place because other
8872      continuations might re-use the same accumulator state.  */
8873   else
8874     { return reverse (sc, accum); }
8875 }
8876
8877 /*_   , every? */
8878 /*_    . counted-every?/5 */
8879 SIG_CHKARRAY(k_counted_every) =
8880 { REF_OPER(is_bool),
8881   REF_OPER(is_integer),
8882   REF_OPER(is_integer),
8883   REF_OPER(is_operative),
8884   REF_OPER(is_finite_list),
8885 };
8886 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_every,0,simple,"counted-every?/5")
8887 {
8888   WITH_5_ARGS(ok, count, len, oper, args);
8889   assert (is_bool (ok));
8890   assert (is_integer (count));
8891   assert (is_integer (len));
8892
8893   /* Arguments:
8894      * succeeded:
8895        * Whether the last invocation of this succeeded.  Initialize with
8896          K_T.
8897
8898      count:
8899      * The number of arguments remaining
8900
8901      len:
8902      * The effective length of args.
8903
8904      oper
8905      * An xary operative
8906
8907      args: list of lists of arguments to this.
8908
8909      * Precondition: Must be a proper list (is_finite_list must give
8910        true).  args will not be cyclic, we'll check for and handle
8911        encycling outside of here.
8912   */
8913
8914   if(ok == K_F)
8915     { return K_F; }
8916   if(ok != K_T)
8917     { KERNEL_ERROR_1(sc, "k_counted_every: Must be boolean: ", ok); }
8918
8919   /* If there are remaining arguments, arrange to evaluate one and
8920      return control here. */
8921   if (ivalue (count) > 0)
8922     {
8923       assert(is_pair(args));
8924       int len_v = ivalue(len);
8925       /* This can't be converted to a loop because we don't know
8926          whether kernel_eval_aux will create more frames.
8927
8928          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8929       */
8930       CONTIN_4 (dcrry_4VLLdotALL,
8931                 k_counted_every, sc,
8932                 mk_integer(ivalue(count) - 1),
8933                 len,
8934                 oper,
8935                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8936
8937       return kernel_eval_aux (sc,
8938                               oper,
8939                               k_counted_map_car(sc, len_v, args, T_PAIR),
8940                               sc->envir);
8941     }
8942   /* If there are no remaining arguments, return true.  */
8943   else
8944     { return K_T; }
8945 }
8946
8947 /*_   , some? */
8948 /*_    . counted-some?/5 */
8949 SIG_CHKARRAY(k_counted_some) =
8950 { REF_OPER(is_bool),
8951   REF_OPER(is_integer),
8952   REF_OPER(is_integer),
8953   REF_OPER(is_operative),
8954   REF_OPER(is_finite_list),
8955 };
8956 DEF_SIMPLE_APPLICATIVE (ps0a5, k_counted_some,0,simple,"counted-some?/5")
8957 {
8958   WITH_5_ARGS(ok, count, len, oper, args);
8959   assert (is_bool (ok));
8960   assert (is_integer (count));
8961   assert (is_integer (len));
8962
8963   if(ok == K_T)
8964     { return K_T; }
8965   if(ok != K_F)
8966     { KERNEL_ERROR_1(sc, "k_counted_some: Must be boolean: ", ok); }
8967
8968   /* If there are remaining arguments, arrange to evaluate one and
8969      return control here. */
8970   if (ivalue (count) > 0)
8971     {
8972       assert(is_pair(args));
8973       int len_v = ivalue(len);
8974       /* This can't be converted to a loop because we don't know
8975          whether kernel_eval_aux will create more frames.
8976
8977          $$IMPROVE ME Check T_NO_K of proc; if it's set, we can loop.
8978       */
8979       CONTIN_4 (dcrry_4VLLdotALL,
8980                 k_counted_some, sc,
8981                 mk_integer(ivalue(count) - 1),
8982                 len,
8983                 oper,
8984                 k_counted_map_cdr(sc, len_v, args, T_PAIR));
8985
8986       return kernel_eval_aux (sc,
8987                               oper,
8988                               k_counted_map_car(sc, len_v, args, T_PAIR),
8989                               sc->envir);
8990     }
8991   /* If there are no remaining arguments, return false.  */
8992   else
8993     { return K_F; }
8994 }
8995
8996
8997 /*_  . Klink top level */
8998 /*_   , kernel_repl */
8999 DEF_CFUNC(ps0a0, kernel_repl, K_NO_TYPE,0)
9000 {
9001   /* If we reached the end of file, this loop is done. */
9002   port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
9003
9004   if (pt->kind & port_saw_EOF)
9005     { return K_INERT; }
9006
9007   putstr (sc, "\n");
9008   putstr (sc, prompt);
9009
9010   assert (is_environment (sc->envir));
9011
9012   /* Arrange another iteration */
9013   CONTIN_0 (kernel_repl, sc);
9014   klink_push_dyn_binding(sc,K_PRINT_FLAG,K_T);
9015   klink_push_cont(sc, REF_OBJ(print_value));
9016 #if USE_TRACING
9017   CONTIN_1 (dcrry_2A01VLL, tracing_say, sc, mk_string("\nGives: "));
9018 #endif
9019   CONTIN_0 (kernel_internal_eval, sc);
9020   CONTIN_0 (kernel_read_internal, sc);
9021   return K_INERT;
9022 }
9023
9024 /*_   , kernel_rel */
9025 static const kt_vector rel_chain =
9026   {
9027     3,
9028     ((pko[])
9029     {
9030       REF_OPER(kernel_read_internal),
9031         REF_OPER(kernel_internal_eval),
9032         REF_OPER(kernel_rel),
9033         }),
9034   };
9035
9036 DEF_CFUNC(ps0a0, kernel_rel, K_NO_TYPE,0)
9037 {
9038   /* If we reached the end of file, this loop is done. */
9039   port *pt = portvalue (klink_find_dyn_binding(sc,K_INPORT));
9040
9041   if (pt->kind & port_saw_EOF)
9042     { return K_INERT; }
9043
9044   assert (is_environment (sc->envir));
9045
9046 #if 1
9047   schedule_chain( sc, &rel_chain);
9048 #else
9049   /* Arrange another iteration */
9050   CONTIN_0 (kernel_rel, sc);
9051   CONTIN_0 (kernel_internal_eval, sc);
9052   CONTIN_0 (kernel_read_internal, sc);
9053 #endif
9054   return K_INERT;
9055 }
9056
9057 /*_   , kernel_internal_eval */
9058 /* Convert the aftermath of kernel_read_internal to something kernel_eval
9059    can accept.  */
9060 /* $$IMPROVE ME realize this as a currier.  But it's not a curried
9061    object as such because it carries no internal data.  */
9062 DEF_CFUNC (ps0a1, kernel_internal_eval, K_ANY,0)
9063 {
9064   pko value = arg1;
9065   if( sc->new_tracing )
9066     { klink_push_dyn_binding( sc, K_TRACING, K_T ); }
9067   return kernel_eval (sc, value, sc->envir);
9068 }
9069
9070 /*_  . Constructing environments */
9071 /*_   , Declarations for built-in environments */
9072 /* These are initialized before they are registered. */
9073 static pko print_lookup_env = 0;
9074 static pko all_builtins_env = 0;
9075 static pko ground_env       = 0;
9076 #define unsafe_env ground_env
9077 #define simple_env ground_env
9078 static pko typecheck_env_syms = 0;
9079
9080 /*_   , What to include */
9081 #ifndef COLLECT_RGSTRS          /* If we're collecting, these files may not
9082                                    have been generated yet */
9083 const kernel_registerable preregister[] =
9084   {
9085     /* $$MOVE ME These others will move into dedicated arrays, and be
9086        combined so that they can all be seen in init.krn but not in
9087        ground env. */
9088 #include "registerables/ground.inc"
9089 #include "registerables/unsafe.inc"
9090 #include "registerables/simple.inc"
9091     /* $$TRANSITIONAL */
9092     { "type?",                       REF_APPL(typecheck),                },
9093     { "do-destructure",              REF_APPL(do_destructure),           },
9094   };
9095
9096 const kernel_registerable all_builtins[] =
9097   {
9098 #include "registerables/all-builtins.inc"
9099   };
9100
9101 const kernel_registerable print_lookup_rgsts[] =
9102 {
9103   { "#f",      REF_KEY(K_F),       },
9104   { "#t",      REF_KEY(K_T),       },
9105   { "#inert",  REF_KEY(K_INERT),   },
9106   { "#ignore", REF_KEY(K_IGNORE),  },
9107
9108   { "$quote",  REF_OPER(arg1),     },
9109
9110   /* $$IMPROVE ME  Add the other quote-like symbols here. */
9111   /* quasiquote, unquote, unquote-splicing */
9112
9113 };
9114
9115 const kernel_registerable typecheck_syms_rgsts[] =
9116   {
9117 #include "registerables/type-keys.inc"
9118   };
9119 #endif
9120
9121
9122 /*_   , How to add */
9123
9124 /* Bind each of an array of kernel_registerables into env. */
9125 void
9126 k_register_list (const kernel_registerable * list, int count, pko env)
9127 {
9128   int i;
9129   assert(list);
9130   assert (is_environment (env));
9131   for (i = 0; i < count; i++)
9132     {
9133       kernel_define (env, mk_symbol (list[i].name), list[i].data);
9134     }
9135 }
9136
9137 /*_   , k_regstrs_to_env */
9138 pko
9139 k_regstrs_to_env(const kernel_registerable * list, int count)
9140 {
9141   pko env = make_new_frame(K_NIL);
9142   k_register_list (list, count, env);
9143   return env;
9144 }
9145
9146 #define K_REGSTRS_TO_ENV(RGSTRS)\
9147   k_regstrs_to_env(RGSTRS, sizeof (RGSTRS) / sizeof (RGSTRS[0]))
9148 /*_   , setup_print_secondary_lookup */
9149 static pko print_lookup_unwraps = 0;
9150 static pko print_lookup_to_xary = 0;
9151 void
9152 setup_print_secondary_lookup(void)
9153 {
9154   /* Quick and dirty: Set up tables corresponding to the ground env
9155      and put the registering stuff in them. */
9156   /* What this really accomplishes is to make prepared lookup tables
9157      available for particular print operations.  Later we'll use a
9158      more general approach and this will become just a cache. */
9159   print_lookup_unwraps = make_new_frame(K_NIL);
9160   print_lookup_to_xary = make_new_frame(K_NIL);
9161   int i;
9162   const kernel_registerable * list = preregister;
9163   int count = sizeof (preregister) / sizeof (preregister[0]);
9164   for (i = 0; i < count; i++)
9165     {
9166       pko obj = list[i].data;
9167       if(is_applicative(obj))
9168         {
9169           kernel_define (print_lookup_unwraps,
9170                          mk_symbol (list[i].name),
9171                          unwrap(0,obj));
9172         }
9173       pko xary = k_to_trivpred(obj);
9174       if((xary != K_NIL) && xary != obj)
9175         {
9176           kernel_define (print_lookup_to_xary,
9177                          mk_symbol (list[i].name),
9178                          xary);
9179         }
9180     }
9181 }
9182
9183 /*_   , make-kernel-standard-environment */
9184 /* Though it would be neater for this to define ground environment if
9185    there is none, that would mean it would need the eval loop and so
9186    couldn't be done early.  So it relies on the ground environment
9187    being already defined.  */
9188 RGSTR(ground,"make-kernel-standard-environment", REF_OPER(mk_std_environment))
9189 DEF_CFUNC(p00a0, mk_std_environment, K_NO_TYPE,T_NO_K)
9190 {
9191   assert(ground_env);
9192   return make_new_frame(ground_env);
9193 }
9194
9195 /*_  . The eval cycle */
9196 /*_   , Helpers */
9197 /*_    . Make an error continuation */
9198 static void
9199 klink_record_error_cont (klink * sc, pko error_continuation)
9200 {
9201   /* Record error continuation. */
9202   kernel_define (sc->envir,
9203                  mk_symbol ("error-continuation"),
9204                  error_continuation);
9205   /* Also record it in interpreter, so built-ins can see it w/o
9206      lookup. */
9207   sc->error_continuation = error_continuation;
9208 }
9209
9210 /*_   , Entry points */
9211 /*_    . Eval cycle that restarts on error */
9212 static void
9213 klink_cycle_restarting (klink * sc, pko combiner)
9214 {
9215   assert(is_combiner(combiner));
9216   assert(is_environment(sc->envir));
9217   /* Arrange to stop if we ever reach where we started. */
9218   klink_push_cont (sc, REF_OPER (k_quit));
9219
9220   /* Grab root continuation. */
9221   kernel_define (sc->envir,
9222                  mk_symbol ("root-continuation"),
9223                  current_continuation (sc));
9224
9225   /* Make main continuation */
9226   klink_push_cont (sc, combiner);
9227
9228   /* Make error continuation on top of main continuation. */
9229   pko error_continuation =
9230     extend_continuation_aux(sc->dump, REF_OPER(kernel_err), sc->envir);
9231
9232   klink_record_error_cont(sc, error_continuation);
9233
9234   /* Conceptually sc->retcode is a keyed dynamic variable that
9235      kernel_err sets. */
9236   sc->retcode = 0;
9237   _klink_cycle (sc);
9238   /* $$RECONSIDER ME Maybe indicate quit value  */
9239 }
9240 /*_    . Eval cycle that terminates on error */
9241 static int
9242 klink_cycle_no_restart (klink * sc, pko combiner)
9243 {
9244   assert(is_combiner(combiner));
9245   assert(is_environment(sc->envir));
9246   /* Arrange to stop if we ever reach where we started. */
9247   klink_push_cont (sc, REF_OPER (k_quit));
9248
9249   /* Grab root continuation. */
9250   kernel_define (sc->envir,
9251                  mk_symbol ("root-continuation"),
9252                  current_continuation (sc));
9253
9254   /* Make error continuation that quits. */
9255   pko error_continuation =
9256     extend_continuation_aux(sc->dump, REF_OPER(kernel_err_return), sc->envir);
9257
9258   klink_record_error_cont(sc, error_continuation);
9259
9260   klink_push_cont (sc, combiner);
9261
9262   /* Conceptually sc->retcode is a keyed dynamic variable that
9263      kernel_err sets.  Actually it's entirely cached in the
9264      interpreter. */
9265   sc->retcode = 0;
9266   _klink_cycle (sc);
9267   return sc->retcode;
9268 }
9269
9270 /*_   , _klink_cycle (Don't use this directly) */
9271 static void
9272 _klink_cycle (klink * sc)
9273 {
9274   pko value = K_INERT;
9275
9276   sc->done = 0;
9277   while (!sc->done)
9278     {
9279       int i = setjmp (sc->pseudocontinuation);
9280       if (i == 0)
9281         {
9282           k_profiling_step();
9283           int got_new_frame = klink_pop_cont (sc);
9284           /* $$RETHINK ME  Is this test still needed?  Could be just
9285              an assertion. */
9286           if (got_new_frame)
9287             {
9288               /* $$IMPROVE ME Instead, a function that governs
9289                  whether to eval. */
9290               if (sc->new_tracing)
9291                 {
9292                   if(_get_type( sc->next_func ) == T_NOTRACE )
9293                     {
9294                       sc->next_func = notrace_comb( sc->next_func );
9295                       goto normal;
9296                     }
9297                   pko tracing =
9298                        klink_find_dyn_binding(sc, K_TRACING );
9299                   /* Now we know the other branch should have been
9300                      taken. */
9301                   if( !tracing || ( tracing == K_F ))
9302                     { goto normal; }
9303
9304                   /* Enqueue a version that will execute without
9305                      tracing.  Its descendants will be traced. */
9306                   CONTIN_0_RAW (mk_notrace(mk_curried(dcrry_1dotALL,
9307                                                       value,
9308                                                       mk_notrace(sc->next_func))),
9309                                  sc );
9310                   switch (_get_type (sc->next_func))
9311                     {
9312                     case T_LOAD:
9313                       putstr (sc, "\nLoad ");
9314                       break;
9315
9316                     case T_STORE:
9317                       putstr (sc, "\nStore ");
9318                       break;
9319
9320                     case T_CURRIED:
9321                       putstr (sc, "\nDecurry ");
9322                       break;
9323
9324                     default:
9325                       /* Print tracing */
9326                       {
9327                         /* Find and print current frame depth */
9328                         int depth = curr_frame_depth (sc->dump);
9329                         char * str = sc->strbuff;
9330                         snprintf (str, STRBUFFSIZE, "\n%d: ", depth);
9331                         putstr (sc, str);
9332                       }
9333                       klink_push_dyn_binding (sc, K_TRACING, K_F);
9334                       putstr (sc, "Eval: ");
9335                       value = kernel_print_sexp (sc,
9336                                                  cons (sc->next_func, value),
9337                                                  K_INERT);
9338                     }
9339                 }
9340               else
9341                 {
9342                 normal:
9343                   value = kernel_eval_aux (sc, sc->next_func, value, sc->envir);
9344                 }
9345
9346             }
9347           /* Stop looping if stack is empty. */
9348           else
9349             { break; }
9350         }
9351       else
9352         /* Otherwise something jumped to a continuation.  Get the
9353            value and keep looping.  */
9354         {
9355           value = sc->value;
9356         }
9357     }
9358   /* In case we're called nested in another _klink_cycle, don't
9359      affect it. */
9360   sc->done = 0;
9361 }
9362
9363 /*_  . Vtable interface */
9364 /* initialization of Klink */
9365 #if USE_INTERFACE
9366
9367 static struct klink_interface vtbl =
9368   {
9369     klink_define,
9370     mk_mutable_pair,
9371     mk_pair,
9372     mk_integer,
9373     mk_real,
9374     mk_symbol,
9375     mk_string,
9376     mk_counted_string,
9377     mk_character,
9378     mk_vector,
9379     putstr,
9380     putcharacter,
9381
9382     is_string,
9383     string_value,
9384     is_number,
9385     nvalue,
9386     ivalue,
9387     rvalue,
9388     is_integer,
9389     is_real,
9390     is_character,
9391     charvalue,
9392     is_finite_list,
9393     is_vector,
9394     list_length,
9395     vector_len,
9396     fill_vector,
9397     vector_elem,
9398     set_vector_elem,
9399     is_port,
9400
9401     is_pair,
9402     pair_car,
9403     pair_cdr,
9404     set_car,
9405     set_cdr,
9406
9407     is_symbol,
9408     symname,
9409
9410     is_continuation,
9411     is_environment,
9412     is_immutable,
9413     setimmutable,
9414
9415     klink_load_file,
9416     klink_load_string,
9417   };
9418 #if USE_DL
9419 /* $$MOVE ME  Later after I separate some headers
9420    This belongs in dynload.c, could be just:
9421    SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9422    DEF_SIMPLE_APPLICATIVE(ps0a1,klink_load_ext,0,ground, "load-extension") {...}
9423  */
9424 RGSTR(ground, "load-extension", REF_APPL(klink_load_ext))
9425 SIG_CHKARRAY(klink_load_ext) = { REF_OPER(is_string), };
9426 DEF_SIMPLE_DESTR(klink_load_ext);
9427 DEF_CFUNC_PSYCNAME(ps0a1,klink_load_ext, REF_DESTR(klink_load_ext),0);
9428 DEF_BOXED_APPLICATIVE(klink_load_ext, REF_OPER (klink_load_ext));
9429
9430 #endif
9431
9432 #endif
9433
9434 /*_  . Initializing Klink */
9435 /*_   , Allocate and initialize */
9436
9437 klink *
9438 klink_alloc_init (FILE * in, FILE * out)
9439 {
9440   klink *sc = (klink *) GC_MALLOC (sizeof (klink));
9441   if (!klink_init (sc, in, out))
9442     {
9443       GC_FREE (sc);
9444       return 0;
9445     }
9446   else
9447     {
9448       return sc;
9449     }
9450 }
9451
9452 /*_   , Initialization without allocation */
9453 int
9454 klink_init (klink * sc, FILE * in, FILE * out)
9455 {
9456   /* Init stack first, just in case something calls _klink_error_1. */
9457   dump_stack_initialize (sc);
9458   /* Initialize ports early in case something prints. */
9459   /* $$IMPROVE ME  Should accept general ports of appropriate in/out. */
9460   klink_set_input_port_file (sc, in);
9461   klink_set_output_port_file (sc, out);
9462
9463 #if USE_INTERFACE
9464   /* Why do we need this field if there is a static table? */
9465   sc->vptr = &vtbl;
9466 #endif
9467
9468   sc->tracing = 0;
9469   sc->new_tracing = 0;
9470
9471   if(!oblist)
9472     { oblist = oblist_initial_value (); }
9473
9474
9475   /* Add the Kernel built-ins */
9476   if(!print_lookup_env)
9477     {
9478       print_lookup_env = K_REGSTRS_TO_ENV(print_lookup_rgsts);
9479     }
9480   if(!all_builtins_env)
9481     {
9482       all_builtins_env = K_REGSTRS_TO_ENV(all_builtins);
9483     }
9484   if(!typecheck_env_syms)
9485     { typecheck_env_syms = K_REGSTRS_TO_ENV(typecheck_syms_rgsts); }
9486   if(!ground_env)
9487     {
9488       /** Register objects from hard-coded list. **/
9489       ground_env = K_REGSTRS_TO_ENV(preregister);
9490       /* $$TRANSITIONAL  Set up special lookup tables related to preregister. */
9491       setup_print_secondary_lookup();
9492       /** Bind certain objects that we make at init time.  **/
9493       kernel_define (ground_env,
9494                      mk_symbol ("print-lookup-env"),
9495                      print_lookup_env);
9496       kernel_define (unsafe_env,
9497                      mk_symbol ("typecheck-special-syms"),
9498                      typecheck_env_syms);
9499
9500       /** Read some definitions from a prolog **/
9501       /* We need an envir before klink_call, because that defines a
9502          few things.  Those bindings are specific to one instance of
9503          the interpreter so they do not belong in anything shared such
9504          as ground_env.  */
9505       /* $$IMPROVE ME Something in the call chain (klink_call?) should
9506          guarantee an environment.  Needn't have anything in it to
9507          begin with.  */
9508       sc->envir = make_new_frame(K_NIL);
9509
9510       /* Can't easily merge this with klink_load_named_file.  Two
9511          difficulties: it uses klink_cycle_restarting while klink_call
9512          uses klink_cycle_no_restart, and here we need to control the
9513          load environment.  */
9514       pko p = port_from_filename (InitFile, port_file | port_input);
9515       if (p == K_NIL) { return 0; }
9516
9517       /* We can't use k_get_mod_fm_port to manage parameters because
9518          later we will need the environment to have several parents:
9519          ground, simple, unsafe, possibly more. */
9520       /* Params: `into' =  ground environment */
9521       /* We can't share this with the previous frame-making, because
9522          it should not define in the same environment.  */
9523       pko params = make_new_frame(K_NIL);
9524       kernel_define (params, mk_symbol ("into"), ground_env);
9525       pko env = make_new_frame(ground_env);
9526       kernel_define (env, mk_symbol ("module-parameters"), params);
9527       int retcode = klink_call(sc,
9528                                REF_OPER(load_from_port),
9529                                LIST2(p, env));
9530       if(retcode) { return 0; }
9531
9532       /* The load will have written various things into ground
9533          environment.  sc->envir is unsuitable now because it is this
9534          load's environment. */
9535     }
9536
9537   assert (is_environment (ground_env));
9538   sc->envir = make_new_frame(ground_env);
9539
9540 #if 1                           /* Transitional.  Leave this on for the moment */
9541   /* initialization of global pointers to special symbols */
9542   sc->QUOTE = mk_symbol ("quote");
9543   sc->QQUOTE = mk_symbol ("quasiquote");
9544   sc->UNQUOTE = mk_symbol ("unquote");
9545   sc->UNQUOTESP = mk_symbol ("unquote-splicing");
9546   sc->COLON_HOOK = mk_symbol ("*colon-hook*");
9547   sc->SHARP_HOOK = mk_symbol ("*sharp-hook*");
9548 #endif
9549   return 1;
9550 }
9551
9552 /*_   , Deinit */
9553 void
9554 klink_deinit (klink * sc)
9555 {
9556   sc->envir = K_NIL;
9557   sc->value = K_NIL;
9558 }
9559 /*_  . Using Klink from C */
9560 /*_   , To set ports */
9561 void
9562 klink_set_input_port_file (klink * sc, FILE * fin)
9563 {
9564   klink_push_dyn_binding(sc,K_INPORT,port_from_file (fin, port_input));
9565 }
9566
9567 void
9568 klink_set_input_port_string (klink * sc, char *start, char *past_the_end)
9569 {
9570   klink_push_dyn_binding(sc,
9571                          K_INPORT,
9572                          port_from_string (start, past_the_end, port_input));
9573 }
9574
9575 void
9576 klink_set_output_port_file (klink * sc, FILE * fout)
9577 {
9578   klink_push_dyn_binding(sc,K_OUTPORT,port_from_file (fout, port_output));
9579 }
9580
9581 void
9582 klink_set_output_port_string (klink * sc, char *start, char *past_the_end)
9583 {
9584   klink_push_dyn_binding(sc,
9585                          K_OUTPORT,
9586                          port_from_string (start, past_the_end, port_output));
9587 }
9588 /*_   , To set external data */
9589 void
9590 klink_set_external_data (klink * sc, void *p)
9591 {
9592   sc->ext_data = p;
9593 }
9594
9595
9596 /*_   , To load */
9597 /*_    . Load file (C) */
9598 /*_     , Worker */
9599 void
9600 klink_load_port (klink * sc, pko p, int interactive)
9601 {
9602   if (p == K_NIL)
9603     {
9604       sc->retcode = 2;
9605       return;
9606     }
9607   else
9608     {
9609       klink_push_dyn_binding(sc,K_INPORT,p);
9610     }
9611
9612   {
9613     pko combiner =
9614       interactive ?
9615       REF_OPER (kernel_repl) :
9616       REF_OPER (kernel_rel);
9617     klink_cycle_restarting (sc, combiner);
9618   }
9619 }
9620
9621 /*_     , klink_load_file */
9622 void
9623 klink_load_file (klink * sc, FILE * fin)
9624 {
9625   klink_load_port (sc,
9626                    port_from_file (fin, port_file | port_input),
9627                    (fin == stdin));
9628 }
9629
9630 /*_     , klink_load_named_file */
9631 void
9632 klink_load_named_file (klink * sc, FILE * fin, const char *filename)
9633 {
9634   klink_load_port(sc,
9635                   port_from_filename (filename, port_file | port_input),
9636                   (fin == stdin));
9637 }
9638
9639 /*_    . load string (C) */
9640
9641 void
9642 klink_load_string (klink * sc, const char *cmd)
9643 {
9644   klink_load_port(sc,
9645                   port_from_string ((char *)cmd,
9646                                     (char *)cmd + strlen (cmd),
9647                                     port_input | port_string),
9648                   0);
9649 }
9650
9651 /*_   , Apply combiner */
9652 /* sc is presumed to be already set up.
9653    The final value or error argument is in sc->value.
9654    The return code is duplicated in sc->retcode.
9655  */
9656 int
9657 klink_call (klink * sc, pko func, pko args)
9658 {
9659   klink_cycle_no_restart (sc,
9660                           mk_curried(dcrry_NdotALL,args,func));
9661   return sc->retcode;
9662 }
9663
9664 /*_   , Eval form */
9665 /* This is completely unexercised. */
9666
9667 int
9668 klink_eval (klink * sc, pko obj)
9669 {
9670   klink_cycle_no_restart(sc,
9671                          mk_curried(dcrry_2dotALL,
9672                                     LIST2(obj,sc->envir),
9673                                     REF_OPER(kernel_eval)));
9674   return sc->retcode;
9675 }
9676
9677 /*_  . Main (if standalone) */
9678 #if STANDALONE
9679 /*_   , Mac */
9680 #if defined(__APPLE__) && !defined (OSX)
9681 int
9682 main ()
9683 {
9684   extern MacTS_main (int argc, char **argv);
9685   char **argv;
9686   int argc = ccommand (&argv);
9687   MacTS_main (argc, argv);
9688   return 0;
9689 }
9690
9691 /*_   , General */
9692 int
9693 MacTS_main (int argc, char **argv)
9694 {
9695 #else
9696 int
9697 main (int argc, char **argv)
9698 {
9699 #endif
9700   klink sc;
9701   FILE *fin = 0;
9702   char *file_name = 0;          /* Was InitFile */
9703   int retcode;
9704   int isfile = 1;
9705   GC_INIT ();
9706   if (argc == 1)
9707     {
9708       printf (banner);
9709     }
9710   if (argc == 2 && strcmp (argv[1], "-?") == 0)
9711     {
9712       printf ("Usage: klink -?\n");
9713       printf ("or:    klink [<file1> <file2> ...]\n");
9714       printf ("followed by\n");
9715       printf ("          -1 <file> [<arg1> <arg2> ...]\n");
9716       printf ("          -c <Kernel commands> [<arg1> <arg2> ...]\n");
9717       printf ("assuming that the executable is named klink.\n");
9718       printf ("Use - as filename for stdin.\n");
9719       return 1;
9720     }
9721
9722   /* Make error_continuation semi-safe until it's properly set.  */
9723   sc.error_continuation = 0;
9724   int i = setjmp (sc.pseudocontinuation);
9725   if (i == 0)
9726     {
9727       if (!klink_init (&sc, stdin, stdout))
9728         {
9729           fprintf (stderr, "Could not initialize!\n");
9730           return 2;
9731         }
9732     }
9733   else
9734     {
9735       fprintf (stderr, "Kernel error encountered while initializing!\n");
9736       return 3;
9737     }
9738   argv++;
9739   /* $$IMPROVE ME Maybe use get_opts instead. */
9740   while(1)
9741     {
9742       /* $$IMPROVE ME Add a principled way of sometimes including
9743          filename defined in environment.  Eg getenv
9744          ("KLINKINIT").  */
9745       file_name = *argv;
9746       argv++;
9747       if(!file_name) { break; }
9748       if (strcmp (file_name, "-") == 0)
9749         {
9750           fin = stdin;
9751         }
9752       else if (strcmp (file_name, "-1") == 0 || strcmp (file_name, "-c") == 0)
9753         {
9754           pko args = K_NIL;
9755           /* $$FACTOR ME This is a messy way to distinguish command
9756              string from filename string */
9757           isfile = (file_name[1] == '1');
9758           file_name = *argv++;
9759           if (strcmp (file_name, "-") == 0)
9760             {
9761               fin = stdin;
9762             }
9763           else if (isfile)
9764             {
9765               fin = fopen (file_name, "r");
9766             }
9767
9768           /* Put remaining command-line args into *args* in envir. */
9769           for (; *argv; argv++)
9770             {
9771               pko value = mk_string (*argv);
9772               args = mcons (value, args);
9773             }
9774           args = unsafe_v2reverse_in_place (K_NIL, args);
9775           /* Instead, use (command-line) as accessor and provide the
9776              whole command line as a list of strings.  */
9777           kernel_define (sc.envir, mk_symbol ("*args*"), args);
9778
9779         }
9780       else
9781         {
9782           fin = fopen (file_name, "r");
9783         }
9784       if (isfile && fin == 0)
9785         {
9786           fprintf (stderr, "Could not open file %s\n", file_name);
9787         }
9788       else
9789         {
9790           if (isfile)
9791             {
9792               /* $$IMPROVE ME Use klink_load_named_file, replacing the
9793                  file-opening code, so we can report filename  */
9794               klink_load_file (&sc, fin);
9795             }
9796           else
9797             {
9798               klink_load_string (&sc, file_name);
9799             }
9800           if (!isfile || fin != stdin)
9801             {
9802               if (sc.retcode != 0)
9803                 {
9804                   fprintf (stderr, "Errors encountered reading %s\n",
9805                            file_name);
9806                 }
9807               if (isfile)
9808                 {
9809                   fclose (fin);
9810                 }
9811             }
9812         }
9813     }
9814
9815   if (argc == 1)
9816     {
9817       /* $$MAKE ME CLEANER Quick and dirty for now, we make an
9818          environment for this but let everything else modify ground
9819          env.  I'd like to be more correct about that. */
9820       /* Make an interactive environment over ground_env. */
9821       new_frame_in_env (&sc, sc.envir);
9822       klink_load_file (&sc, stdin);
9823     }
9824   retcode = sc.retcode;
9825   klink_deinit (&sc);
9826
9827   return retcode;
9828 }
9829
9830 #endif
9831
9832 /*_ , Footers */
9833 /*
9834 Local variables:
9835 c-file-style: "gnu"
9836 mode: allout
9837 End:
9838 */