klink.c

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