4116 lines
132 KiB
C
4116 lines
132 KiB
C
|
/* KScheme, a BRUTAL EDIT of MiniScheme, by Zak Fenton MMXX
|
||
|
|
* CHANGES from Mini-Scheme 0.85 to KScheme 0.1:
|
||
|
|
* - Fixed up some old-style C code that modern/C++ compilers complain about (mostly changes to function definitions, now compiles in Visual Studio 2019)
|
||
|
|
* - Removed copyrighted parts of init.scm (assuming the sections with copyright notices aren't covered by the public domain dedication in this file)
|
||
|
|
* - Made partly embeddable (all globals now stored in a struct passed between each function, each function now has kscm_ prefix with an extra underscore
|
||
|
|
* for most of them to indicate that it's part of a private API for now)
|
||
|
|
* - Changed name (Mini-Scheme -> KScheme, as in "kernel scheme")
|
||
|
|
* - Maybe more features coming...
|
||
|
|
*
|
||
|
|
* ---------- Mini-Scheme Interpreter Version 0.85 ----------
|
||
|
|
*
|
||
|
|
* coded by Atsushi Moriwaki (11/5/1989)
|
||
|
|
*
|
||
|
|
* E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp
|
||
|
|
*
|
||
|
|
* THIS SOFTWARE IS IN THE PUBLIC DOMAIN
|
||
|
|
* ------------------------------------
|
||
|
|
* This software is completely free to copy, modify and/or re-distribute.
|
||
|
|
* But I would appreciate it if you left my name on the code as the author.
|
||
|
|
*
|
||
|
|
*/
|
||
|
|
/*--
|
||
|
|
*
|
||
|
|
* This version has been modified by Chris Pressey.
|
||
|
|
* current version is 0.85p1 (as yet unreleased)
|
||
|
|
*
|
||
|
|
* This version has been modified by R.C. Secrist.
|
||
|
|
*
|
||
|
|
* Mini-Scheme is now maintained by Akira KIDA.
|
||
|
|
*
|
||
|
|
* This is a revised and modified version by Akira KIDA.
|
||
|
|
* current version is 0.85k4 (15 May 1994)
|
||
|
|
*
|
||
|
|
* Please send suggestions, bug reports and/or requests to:
|
||
|
|
* <SDI00379@niftyserve.or.jp>
|
||
|
|
*--
|
||
|
|
*/
|
||
|
|
#define KSCM_PLATFORM_BSD
|
||
|
|
//#define KSCM_PLUSPLUS
|
||
|
|
// If KSCM_CONFIG_USE_PRECISE is defined, overflow detection will occur in basic math functions
|
||
|
|
#define KSCM_CONFIG_USE_PRECISE
|
||
|
|
// This just allows unsafe legacy C functions in Visual Studio. It should be disabled and fixed properly but not the highest priority.
|
||
|
|
#define _CRT_SECURE_NO_WARNINGS
|
||
|
|
|
||
|
|
#ifdef KSCM_PLUSPLUS
|
||
|
|
extern "C" {
|
||
|
|
#endif
|
||
|
|
/*
|
||
|
|
* Here is System declaration.
|
||
|
|
* Please define exactly one symbol in the following section.
|
||
|
|
*/
|
||
|
|
/* #define LSC */ /* LightSpeed C for Macintosh */
|
||
|
|
/* #define LSC4 */ /* THINK C version 4.0 for Macintosh */
|
||
|
|
/* #define MPW2 */ /* Macintosh Programmer's Workshop v2.0x */
|
||
|
|
/* #define KSCM_PLATFORM_BSD */ /* 4.x KSCM_PLATFORM_BSD */
|
||
|
|
/* #define MSC */ /* Microsoft C Compiler v.4.00 - 7.00 */
|
||
|
|
/* #define KSCM_PLATFORM_TURBOC */ /* Turbo C compiler v.2.0, or TC++ 1.0 */
|
||
|
|
/* #define SYSV */ /* System-V, or POSIX */
|
||
|
|
/* #define KSCM_PLATFORM_VAXC */ /* VAX/VMS KSCM_PLATFORM_VAXC 2.x or later */ /* (automatic) */
|
||
|
|
|
||
|
|
#ifdef __BORLANDC__ /* Borland C++ - MS-DOS */
|
||
|
|
#define KSCM_PLATFORM_TURBOC
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef __TURBOC__ /* Turbo C V1.5 - MS-DOS */
|
||
|
|
#define KSCM_PLATFORM_TURBOC
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef mips /* DECstation running OSF/1 */
|
||
|
|
#define KSCM_PLATFORM_BSD
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef __osf__ /* Alpha AXP running OSF/1 */
|
||
|
|
#define KSCM_PLATFORM_BSD
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef __DECC /* Alpha AXP running VMS */
|
||
|
|
#define KSCM_PLATFORM_VAXC
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef _AIX /* RS/6000 running AIX */
|
||
|
|
#define KSCM_PLATFORM_BSD
|
||
|
|
#endif
|
||
|
|
|
||
|
|
/*
|
||
|
|
* Define or undefine following symbols as you need.
|
||
|
|
*/
|
||
|
|
// #define VERBOSE /* define this if you want verbose GC */
|
||
|
|
#define KSCM_CONFIG_AVOID_HACK_LOOP /* define this if your compiler is poor
|
||
|
|
* enougth to complain "do { } while (0)"
|
||
|
|
* construction.
|
||
|
|
*/
|
||
|
|
//#define KSCM_CONFIG_USE_SETJMP /* undef this if you do not want to use setjmp() */
|
||
|
|
#define KSCM_CONFIG_USE_QQUOTE /* undef this if you do not need quasiquote */
|
||
|
|
#define KSCM_CONFIG_USE_MACRO /* undef this if you do not need macro */
|
||
|
|
#define KSCM_CONFIG_USE_PERSIST /* undef this if you do not need persistence */
|
||
|
|
#define KSCM_CONFIG_USE_PRECISE /* undef this if you do not need overflow detection and precise integer size */
|
||
|
|
#define KSCM_CONFIG_USE_STRUCTS /* undef this if you do not need additional structure types (buffers & abstractions) */
|
||
|
|
#define KSCM_CONFIG_USE_FLOATS /* undef this if you do not need floating-point functionality (i.e. undefine this if you're running in kernel mode) */
|
||
|
|
#define KSCM_CONFIG_USE_OBJECTS /* undef this if you do not need object-oriented/vector features (these are handy but may complicate simple implementations) */
|
||
|
|
#define KSCM_CONFIG_USE_UTF8 /* undef this if you do not need Unicode support */
|
||
|
|
//#define KSCM_CONFIG_USE_CONSOLE /* undef this if you do not need extended console functions. */
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_CONSOLE
|
||
|
|
#include <sys/ioctl.h>
|
||
|
|
#include <err.h>
|
||
|
|
#include <fcntl.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <unistd.h>
|
||
|
|
#include <termios.h>
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#define KSCM_CONFIG_MAXLOADS 20 /* the maximum depth of the load stack */
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
#include <stdint.h>
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
/*--
|
||
|
|
* If your machine can't support "forward single quotation character"
|
||
|
|
* i.e., '`', you may have trouble to use backquote.
|
||
|
|
* So use '^' in place of '`'.
|
||
|
|
*/
|
||
|
|
# define BACKQUOTE '`'
|
||
|
|
#endif
|
||
|
|
|
||
|
|
/*
|
||
|
|
* Basic memory allocation units
|
||
|
|
*/
|
||
|
|
|
||
|
|
#ifdef KSCM_PLATFORM_TURBOC /* rcs */
|
||
|
|
#define KSCM_CONFIG_CELL_SEGSIZE 2048
|
||
|
|
#define KSCM_CONFIG_CELL_NSEGMENT 100
|
||
|
|
#define KSCM_CONFIG_STR_SEGSIZE 2048
|
||
|
|
#define KSCM_CONFIG_STR_NSEGMENT 100
|
||
|
|
#else
|
||
|
|
#define KSCM_CONFIG_CELL_SEGSIZE 10000 /* # of cells in one segment */
|
||
|
|
#define KSCM_CONFIG_CELL_NSEGMENT 100 /* # of segments for cells */
|
||
|
|
#define KSCM_CONFIG_STR_SEGSIZE 10000 /* bytes of one string segment */
|
||
|
|
#define KSCM_CONFIG_STR_NSEGMENT 10000 /* # of segments for strings */
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#define KSCM_CONFIG_BANNER "Hello, This is KScheme (kscm) 0.3, based on Mini-Scheme Interpreter Version 0.85p1.\n"
|
||
|
|
|
||
|
|
#define KSCM_CONFIG_PERSIST_MAGIC "KSCM"
|
||
|
|
#define KSCM_CONFIG_PERSIST_VERSION 2
|
||
|
|
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <ctype.h>
|
||
|
|
#include <stdbool.h>
|
||
|
|
#ifdef KSCM_CONFIG_USE_SETJMP
|
||
|
|
#include <setjmp.h>
|
||
|
|
#endif
|
||
|
|
|
||
|
|
|
||
|
|
/* System dependency */
|
||
|
|
#ifdef LSC
|
||
|
|
#include <strings.h>
|
||
|
|
#include <unix.h>
|
||
|
|
#define malloc(x) NewPtr((long)(x))
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 5
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef LSC4
|
||
|
|
#include <string.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#define malloc(x) NewPtr((long)(x))
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 5
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef MPW2
|
||
|
|
#include <strings.h>
|
||
|
|
#include <memory.h>
|
||
|
|
#define malloc(x) NewPtr((long)(x))
|
||
|
|
#define KSCM_CONFIG_PROMPT "> [enter at next line]\n"
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 5
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_PLATFORM_BSD
|
||
|
|
#include <string.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#include <signal.h>
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 10
|
||
|
|
#endif
|
||
|
|
|
||
|
|
// Old definition, no detection
|
||
|
|
#ifdef MSC
|
||
|
|
#include <string.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#include <malloc.h>
|
||
|
|
#include <process.h>
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 3
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_PLATFORM_TURBOC
|
||
|
|
#include <string.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 3
|
||
|
|
#endif
|
||
|
|
|
||
|
|
// Old definition, no detection
|
||
|
|
#ifdef SYSV
|
||
|
|
#include <string.h>
|
||
|
|
#include <malloc.h>
|
||
|
|
#if __STDC__
|
||
|
|
# include <stdlib.h>
|
||
|
|
#endif
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 10
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_PLATFORM_VAXC
|
||
|
|
#include <string.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#define KSCM_CONFIG_PROMPT "> "
|
||
|
|
#define KSCM_CONFIG_INITFILE "init.scm"
|
||
|
|
#define KSCM_CONFIG_FIRST_CELLSEGS 10
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef __GNUC__
|
||
|
|
/*
|
||
|
|
* If we use gcc, KSCM_CONFIG_AVOID_HACK_LOOP is unnecessary
|
||
|
|
*/
|
||
|
|
#undef KSCM_CONFIG_AVOID_HACK_LOOP
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifndef KSCM_CONFIG_FIRST_CELLSEGS
|
||
|
|
#error Please define your system type.
|
||
|
|
/*
|
||
|
|
* We refrain this to raise an error anyway even if on pre-ANSI system.
|
||
|
|
*/
|
||
|
|
error Please define your system type.
|
||
|
|
#endif
|
||
|
|
|
||
|
|
|
||
|
|
/* ========== Evaluation Cycle ========== */
|
||
|
|
|
||
|
|
/* operator code */
|
||
|
|
#define KSCM_OP_LOAD 0
|
||
|
|
#define KSCM_OP_T0LVL 1
|
||
|
|
#define KSCM_OP_T1LVL 2
|
||
|
|
#define KSCM_OP_READ 3
|
||
|
|
#define KSCM_OP_VALUEPRINT 4
|
||
|
|
#define KSCM_OP_EVAL 5
|
||
|
|
#define KSCM_OP_E0ARGS 6
|
||
|
|
#define KSCM_OP_E1ARGS 7
|
||
|
|
#define KSCM_OP_APPLY 8
|
||
|
|
#define KSCM_OP_DOMACRO 9
|
||
|
|
|
||
|
|
#define KSCM_OP_LAMBDA 10
|
||
|
|
#define KSCM_OP_QUOTE 11
|
||
|
|
#define KSCM_OP_DEF0 12
|
||
|
|
#define KSCM_OP_DEF1 13
|
||
|
|
#define KSCM_OP_BEGIN 14
|
||
|
|
#define KSCM_OP_IF0 15
|
||
|
|
#define KSCM_OP_IF1 16
|
||
|
|
#define KSCM_OP_SET0 17
|
||
|
|
#define KSCM_OP_SET1 18
|
||
|
|
#define KSCM_OP_LET0 19
|
||
|
|
#define KSCM_OP_LET1 20
|
||
|
|
#define KSCM_OP_LET2 21
|
||
|
|
#define KSCM_OP_LET0AST 22
|
||
|
|
#define KSCM_OP_LET1AST 23
|
||
|
|
#define KSCM_OP_LET2AST 24
|
||
|
|
#define KSCM_OP_LET0REC 25
|
||
|
|
#define KSCM_OP_LET1REC 26
|
||
|
|
#define KSCM_OP_LET2REC 27
|
||
|
|
#define KSCM_OP_COND0 28
|
||
|
|
#define KSCM_OP_COND1 29
|
||
|
|
#define KSCM_OP_DELAY 30
|
||
|
|
#define KSCM_OP_AND0 31
|
||
|
|
#define KSCM_OP_AND1 32
|
||
|
|
#define KSCM_OP_OR0 33
|
||
|
|
#define KSCM_OP_OR1 34
|
||
|
|
#define KSCM_OP_C0STREAM 35
|
||
|
|
#define KSCM_OP_C1STREAM 36
|
||
|
|
#define KSCM_OP_0MACRO 37
|
||
|
|
#define KSCM_OP_1MACRO 38
|
||
|
|
#define KSCM_OP_CASE0 39
|
||
|
|
#define KSCM_OP_CASE1 40
|
||
|
|
#define KSCM_OP_CASE2 41
|
||
|
|
|
||
|
|
#define KSCM_OP_PEVAL 42
|
||
|
|
#define KSCM_OP_PAPPLY 43
|
||
|
|
#define KSCM_OP_CONTINUATION 44
|
||
|
|
#define KSCM_OP_ADD 45
|
||
|
|
#define KSCM_OP_SUB 46
|
||
|
|
#define KSCM_OP_MUL 47
|
||
|
|
#define KSCM_OP_DIV 48
|
||
|
|
#define KSCM_OP_REM 49
|
||
|
|
#define KSCM_OP_CAR 50
|
||
|
|
#define KSCM_OP_CDR 51
|
||
|
|
#define KSCM_OP_CONS 52
|
||
|
|
#define KSCM_OP_SETCAR 53
|
||
|
|
#define KSCM_OP_SETCDR 54
|
||
|
|
#define KSCM_OP_NOT 55
|
||
|
|
#define KSCM_OP_BOOL 56
|
||
|
|
#define KSCM_OP_NULL 57
|
||
|
|
#define KSCM_OP_ZEROP 58
|
||
|
|
#define KSCM_OP_POSP 59
|
||
|
|
#define KSCM_OP_NEGP 60
|
||
|
|
#define KSCM_OP_NEQ 61
|
||
|
|
#define KSCM_OP_LESS 62
|
||
|
|
#define KSCM_OP_GRE 63
|
||
|
|
#define KSCM_OP_LEQ 64
|
||
|
|
#define KSCM_OP_GEQ 65
|
||
|
|
#define KSCM_OP_SYMBOL 66
|
||
|
|
#define KSCM_OP_NUMBER 67
|
||
|
|
#define KSCM_OP_STRING 68
|
||
|
|
#define KSCM_OP_PROC 69
|
||
|
|
#define KSCM_OP_PAIR 70
|
||
|
|
#define KSCM_OP_EQ 71
|
||
|
|
#define KSCM_OP_EQV 72
|
||
|
|
#define KSCM_OP_FORCE 73
|
||
|
|
#define KSCM_OP_WRITE 74
|
||
|
|
#define KSCM_OP_DISPLAY 75
|
||
|
|
#define KSCM_OP_NEWLINE 76
|
||
|
|
#define KSCM_OP_ERR0 77
|
||
|
|
#define KSCM_OP_ERR1 78
|
||
|
|
#define KSCM_OP_REVERSE 79
|
||
|
|
#define KSCM_OP_APPEND 80
|
||
|
|
#define KSCM_OP_PUT 81
|
||
|
|
#define KSCM_OP_GET 82
|
||
|
|
#define KSCM_OP_QUIT 83
|
||
|
|
#define KSCM_OP_GC 84
|
||
|
|
#define KSCM_OP_GCVERB 85
|
||
|
|
#define KSCM_OP_NEWSEGMENT 86
|
||
|
|
|
||
|
|
#define KSCM_OP_RDSEXPR 87
|
||
|
|
#define KSCM_OP_RDLIST 88
|
||
|
|
#define KSCM_OP_RDDOT 89
|
||
|
|
#define KSCM_OP_RDQUOTE 90
|
||
|
|
#define KSCM_OP_RDQQUOTE 91
|
||
|
|
#define KSCM_OP_RDUNQUOTE 92
|
||
|
|
#define KSCM_OP_RDUQTSP 93
|
||
|
|
|
||
|
|
#define KSCM_OP_P0LIST 94
|
||
|
|
#define KSCM_OP_P1LIST 95
|
||
|
|
|
||
|
|
#define KSCM_OP_LIST_LENGTH 96
|
||
|
|
#define KSCM_OP_ASSQ 97
|
||
|
|
#define KSCM_OP_PRINT_WIDTH 98
|
||
|
|
#define KSCM_OP_P0_WIDTH 99
|
||
|
|
#define KSCM_OP_P1_WIDTH 100
|
||
|
|
#define KSCM_OP_GET_CLOSURE 101
|
||
|
|
#define KSCM_OP_CLOSUREP 102
|
||
|
|
#define KSCM_OP_MACROP 103
|
||
|
|
|
||
|
|
#define KSCM_OP_STRCAT 104
|
||
|
|
#define KSCM_OP_STRLEN 105
|
||
|
|
#define KSCM_OP_STRGET 106
|
||
|
|
#define KSCM_OP_SAVE_STATE 107
|
||
|
|
#define KSCM_OP_RESUME_STATE 108
|
||
|
|
#define KSCM_OP_BUFFER 109
|
||
|
|
#define KSCM_OP_BUFFER_NEW 110
|
||
|
|
#define KSCM_OP_BUFFER_LEN 111
|
||
|
|
#define KSCM_OP_BUFFER_GET 112
|
||
|
|
#define KSCM_OP_BUFFER_SET 113
|
||
|
|
#define KSCM_OP_ABSTRACTION 114
|
||
|
|
#define KSCM_OP_ABSTRACTION_NEW 115
|
||
|
|
#define KSCM_OP_ABSTRACTION_TYPE 116
|
||
|
|
#define KSCM_OP_ABSTRACTION_VALUE 117
|
||
|
|
#define KSCM_OP_OBJECT 118
|
||
|
|
#define KSCM_OP_OBJECT_NEW 119
|
||
|
|
#define KSCM_OP_OBJECT_LEN 120
|
||
|
|
#define KSCM_OP_OBJECT_GET 121
|
||
|
|
#define KSCM_OP_OBJECT_SET 122
|
||
|
|
#define KSCM_OP_OBJECT_RETYPE 123
|
||
|
|
#define KSCM_OP_SYMBOL_TO_STRING 124
|
||
|
|
#define KSCM_OP_BUFFER_LOAD 125
|
||
|
|
#define KSCM_OP_BUFFER_SAVE 126
|
||
|
|
#define KSCM_OP_CONSOLE_MODE 127
|
||
|
|
#define KSCM_OP_CONSOLE_NEXT 128
|
||
|
|
#define KSCM_OP_CONSOLE_POLL 129
|
||
|
|
#define KSCM_OP_CONSOLE_WIDTH 130
|
||
|
|
#define KSCM_OP_CONSOLE_HEIGHT 131
|
||
|
|
|
||
|
|
#define KSCM_TOK_LPAREN 0
|
||
|
|
#define KSCM_TOK_RPAREN 1
|
||
|
|
#define KSCM_TOK_DOT 2
|
||
|
|
#define KSCM_TOK_ATOM 3
|
||
|
|
#define KSCM_TOK_QUOTE 4
|
||
|
|
#define KSCM_TOK_COMMENT 5
|
||
|
|
#define KSCM_TOK_DQUOTE 6
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
# define KSCM_TOK_BQUOTE 7
|
||
|
|
# define KSCM_TOK_COMMA 8
|
||
|
|
# define KSCM_TOK_ATMARK 9
|
||
|
|
#endif
|
||
|
|
#define KSCM_TOK_SHARP 10
|
||
|
|
|
||
|
|
typedef struct kscm kscm_t;
|
||
|
|
|
||
|
|
/* cell structure */
|
||
|
|
struct kscm_cell {
|
||
|
|
unsigned long _flag; // TODO: This should probably always be 32-bit
|
||
|
|
union {
|
||
|
|
struct {
|
||
|
|
char* _svalue;
|
||
|
|
short _keynum;
|
||
|
|
} _string;
|
||
|
|
struct {
|
||
|
|
long _ivalue; // TODO: This should probably always be 32-bit, i.e. representing a flexible "small int" value
|
||
|
|
} _number;
|
||
|
|
struct {
|
||
|
|
struct kscm_cell* _car;
|
||
|
|
struct kscm_cell* _cdr;
|
||
|
|
} _cons;
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
struct {
|
||
|
|
unsigned long _length;
|
||
|
|
unsigned char* _data;
|
||
|
|
} _buffer;
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_FLOATS
|
||
|
|
struct {
|
||
|
|
double _dvalue;
|
||
|
|
} _float64;
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
struct {
|
||
|
|
struct kscm_cell* _type;
|
||
|
|
long _count;
|
||
|
|
long _gccount;
|
||
|
|
struct kscm_cell** _elements;
|
||
|
|
} _objx;
|
||
|
|
#endif
|
||
|
|
} _object;
|
||
|
|
};
|
||
|
|
|
||
|
|
typedef struct kscm_cell* kscm_object_t;
|
||
|
|
|
||
|
|
typedef struct kscm_gcstate kscm_gcstate_t;
|
||
|
|
struct kscm_gcstate {
|
||
|
|
kscm_object_t object;
|
||
|
|
size_t offset;
|
||
|
|
};
|
||
|
|
|
||
|
|
#define KSCM_PERSIST_TINT32 1
|
||
|
|
#define KSCM_PERSIST_TSTRING 2
|
||
|
|
#define KSCM_PERSIST_TSYMBOL 3
|
||
|
|
#define KSCM_PERSIST_TPAIR 4
|
||
|
|
#define KSCM_PERSIST_TPROC 5
|
||
|
|
#define KSCM_PERSIST_TCLOSURE 6
|
||
|
|
#define KSCM_PERSIST_TSYNTAX 7
|
||
|
|
#define KSCM_PERSIST_TCONTINUATION 8
|
||
|
|
#define KSCM_PERSIST_TBUFFER 9
|
||
|
|
#define KSCM_PERSIST_TABSTRACTION 10
|
||
|
|
#define KSCM_PERSIST_TOBJX 11
|
||
|
|
#define KSCM_PERSIST_TFLOAT32_RESERVED 12
|
||
|
|
#define KSCM_PERSIST_TFLOAT64 13
|
||
|
|
#define KSCM_PERSIST_TUINT64_RESERVED 14
|
||
|
|
#define KSCM_PERSIST_TINT64_RESERVED 15
|
||
|
|
|
||
|
|
#define KSCM_T_STRING 1 /* 0000000000000001 */
|
||
|
|
#define KSCM_T_NUMBER 2 /* 0000000000000010 */
|
||
|
|
#define KSCM_T_SYMBOL 4 /* 0000000000000100 */
|
||
|
|
#define KSCM_T_SYNTAX 8 /* 0000000000001000 */
|
||
|
|
#define KSCM_T_PROC 16 /* 0000000000010000 */
|
||
|
|
#define KSCM_T_PAIR 32 /* 0000000000100000 */
|
||
|
|
#define KSCM_T_CLOSURE 64 /* 0000000001000000 */
|
||
|
|
#define KSCM_T_CONTINUATION 128 /* 0000000010000000 */
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
# define KSCM_T_MACRO 256/* 0000000100000000 */
|
||
|
|
#endif
|
||
|
|
#define KSCM_T_PROMISE 512 /* 0000001000000000 */
|
||
|
|
#define KSCM_T_BUFFER 1024/* 0000010000000000 */
|
||
|
|
#define KSCM_T_ABSTRACTION 2048/* 0000100000000000 */
|
||
|
|
#define KSCM_T_OBJX 4096/* 0001000000000000 */
|
||
|
|
#define KSCM_T_FLOAT64 8192/* 0010000000000000 */
|
||
|
|
#define KSCM_T_ATOM 16384 /* 0100000000000000 */ /* only for gc */
|
||
|
|
#define KSCM_CLRATOM 49151 /* 1011111111111111 */ /* only for gc */
|
||
|
|
#define KSCM_MARK 32768 /* 1000000000000000 */
|
||
|
|
#define KSCM_UNMARK 32767 /* 0111111111111111 */
|
||
|
|
|
||
|
|
/* macros for cell operations */
|
||
|
|
#define kscm__type(kscm,p) ((p)->_flag)
|
||
|
|
|
||
|
|
#define kscm__isstring(kscm,p) (kscm__type(kscm, p)&KSCM_T_STRING)
|
||
|
|
#define kscm__strvalue(kscm,p) ((p)->_object._string._svalue)
|
||
|
|
#define kscm__keynum(kscm,p) ((p)->_object._string._keynum)
|
||
|
|
|
||
|
|
#define kscm__isnumber(kscm,p) (kscm__type(kscm, p)&KSCM_T_NUMBER)
|
||
|
|
#define kscm__ivalue(kscm,p) ((p)->_object._number._ivalue)
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_FLOATS
|
||
|
|
#define kscm__isfloat64(kscm,p) (kscm__type(kscm, p)&KSCM_T_FLOAT64)
|
||
|
|
#define kscm__dvalue(kscm,p) ((p)->_object._float64._dvalue)
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#define kscm__ispair(kscm,p) (kscm__type(kscm,p)&KSCM_T_PAIR)
|
||
|
|
#define kscm__car(kscm,p) (p)->_object._cons._car
|
||
|
|
#define kscm__cdr(kscm,p) (p)->_object._cons._cdr
|
||
|
|
|
||
|
|
#define kscm__issymbol(kscm,p) (kscm__type(kscm, p)&KSCM_T_SYMBOL)
|
||
|
|
#define kscm__symname(kscm,p) kscm__strvalue(kscm, kscm__car(kscm, p))
|
||
|
|
#define kscm__hasprop(kscm,p) (kscm__type(kscm, p)&KSCM_T_SYMBOL)
|
||
|
|
#define kscm__symprop(kscm,p) kscm__cdr(kscm, p)
|
||
|
|
|
||
|
|
#define kscm__issyntax(kscm,p) (kscm__type(kscm, p)&KSCM_T_SYNTAX)
|
||
|
|
#define kscm__isproc(kscm,p) (kscm__type(kscm, p)&KSCM_T_PROC)
|
||
|
|
#define kscm__syntaxname(kscm,p) kscm__strvalue(kscm, kscm__car(kscm, p))
|
||
|
|
#define kscm__syntaxnum(kscm,p) kscm__keynum(kscm, kscm__car(kscm, p))
|
||
|
|
#define kscm__procnum(kscm,p) kscm__ivalue(kscm, p)
|
||
|
|
|
||
|
|
#define kscm__isclosure(kscm,p) (kscm__type(kscm, p)&KSCM_T_CLOSURE)
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
# define kscm__ismacro(kscm,p) (kscm__type(kscm, p)&KSCM_T_MACRO)
|
||
|
|
#endif
|
||
|
|
#define kscm__closure_code(kscm,p) kscm__car(kscm, p)
|
||
|
|
#define kscm__closure_env(kscm,p) kscm__cdr(kscm, p)
|
||
|
|
|
||
|
|
#define kscm__iscontinuation(kscm,p) (kscm__type(kscm, p)&KSCM_T_CONTINUATION)
|
||
|
|
#define kscm__cont_dump(kscm,p) kscm__cdr(kscm, p)
|
||
|
|
|
||
|
|
#define kscm__ispromise(kscm,p) (kscm__type(kscm,p)&KSCM_T_PROMISE)
|
||
|
|
#define kscm__setpromise(kscm,p) kscm__type(kscm,p) |= KSCM_T_PROMISE
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
#define kscm__isbuffer(kscm,p) (kscm__type(kscm,p)&KSCM_T_BUFFER)
|
||
|
|
#define kscm__isabstraction(kscm,p) (kscm__type(kscm,p)&KSCM_T_ABSTRACTION)
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
#define kscm__isobjx(kscm,p) (kscm__type(kscm,p)&KSCM_T_OBJX)
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#define kscm__isatom(kscm,p) (kscm__type(kscm,p)&KSCM_T_ATOM)
|
||
|
|
#define kscm__setatom(kscm,p) kscm__type(kscm,p) |= KSCM_T_ATOM
|
||
|
|
#define kscm__clratom(kscm,p) kscm__type(kscm,p) &= KSCM_CLRATOM
|
||
|
|
|
||
|
|
#define kscm__ismark(kscm,p) (kscm__type(kscm, p)&KSCM_MARK)
|
||
|
|
#define kscm__setmark(kscm,p) kscm__type(kscm, p) |= KSCM_MARK
|
||
|
|
#define kscm__clrmark(kscm,p) kscm__type(kscm, p) &= KSCM_UNMARK
|
||
|
|
|
||
|
|
#define kscm__caar(kscm, p) kscm__car(kscm, kscm__car(kscm, p))
|
||
|
|
#define kscm__cadr(kscm, p) kscm__car(kscm, kscm__cdr(kscm, p))
|
||
|
|
#define kscm__cdar(kscm, p) kscm__cdr(kscm, kscm__car(kscm, p))
|
||
|
|
#define kscm__cddr(kscm, p) kscm__cdr(kscm, kscm__cdr(kscm, p))
|
||
|
|
#define kscm__cadar(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__car(kscm, p)))
|
||
|
|
#define kscm__caddr(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__cdr(kscm, p)))
|
||
|
|
#define kscm__cadaar(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__car(kscm, kscm__car(kscm, p))))
|
||
|
|
#define kscm__cadddr(kscm, p) kscm__car(kscm, kscm__cdr(kscm, kscm__cdr(kscm, kscm__cdr(kscm, p))))
|
||
|
|
#define kscm__cddddr(kscm, p) kscm__cdr(kscm, kscm__cdr(kscm, kscm__cdr(kscm, kscm__cdr(kscm, p))))
|
||
|
|
|
||
|
|
#define LINESIZE 1024
|
||
|
|
|
||
|
|
struct kscm {
|
||
|
|
/* arrays for segments */
|
||
|
|
kscm_object_t* cell_seg;
|
||
|
|
int last_cell_seg;// = -1;
|
||
|
|
int gcstate_max;
|
||
|
|
kscm_gcstate_t* gcstate;
|
||
|
|
//char* str_seg[KSCM_CONFIG_STR_NSEGMENT];
|
||
|
|
//int str_seglast;// = -1;
|
||
|
|
|
||
|
|
/* We use 4 registers (actually, some more registers are used internally). */
|
||
|
|
kscm_object_t args; /* register for arguments of function */
|
||
|
|
kscm_object_t envir; /* stack register for current environment */
|
||
|
|
kscm_object_t code; /* register for current code */
|
||
|
|
kscm_object_t dump; /* stack register for next evaluation */
|
||
|
|
|
||
|
|
/* The VM is currently single-threaded, but to facilitate compatibility with future/other versions
|
||
|
|
* some information is associated with the "main thread" as though it were one thread in a multi-threaded
|
||
|
|
* environment.
|
||
|
|
*/
|
||
|
|
int _threadstate;
|
||
|
|
kscm_object_t _threadname;
|
||
|
|
kscm_object_t _threadopts;
|
||
|
|
kscm_object_t _threadobject;
|
||
|
|
|
||
|
|
/* Right now, the state format just contains the number of bytes per reference (either 4 or 8). */
|
||
|
|
int _stateformat;
|
||
|
|
|
||
|
|
//struct kscm_cell _NIL;
|
||
|
|
kscm_object_t NIL;// = &_NIL; /* special cell representing empty cell */
|
||
|
|
//struct kscm_cell _T;
|
||
|
|
kscm_object_t T;// = &_T; /* special cell representing #t */
|
||
|
|
//struct kscm_cell _F;
|
||
|
|
kscm_object_t F;// = &_F; /* special cell representing #f */
|
||
|
|
kscm_object_t oblist;// = &_NIL; /* pointer to symbol table */
|
||
|
|
kscm_object_t global_env; /* pointer to global environment */
|
||
|
|
|
||
|
|
/* global pointers to special symbols */
|
||
|
|
kscm_object_t LAMBDA; /* pointer to syntax lambda */
|
||
|
|
kscm_object_t QUOTE; /* pointer to syntax quote */
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
kscm_object_t QQUOTE; /* pointer to symbol quasiquote */
|
||
|
|
kscm_object_t UNQUOTE; /* pointer to symbol unquote */
|
||
|
|
kscm_object_t UNQUOTESP; /* pointer to symbol unquote-splicing */
|
||
|
|
|
||
|
|
#endif
|
||
|
|
|
||
|
|
kscm_object_t free_cell;// = &_NIL; /* pointer to top of free cells */
|
||
|
|
long fcells;// = 0; /* # of free cells */
|
||
|
|
|
||
|
|
//FILE* infp; /* input file */
|
||
|
|
FILE* inputs[KSCM_CONFIG_MAXLOADS];
|
||
|
|
int inputtop; // = 0; (TODO: Remove the other initialisers - assume calloc or similar clears memory prior during manual initialisation)
|
||
|
|
FILE* outfp; /* output file */
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_SETJMP
|
||
|
|
jmp_buf error_jmp;
|
||
|
|
|
||
|
|
#endif
|
||
|
|
char gc_verbose; /* if gc_verbose is not zero, print gc status */
|
||
|
|
int quiet;// = 0; /* if not zero, print KSCM_CONFIG_BANNER, KSCM_CONFIG_PROMPT, results */
|
||
|
|
int all_errors_fatal;// = 0; /* if not zero, every error is a FatalError */
|
||
|
|
|
||
|
|
FILE* tmpfp;
|
||
|
|
int tok;
|
||
|
|
int print_flag;
|
||
|
|
kscm_object_t value;
|
||
|
|
short _operator;
|
||
|
|
|
||
|
|
char linebuff[LINESIZE];
|
||
|
|
char strbuff[256];
|
||
|
|
char* currentline;// = linebuff;
|
||
|
|
char* endline;// = linebuff;
|
||
|
|
};
|
||
|
|
|
||
|
|
/* allocate new cell segment */
|
||
|
|
int kscm__alloc_cellseg(kscm_t *kscm, int n)
|
||
|
|
{
|
||
|
|
/*register*/ kscm_object_t p;
|
||
|
|
/*register*/ long i;
|
||
|
|
/*register*/ int k;
|
||
|
|
|
||
|
|
for (k = 0; k < n; k++) {
|
||
|
|
if (kscm->last_cell_seg >= (KSCM_CONFIG_CELL_NSEGMENT - 1))
|
||
|
|
return k;
|
||
|
|
p = (kscm_object_t)calloc(1,KSCM_CONFIG_CELL_SEGSIZE * sizeof(struct kscm_cell));
|
||
|
|
if (p == (kscm_object_t)0)
|
||
|
|
return k;
|
||
|
|
kscm->last_cell_seg++;
|
||
|
|
kscm->cell_seg[kscm->last_cell_seg] = p;
|
||
|
|
kscm->fcells += KSCM_CONFIG_CELL_SEGSIZE;
|
||
|
|
|
||
|
|
for (i = 0; i < KSCM_CONFIG_CELL_SEGSIZE; i++) {
|
||
|
|
kscm__type(kscm, p+i) = 0;
|
||
|
|
kscm__car(kscm, p+i) = kscm->NIL;
|
||
|
|
kscm__cdr(kscm, p+i) = kscm->free_cell;
|
||
|
|
kscm->free_cell = p+i;
|
||
|
|
//p++;
|
||
|
|
}
|
||
|
|
|
||
|
|
//for (i = 0; i < (KSCM_CONFIG_CELL_SEGSIZE - 1); i++/*, p++*/) {
|
||
|
|
/* kscm__type(kscm, p) = 0;
|
||
|
|
kscm__car(kscm, p) = kscm->NIL;
|
||
|
|
kscm__cdr(kscm, p) = (p + 1);
|
||
|
|
|
||
|
|
//fprintf(stderr, "Added cell %d @ %lx %lx %lx\n", i, kscm__cdr(kscm, p), (p + 1), kscm->NIL);
|
||
|
|
p++;
|
||
|
|
}
|
||
|
|
kscm__type(kscm, p) = 0;
|
||
|
|
kscm__car(kscm, p) = kscm->NIL;
|
||
|
|
kscm__cdr(kscm, p) = kscm->free_cell;
|
||
|
|
kscm->free_cell = kscm->cell_seg[kscm->last_cell_seg];*/
|
||
|
|
}
|
||
|
|
return n;
|
||
|
|
}
|
||
|
|
|
||
|
|
/* allocate new string segment */
|
||
|
|
/*int kscm__alloc_strseg(kscm_t* kscm, int n)
|
||
|
|
{
|
||
|
|
register char* p;
|
||
|
|
register long i;
|
||
|
|
register int k;
|
||
|
|
|
||
|
|
for (k = 0; k < n; k++) {
|
||
|
|
if (kscm->str_seglast >= KSCM_CONFIG_STR_NSEGMENT)
|
||
|
|
return k;
|
||
|
|
p = (char*)malloc(KSCM_CONFIG_STR_SEGSIZE * sizeof(char));
|
||
|
|
if (p == (char*)0)
|
||
|
|
return k;
|
||
|
|
kscm->str_seg[++kscm->str_seglast] = p;
|
||
|
|
for (i = 0; i < KSCM_CONFIG_STR_SEGSIZE; i++)
|
||
|
|
*p++ = (char)(-1);
|
||
|
|
}
|
||
|
|
return n;
|
||
|
|
}*/
|
||
|
|
|
||
|
|
void kscm__fatal_error(kscm_t* kscm, const char* msg, const char* a, const char* b, const char* c);
|
||
|
|
void kscm__error(kscm_t* kscm, const char* msg, const char* a, const char* b, const char* c);
|
||
|
|
void kscm__init_globals(kscm_t* kscm);
|
||
|
|
kscm_object_t kscm__mk_string(kscm_t* kscm, const char* str);
|
||
|
|
|
||
|
|
struct kscm_cell _NIL;
|
||
|
|
struct kscm_cell _T;
|
||
|
|
struct kscm_cell _F;
|
||
|
|
|
||
|
|
/* initialization of Mini-Scheme */
|
||
|
|
void kscm__init_scheme(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
memset(&_NIL, 0, sizeof(struct kscm_cell));
|
||
|
|
memset(&_T, 0, sizeof(struct kscm_cell));
|
||
|
|
memset(&_F, 0, sizeof(struct kscm_cell));
|
||
|
|
|
||
|
|
/*register*/ kscm_object_t i;
|
||
|
|
|
||
|
|
kscm->last_cell_seg = -1;
|
||
|
|
//kscm->str_seglast = -1;
|
||
|
|
kscm->NIL = &_NIL;
|
||
|
|
kscm->T = &_T;
|
||
|
|
kscm->F = &_F;
|
||
|
|
kscm->oblist = &_NIL;
|
||
|
|
kscm->free_cell = &_NIL;
|
||
|
|
|
||
|
|
fprintf(stderr, "Initialising scheme...\n");
|
||
|
|
|
||
|
|
if (kscm__alloc_cellseg(kscm, KSCM_CONFIG_FIRST_CELLSEGS) != KSCM_CONFIG_FIRST_CELLSEGS)
|
||
|
|
kscm__fatal_error(kscm, "Unable to allocate initial cell segments", NULL, NULL, NULL);
|
||
|
|
/*if (!kscm__alloc_strseg(kscm, 1))
|
||
|
|
kscm__fatal_error(kscm, "Unable to allocate initial string segments", NULL, NULL, NULL);*/
|
||
|
|
#ifdef VERBOSE
|
||
|
|
kscm->gc_verbose = 1;
|
||
|
|
#else
|
||
|
|
kscm->gc_verbose = 0;
|
||
|
|
#endif
|
||
|
|
kscm->_stateformat = 4;
|
||
|
|
kscm->_threadstate = 1;
|
||
|
|
kscm->_threadobject = kscm->NIL;
|
||
|
|
fprintf(stderr, "Initialising strings...\n");
|
||
|
|
kscm->_threadname = kscm__mk_string(kscm, "main");
|
||
|
|
fprintf(stderr, "Initialising strings...\n");
|
||
|
|
kscm->_threadopts = kscm__mk_string(kscm, "");
|
||
|
|
fprintf(stderr, "Initialising globals...\n");
|
||
|
|
kscm__init_globals(kscm);
|
||
|
|
}
|
||
|
|
|
||
|
|
void kscm__gc(kscm_t* kscm,/* register*/ kscm_object_t a, /*register*/ kscm_object_t b);
|
||
|
|
|
||
|
|
/* get new cell. parameter a, b is marked by gc. */
|
||
|
|
kscm_object_t kscm__get_cell(kscm_t* kscm, /*register*/ kscm_object_t a, /*register*/ kscm_object_t b)
|
||
|
|
{
|
||
|
|
// return calloc(1,sizeof(struct kscm_cell));
|
||
|
|
//#if 0
|
||
|
|
/*register*/ kscm_object_t x;
|
||
|
|
//fprintf(stderr, "A\n");
|
||
|
|
if (kscm->free_cell == kscm->NIL) {
|
||
|
|
//fprintf(stderr, "B\n");
|
||
|
|
kscm__gc(kscm, a, b);
|
||
|
|
if (kscm->free_cell == kscm->NIL) {
|
||
|
|
//fprintf(stderr, "C\n");
|
||
|
|
#ifdef KSCM_CONFIG_USE_SETJMP
|
||
|
|
if (!kscm__alloc_cellseg(kscm, 1)) {
|
||
|
|
//fprintf(stderr, "D\n");
|
||
|
|
kscm->args = kscm->envir = kscm->code = kscm->dump = kscm->NIL;
|
||
|
|
kscm__gc(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
if (kscm->free_cell != kscm->NIL) {
|
||
|
|
kscm__error(kscm, "run out of cells --- rerurn to top level", NULL, NULL, NULL);
|
||
|
|
} else {
|
||
|
|
kscm__fatal_error(kscm, "run out of cells --- unable to recover cells", NULL, NULL, NULL);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
if (!kscm__alloc_cellseg(kscm, 1)) {
|
||
|
|
//fprintf(stderr, "E\n");
|
||
|
|
kscm__fatal_error(kscm, "run out of cells --- unable to recover cells", NULL, NULL, NULL);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
}
|
||
|
|
//fprintf(stderr, "F\n");
|
||
|
|
x = kscm->free_cell;
|
||
|
|
//fprintf(stderr, "G %lx\n", x);
|
||
|
|
//fprintf(stderr, "G %lx\n", kscm__cdr(kscm, x));
|
||
|
|
kscm->free_cell = kscm__cdr(kscm, x);
|
||
|
|
//fprintf(stderr, "H\n");
|
||
|
|
kscm->fcells--;
|
||
|
|
//fprintf(stderr, "I\n");
|
||
|
|
return x;
|
||
|
|
//#endif
|
||
|
|
}
|
||
|
|
|
||
|
|
/* get new cons cell */
|
||
|
|
kscm_object_t kscm__cons(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b)
|
||
|
|
{
|
||
|
|
register kscm_object_t x = kscm__get_cell(kscm, a, b);
|
||
|
|
|
||
|
|
kscm__type(kscm, x) = KSCM_T_PAIR;
|
||
|
|
kscm__car(kscm, x) = a;
|
||
|
|
kscm__cdr(kscm, x) = b;
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* get number atom */
|
||
|
|
kscm_object_t kscm__mk_number(kscm_t* kscm, register long num)
|
||
|
|
{
|
||
|
|
register kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
|
||
|
|
kscm__type(kscm, x) = (KSCM_T_NUMBER | KSCM_T_ATOM);
|
||
|
|
kscm__ivalue(kscm, x) = num;
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_FLOATS
|
||
|
|
kscm_object_t kscm__mk_float64(kscm_t* kscm, double value) {
|
||
|
|
kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
|
||
|
|
kscm__type(kscm, x) = (KSCM_T_FLOAT64 | KSCM_T_ATOM);
|
||
|
|
x->_object._float64._dvalue = value;
|
||
|
|
|
||
|
|
return x;
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
/* allocate name to string area */
|
||
|
|
//char* kscm__store_string(kscm_t* kscm, const char *name)
|
||
|
|
//{
|
||
|
|
// register char* q = NULL;
|
||
|
|
// register short i;
|
||
|
|
// long len, remain;
|
||
|
|
//
|
||
|
|
// /* first check name has already listed */
|
||
|
|
// for (i = 0; i <= kscm->str_seglast; i++)
|
||
|
|
// for (q = kscm->str_seg[i]; *q != (char)(-1); ) {
|
||
|
|
// if (!strcmp(q, name))
|
||
|
|
// goto FOUND;
|
||
|
|
// while (*q++)
|
||
|
|
// ; /* get next string */
|
||
|
|
// }
|
||
|
|
// len = strlen(name) + 2;
|
||
|
|
// // TODO: Replace legacy types, it's starting to get ugly. -Zak
|
||
|
|
// remain = (long long)KSCM_CONFIG_STR_SEGSIZE - ((long long)q - (long long)kscm->str_seg[kscm->str_seglast]);
|
||
|
|
// if (remain < len) {
|
||
|
|
// if (!kscm__alloc_strseg(kscm, 1))
|
||
|
|
// kscm__fatal_error(kscm, "run out of string area", NULL, NULL, NULL);
|
||
|
|
// q = kscm->str_seg[kscm->str_seglast];
|
||
|
|
// /*if ((long long)KSCM_CONFIG_STR_SEGSIZE - ((long long)q - (long long)kscm->str_seg[kscm->str_seglast])) {
|
||
|
|
// fprintf(stderr, "String in question's total length is %d", len);
|
||
|
|
// kscm__fatal_error(kscm, "string too big", NULL, NULL, NULL);
|
||
|
|
// }*/
|
||
|
|
// }
|
||
|
|
// strcpy(q, name);
|
||
|
|
//FOUND:
|
||
|
|
// return (q);
|
||
|
|
//}
|
||
|
|
|
||
|
|
/* get new string */
|
||
|
|
kscm_object_t kscm__mk_string(kscm_t* kscm, const char *str)
|
||
|
|
{
|
||
|
|
/*register*/ kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
#ifdef __WIN32
|
||
|
|
kscm__strvalue(kscm, x) = _strdup(str);//kscm__store_string(kscm, str);
|
||
|
|
#else
|
||
|
|
kscm__strvalue(kscm, x) = strdup(str);//kscm__store_string(kscm, str);
|
||
|
|
#endif
|
||
|
|
kscm__type(kscm, x) = (KSCM_T_STRING | KSCM_T_ATOM);
|
||
|
|
kscm__keynum(kscm, x) = (short)(-1);
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* get new symbol */
|
||
|
|
kscm_object_t kscm__mk_symbol(kscm_t* kscm, const char *name)
|
||
|
|
{
|
||
|
|
register kscm_object_t x;
|
||
|
|
|
||
|
|
/* fisrt check oblist */
|
||
|
|
for (x = kscm->oblist; x != kscm->NIL; x = kscm__cdr(kscm, x))
|
||
|
|
if (!strcmp(name, kscm__symname(kscm, kscm__car(kscm, x))))
|
||
|
|
break;
|
||
|
|
|
||
|
|
if (x != kscm->NIL)
|
||
|
|
return (kscm__car(kscm, x));
|
||
|
|
else {
|
||
|
|
x = kscm__cons(kscm, kscm__mk_string(kscm, name), kscm->NIL);
|
||
|
|
kscm__type(kscm, x) = KSCM_T_SYMBOL;
|
||
|
|
kscm->oblist = kscm__cons(kscm, x, kscm->oblist);
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
kscm_object_t kscm__mk_buffer(kscm_t* kscm, long len) {
|
||
|
|
void* d = calloc(1, len);
|
||
|
|
if (d == NULL) {
|
||
|
|
return kscm->NIL;
|
||
|
|
}
|
||
|
|
kscm_object_t result = kscm__get_cell(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
kscm__type(kscm, result) = (KSCM_T_BUFFER | KSCM_T_ATOM);
|
||
|
|
result->_object._buffer._length = len;
|
||
|
|
result->_object._buffer._data = (unsigned char*) d;
|
||
|
|
return result;
|
||
|
|
}
|
||
|
|
kscm_object_t kscm__mk_abstraction(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b)
|
||
|
|
{
|
||
|
|
register kscm_object_t x = kscm__get_cell(kscm, a, b);
|
||
|
|
|
||
|
|
kscm__type(kscm, x) = KSCM_T_ABSTRACTION;
|
||
|
|
kscm__car(kscm, x) = a;
|
||
|
|
kscm__cdr(kscm, x) = b;
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
kscm_object_t kscm__mk_objx(kscm_t* kscm, kscm_object_t typ, long len) {
|
||
|
|
void* d = calloc(sizeof(kscm_object_t), len);
|
||
|
|
if (d == NULL) {
|
||
|
|
return kscm->NIL;
|
||
|
|
}
|
||
|
|
kscm_object_t result = kscm__get_cell(kscm, typ, kscm->NIL);
|
||
|
|
kscm__type(kscm, result) = KSCM_T_OBJX;
|
||
|
|
result->_object._objx._type = typ;
|
||
|
|
result->_object._objx._count = len;
|
||
|
|
result->_object._objx._elements = (kscm_object_t*)d;
|
||
|
|
long i;
|
||
|
|
for (i = 0; i < len; i++) {
|
||
|
|
result->_object._objx._elements[i] = kscm->NIL;
|
||
|
|
}
|
||
|
|
return result;
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
int kscm__safedigit(kscm_t* kscm, int base, char d) {
|
||
|
|
if (base <= 10) {
|
||
|
|
if (d >= '0' && d < '0' + base) {
|
||
|
|
return d - '0';
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else if (base == 16) {
|
||
|
|
if (d >= '0' && d < '0' + 10) {
|
||
|
|
return d - '0';
|
||
|
|
}
|
||
|
|
else if (d >= 'a' && d < 'a' + 6) {
|
||
|
|
return 10 + (d - 'a');
|
||
|
|
}
|
||
|
|
else if (d >= 'A' && d < 'A' + 6) {
|
||
|
|
return 10 + (d - 'A');
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
kscm_object_t kscm__mk_safenum(kscm_t* kscm, int base, const char* src) {
|
||
|
|
char c;
|
||
|
|
const char* p;
|
||
|
|
int32_t v = 0;
|
||
|
|
int negate = 0;
|
||
|
|
p = src;
|
||
|
|
if (p[0] == '-') {
|
||
|
|
negate = 1;
|
||
|
|
p++;
|
||
|
|
}
|
||
|
|
else if (p[0] == '+') {
|
||
|
|
p++;
|
||
|
|
}
|
||
|
|
if (kscm__safedigit(kscm, base, p[0]) < 0) {
|
||
|
|
return kscm->F;
|
||
|
|
}
|
||
|
|
while (kscm__safedigit(kscm, base, p[0]) >= 0) {
|
||
|
|
int64_t lv = ((int64_t)v) * base + kscm__safedigit(kscm, base, p[0]);
|
||
|
|
v = (int32_t)lv;
|
||
|
|
//printf("Adding digit %d to get %d\n", kscm__safedigit(kscm, base, p[0]), v);
|
||
|
|
if (((int64_t)v) != lv) {
|
||
|
|
return kscm->F;
|
||
|
|
}
|
||
|
|
p++;
|
||
|
|
}
|
||
|
|
|
||
|
|
if (negate) {
|
||
|
|
v = -v;
|
||
|
|
}
|
||
|
|
|
||
|
|
return kscm__mk_number(kscm, v);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
/* make symbol or number atom from string */
|
||
|
|
kscm_object_t kscm__mk_atom(kscm_t* kscm, const char *q)
|
||
|
|
{
|
||
|
|
char c;
|
||
|
|
const char *p;
|
||
|
|
|
||
|
|
p = q;
|
||
|
|
if (!isdigit(c = *p++)) {
|
||
|
|
if ((c != '+' && c != '-') || !isdigit(*p))
|
||
|
|
return (kscm__mk_symbol(kscm, q));
|
||
|
|
}
|
||
|
|
#ifdef KSCM_CONFIG_USE_FLOATS
|
||
|
|
bool isFloat = false;
|
||
|
|
bool hasE = false;
|
||
|
|
bool hasESign = false;
|
||
|
|
char prev = ' ';
|
||
|
|
for (; (c = *p) != 0; ++p) {
|
||
|
|
if (!isdigit(c)) {
|
||
|
|
if (!isFloat && c == '.') {
|
||
|
|
isFloat = true;
|
||
|
|
}
|
||
|
|
else if (isFloat && !hasE && (c == 'e' || c == 'E')) {
|
||
|
|
hasE = true;
|
||
|
|
}
|
||
|
|
else if (isFloat && hasE && (prev == 'e' || prev == 'E') && (c == '+' || c == '-')) {
|
||
|
|
hasESign = true;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
return (kscm__mk_symbol(kscm, q));
|
||
|
|
}
|
||
|
|
}
|
||
|
|
prev = c;
|
||
|
|
}
|
||
|
|
if (isFloat) {
|
||
|
|
return kscm__mk_float64(kscm, atof(q));
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
for (; (c = *p) != 0; ++p)
|
||
|
|
if (!isdigit(c))
|
||
|
|
return (kscm__mk_symbol(kscm, q));
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
kscm_object_t result = kscm__mk_safenum(kscm, 10, q);
|
||
|
|
if (result == kscm->F) {
|
||
|
|
//fprintf(stderr, "WARNING: Math overflow in '%s'\n", q);
|
||
|
|
result = kscm__cons(kscm, kscm__mk_symbol(kscm, "parse-number"), kscm__cons(kscm, kscm__mk_string(kscm, q), kscm->NIL));
|
||
|
|
}
|
||
|
|
return result;
|
||
|
|
#else
|
||
|
|
return (kscm__mk_number(kscm, atol(q)));
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
|
||
|
|
/* make constant */
|
||
|
|
kscm_object_t kscm__mk_const(kscm_t* kscm, const char *name)
|
||
|
|
{
|
||
|
|
long x;
|
||
|
|
char tmp[256];
|
||
|
|
|
||
|
|
if (!strcmp(name, "t"))
|
||
|
|
return (kscm->T);
|
||
|
|
else if (!strcmp(name, "f"))
|
||
|
|
return (kscm->F);
|
||
|
|
else if (*name == 'o') {/* #o (octal) */
|
||
|
|
sprintf(tmp, "0%s", /*&name[1]*/ name+1);
|
||
|
|
fprintf(stderr, "TODO: Octal parsing!\n"); exit(-1);
|
||
|
|
//sscanf(tmp, "%lo", (unsigned long int*) & x);
|
||
|
|
return (kscm__mk_number(kscm, x));
|
||
|
|
}
|
||
|
|
else if (*name == 'd') { /* #d (decimal) */
|
||
|
|
x = atoll(name+1); //sscanf(&name[1], "%ld", &x);
|
||
|
|
return (kscm__mk_number(kscm, x));
|
||
|
|
}
|
||
|
|
else if (*name == 'x') { /* #x (hex) */
|
||
|
|
sprintf(tmp, "0x%s", &name[1]);
|
||
|
|
fprintf(stderr, "TODO: Hex parsing!\n"); exit(-1);
|
||
|
|
//sscanf(tmp, "%lx", (unsigned long int*) & x);
|
||
|
|
return (kscm__mk_number(kscm, x));
|
||
|
|
}
|
||
|
|
else
|
||
|
|
return (kscm->NIL);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
/* ========== garbage collector ========== */
|
||
|
|
|
||
|
|
/*--
|
||
|
|
* We use algorithm E (Kunuth, The Art of Computer Programming Vol.1,
|
||
|
|
* sec.3.5) for marking.
|
||
|
|
*
|
||
|
|
* NOTE: The implementation is complicated a bit when using object-oriented/vector extensions.
|
||
|
|
* I've decided to just use recursive marking in this case, but I've added some documentation to
|
||
|
|
* the original algorithm as well in case anyone wants to update it.
|
||
|
|
*/
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
#define KSCM_GC_MAXREC 100000
|
||
|
|
void kscm__fastmark(kscm_t* kscm, kscm_object_t root) {
|
||
|
|
int stacklevel = 0;
|
||
|
|
|
||
|
|
kscm->gcstate[stacklevel].object = root;
|
||
|
|
kscm->gcstate[stacklevel].offset = 0;
|
||
|
|
|
||
|
|
while (stacklevel >= 0) {
|
||
|
|
kscm_object_t a = kscm->gcstate[stacklevel].object;
|
||
|
|
long o = kscm->gcstate[stacklevel].offset;
|
||
|
|
|
||
|
|
if (o == 0) {
|
||
|
|
if (kscm__ismark(kscm, a)) {
|
||
|
|
stacklevel--;
|
||
|
|
continue;
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm__setmark(kscm, a);
|
||
|
|
|
||
|
|
if (kscm__isatom(kscm, a)) {
|
||
|
|
stacklevel--;
|
||
|
|
continue;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm->gcstate[stacklevel].offset = o + 1;
|
||
|
|
|
||
|
|
if (stacklevel + 1 >= kscm->gcstate_max) {
|
||
|
|
fprintf(stderr, "ERROR: Garbage collection stack limit reached! Current limit is set at %d!\n", kscm->gcstate_max);
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
|
||
|
|
if (kscm__isobjx(kscm, a)) {
|
||
|
|
if (o == 0) {
|
||
|
|
stacklevel++;
|
||
|
|
kscm->gcstate[stacklevel].object = a->_object._objx._type;
|
||
|
|
kscm->gcstate[stacklevel].offset = 0;
|
||
|
|
} else if (o - 1 >= a->_object._objx._count) {
|
||
|
|
stacklevel--;
|
||
|
|
continue;
|
||
|
|
} else {
|
||
|
|
stacklevel++;
|
||
|
|
kscm->gcstate[stacklevel].object = a->_object._objx._elements[o-1];
|
||
|
|
kscm->gcstate[stacklevel].offset = 0;
|
||
|
|
}
|
||
|
|
} else { /* Is pair or pair-like abstraction*/
|
||
|
|
if (o == 0) {
|
||
|
|
stacklevel++;
|
||
|
|
kscm->gcstate[stacklevel].object = kscm__car(kscm, a);
|
||
|
|
kscm->gcstate[stacklevel].offset = 0;
|
||
|
|
} else if (o == 1) {
|
||
|
|
stacklevel++;
|
||
|
|
kscm->gcstate[stacklevel].object = kscm__cdr(kscm, a);
|
||
|
|
kscm->gcstate[stacklevel].offset = 0;
|
||
|
|
} else {
|
||
|
|
stacklevel--;
|
||
|
|
continue;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
}
|
||
|
|
}
|
||
|
|
void kscm__recursivemark(kscm_t* kscm, kscm_object_t a, int recursionlevel) {
|
||
|
|
printf("Recursion=%d\n", recursionlevel);
|
||
|
|
if (recursionlevel > KSCM_GC_MAXREC) {
|
||
|
|
fprintf(stderr, "WARNING: Garbage collector is recursing like a motherfucker\n");
|
||
|
|
recursionlevel = 0; // We just reset it though, the warning should be enough to show if it's becoming a problem
|
||
|
|
}
|
||
|
|
|
||
|
|
if (kscm__ismark(kscm, a)) {
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm__setmark(kscm, a);
|
||
|
|
|
||
|
|
if (kscm__isatom(kscm, a)) {
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
if (kscm__isobjx(kscm, a)) {
|
||
|
|
kscm__recursivemark(kscm, a->_object._objx._type, recursionlevel + 1);
|
||
|
|
int i;
|
||
|
|
for (i = 0; i < a->_object._objx._count; i++) {
|
||
|
|
//printf("Recursively marking object at index %d\n", i);
|
||
|
|
kscm__recursivemark(kscm, a->_object._objx._elements[i], recursionlevel + 1);
|
||
|
|
}
|
||
|
|
} else { /* Is pair or pair-like abstraction*/
|
||
|
|
kscm__recursivemark(kscm, kscm__car(kscm, a), recursionlevel + 1);
|
||
|
|
kscm__recursivemark(kscm, kscm__cdr(kscm, a), recursionlevel + 1);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
void kscm__mark(kscm_t* kscm, kscm_object_t a) {
|
||
|
|
//kscm__recursivemark(kscm, a, 1);
|
||
|
|
kscm__fastmark(kscm, a);
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
void kscm__mark(kscm_t* kscm, kscm_object_t a)
|
||
|
|
{
|
||
|
|
register kscm_object_t t; /* Used to track the previous object. This object will in turn be used to track it's previous. */
|
||
|
|
register kscm_object_t q; /* Used as a temporary value to hold our subreferences. */
|
||
|
|
register kscm_object_t p; /* Points to the current object. */
|
||
|
|
|
||
|
|
/* E1: Start of algorithm. Reset t and p. */
|
||
|
|
E1: t = (kscm_object_t)0;
|
||
|
|
p = a;
|
||
|
|
/* E2: Start by marking p (i.e. marking it as "keep this cell"). */
|
||
|
|
E2: kscm__setmark(kscm, p);
|
||
|
|
/* E3: Check type. If it's an atom (not built out of references to other cells) we can skip marking references. */
|
||
|
|
E3: if (kscm__isatom(kscm, p))
|
||
|
|
goto E6;
|
||
|
|
/* E4: Mark first reference ("car" or equivalent) if it's not already marked. */
|
||
|
|
E4:
|
||
|
|
q = kscm__car(kscm, p);
|
||
|
|
if (q && !kscm__ismark(kscm, q)) {
|
||
|
|
kscm__setatom(kscm, p);
|
||
|
|
kscm__car(kscm, p) = t;
|
||
|
|
t = p;
|
||
|
|
p = q;
|
||
|
|
goto E2;
|
||
|
|
}
|
||
|
|
/* E5: Mark second/nth references if they're not already marked. */
|
||
|
|
E5: q = kscm__cdr(kscm, p);
|
||
|
|
if (q && !kscm__ismark(kscm, q)) {
|
||
|
|
kscm__cdr(kscm, p) = t;
|
||
|
|
t = p;
|
||
|
|
p = q;
|
||
|
|
goto E2;
|
||
|
|
}
|
||
|
|
/* E6: This object is now fully marked. If there's no previous object, we can just return. Otherwise,
|
||
|
|
* we reload the previous object (and set the new previous to the one stored in "car" or equivalent),
|
||
|
|
* and continue marking it's subreferences.
|
||
|
|
*/
|
||
|
|
E6: if (!t)
|
||
|
|
return;
|
||
|
|
q = t;
|
||
|
|
if (kscm__isatom(kscm, q)) {
|
||
|
|
kscm__clratom(kscm, q);
|
||
|
|
t = kscm__car(kscm, q);
|
||
|
|
kscm__car(kscm, q) = p;
|
||
|
|
p = q;
|
||
|
|
goto E5;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
t = kscm__cdr(kscm, q);
|
||
|
|
kscm__cdr(kscm, q) = p;
|
||
|
|
p = q;
|
||
|
|
goto E6;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
|
||
|
|
/* garbage collection. parameter a, b is marked. */
|
||
|
|
void kscm__gc(kscm_t* kscm, /*register*/ kscm_object_t a, /*register*/ kscm_object_t b)
|
||
|
|
{
|
||
|
|
/*register*/ kscm_object_t p;
|
||
|
|
/*register*/ short i;
|
||
|
|
/*register*/ long j;
|
||
|
|
|
||
|
|
if (kscm->gc_verbose)
|
||
|
|
printf("gc...");
|
||
|
|
|
||
|
|
/* mark system globals */
|
||
|
|
kscm__mark(kscm, kscm->oblist);
|
||
|
|
kscm__mark(kscm, kscm->global_env);
|
||
|
|
|
||
|
|
/* mark current registers */
|
||
|
|
kscm__mark(kscm, kscm->args);
|
||
|
|
kscm__mark(kscm, kscm->envir);
|
||
|
|
kscm__mark(kscm, kscm->code);
|
||
|
|
kscm__mark(kscm, kscm->dump);
|
||
|
|
|
||
|
|
/* mark thread values (this implementation is single-threaded but we keep them anyway) */
|
||
|
|
kscm__mark(kscm, kscm->_threadname);
|
||
|
|
kscm__mark(kscm, kscm->_threadopts);
|
||
|
|
kscm__mark(kscm, kscm->_threadobject);
|
||
|
|
|
||
|
|
/* mark variables a, b */
|
||
|
|
kscm__mark(kscm, a);
|
||
|
|
kscm__mark(kscm, b);
|
||
|
|
|
||
|
|
/* garbage collect */
|
||
|
|
kscm__clrmark(kscm, kscm->NIL);
|
||
|
|
kscm->fcells = 0;
|
||
|
|
kscm->free_cell = kscm->NIL;
|
||
|
|
for (i = 0; i <= kscm->last_cell_seg; i++) {
|
||
|
|
j = 0;
|
||
|
|
for (/*j = 0,*/ p = kscm->cell_seg[i]; j < KSCM_CONFIG_CELL_SEGSIZE; j++/*, p++*/) {
|
||
|
|
if (kscm__ismark(kscm, p))
|
||
|
|
kscm__clrmark(kscm, p);
|
||
|
|
else {
|
||
|
|
if (kscm__isstring(kscm, p)) {
|
||
|
|
if (p->_object._string._svalue != NULL) {
|
||
|
|
free(p->_object._string._svalue);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
if (kscm__isbuffer(kscm, p)) {
|
||
|
|
if (p->_object._buffer._data != NULL) {
|
||
|
|
//fprintf(stderr, "Freeing a buffer of %d length\n", p->_object._buffer._length);
|
||
|
|
free(p->_object._buffer._data);
|
||
|
|
p->_object._buffer._data = NULL;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
if (kscm__isobjx(kscm, p)) {
|
||
|
|
if (p->_object._objx._elements != NULL) {
|
||
|
|
free(p->_object._objx._elements);
|
||
|
|
p->_object._objx._elements = NULL;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
// TODO: Should probably clear the whole structure before setting defaults or adding to free list
|
||
|
|
// (this could help avoid bugs if larger-than-pair structures aren't cleared or reset properly elsewhere)
|
||
|
|
kscm__type(kscm, p) = 0;
|
||
|
|
kscm__cdr(kscm, p) = kscm->free_cell;
|
||
|
|
kscm__car(kscm, p) = kscm->NIL;
|
||
|
|
kscm->free_cell = p;
|
||
|
|
kscm->fcells++;
|
||
|
|
}
|
||
|
|
p = p + 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
if (kscm->gc_verbose)
|
||
|
|
printf(" done %ld cells are recovered.\n", kscm->fcells);
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
/* ========== Rootines for Reading ========== */
|
||
|
|
|
||
|
|
/* get new character from input file */
|
||
|
|
int kscm__inchar(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
if (kscm->currentline >= kscm->endline) { /* input buffer is empty */
|
||
|
|
if (feof(kscm->inputs[kscm->inputtop])) {
|
||
|
|
fclose(kscm->inputs[kscm->inputtop]);
|
||
|
|
if (kscm->inputtop > 0) { // return to outer input
|
||
|
|
kscm->inputs[kscm->inputtop] = NULL;
|
||
|
|
kscm->inputtop--;
|
||
|
|
if (kscm->inputs[kscm->inputtop] == stdin) {
|
||
|
|
if (!kscm->quiet)
|
||
|
|
{printf(KSCM_CONFIG_PROMPT);fflush(stdout);}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else { // go back to the top-level
|
||
|
|
kscm->inputs[kscm->inputtop] = stdin;
|
||
|
|
if (!kscm->quiet)
|
||
|
|
{printf(KSCM_CONFIG_PROMPT);fflush(stdout);}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
strcpy(kscm->linebuff, "\n"); // TODO: Why's this here? -Zak.
|
||
|
|
if (fgets(kscm->currentline = kscm->linebuff, LINESIZE, kscm->inputs[kscm->inputtop]) == NULL)
|
||
|
|
if (kscm->inputs[kscm->inputtop] == stdin) {
|
||
|
|
if (!kscm->quiet)
|
||
|
|
fprintf(stderr, "Good-bye\n");
|
||
|
|
exit(0);
|
||
|
|
}
|
||
|
|
kscm->endline = kscm->linebuff + strlen(kscm->linebuff);
|
||
|
|
}
|
||
|
|
return (*kscm->currentline++);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* clear input buffer */
|
||
|
|
void kscm__clearinput(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
kscm->currentline = kscm->endline = kscm->linebuff;
|
||
|
|
}
|
||
|
|
|
||
|
|
/* back to standard input */
|
||
|
|
void kscm__resetinput(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
/*if (kscm->inputs[kscm->inputtop] != stdin) {
|
||
|
|
fclose(kscm->inputs[kscm->inputtop]);
|
||
|
|
kscm->inputs[kscm->inputtop] = stdin;
|
||
|
|
}*/
|
||
|
|
while (kscm->inputtop > 0 || kscm->inputs[kscm->inputtop] != stdin) {
|
||
|
|
fclose(kscm->inputs[kscm->inputtop]);
|
||
|
|
if (kscm->inputtop > 0) { // return to outer input
|
||
|
|
kscm->inputs[kscm->inputtop] = NULL;
|
||
|
|
kscm->inputtop--;
|
||
|
|
}
|
||
|
|
else { // go back to the top-level
|
||
|
|
kscm->inputs[kscm->inputtop] = stdin;
|
||
|
|
if (!kscm->quiet)
|
||
|
|
{printf(KSCM_CONFIG_PROMPT);fflush(stdout);}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
kscm__clearinput(kscm);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* back character to input buffer */
|
||
|
|
void kscm__backchar(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
kscm->currentline--;
|
||
|
|
}
|
||
|
|
|
||
|
|
int kscm__isdelim(kscm_t* kscm, const char* s, char c);
|
||
|
|
|
||
|
|
/* read chacters to delimiter */
|
||
|
|
char* kscm__readstr(kscm_t* kscm, const char *delim)
|
||
|
|
{
|
||
|
|
char* p = kscm->strbuff;
|
||
|
|
|
||
|
|
while (kscm__isdelim(kscm, delim, (*p++ = kscm__inchar(kscm))))
|
||
|
|
;
|
||
|
|
kscm__backchar(kscm);
|
||
|
|
*--p = '\0';
|
||
|
|
return (kscm->strbuff);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* read string expression "xxx...xxx" */
|
||
|
|
char* kscm__readstrexp(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
char c, * p = kscm->strbuff;
|
||
|
|
|
||
|
|
for (;;) {
|
||
|
|
if ((c = kscm__inchar(kscm)) != '"')
|
||
|
|
*p++ = c;
|
||
|
|
else if (p > kscm->strbuff&&* (p - 1) == '\\')
|
||
|
|
*(p - 1) = '"';
|
||
|
|
else {
|
||
|
|
*p = '\0';
|
||
|
|
return (kscm->strbuff);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* check c is delimiter */
|
||
|
|
int kscm__isdelim(kscm_t* kscm, const char *s, char c)
|
||
|
|
{
|
||
|
|
while (*s)
|
||
|
|
if (*s++ == c)
|
||
|
|
return (0);
|
||
|
|
return (1);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* skip white characters */
|
||
|
|
void kscm__skipspace(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
while (isspace(kscm__inchar(kscm)))
|
||
|
|
;
|
||
|
|
kscm__backchar(kscm);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* get token */
|
||
|
|
int kscm__token(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
kscm__skipspace(kscm);
|
||
|
|
switch (kscm__inchar(kscm)) {
|
||
|
|
case '(':
|
||
|
|
return (KSCM_TOK_LPAREN);
|
||
|
|
case ')':
|
||
|
|
return (KSCM_TOK_RPAREN);
|
||
|
|
case '.':
|
||
|
|
return (KSCM_TOK_DOT);
|
||
|
|
case '\'':
|
||
|
|
return (KSCM_TOK_QUOTE);
|
||
|
|
case ';':
|
||
|
|
return (KSCM_TOK_COMMENT);
|
||
|
|
case '"':
|
||
|
|
return (KSCM_TOK_DQUOTE);
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
case BACKQUOTE:
|
||
|
|
return (KSCM_TOK_BQUOTE);
|
||
|
|
case ',':
|
||
|
|
if (kscm__inchar(kscm) == '@')
|
||
|
|
return (KSCM_TOK_ATMARK);
|
||
|
|
else {
|
||
|
|
kscm__backchar(kscm);
|
||
|
|
return (KSCM_TOK_COMMA);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
case '#':
|
||
|
|
return (KSCM_TOK_SHARP);
|
||
|
|
default:
|
||
|
|
kscm__backchar(kscm);
|
||
|
|
return (KSCM_TOK_ATOM);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* ========== Rootines for Printing ========== */
|
||
|
|
#define kscm__ok_abbrev(kscm,x) (kscm__ispair(kscm, x) && kscm__cdr(kscm, x) == kscm->NIL)
|
||
|
|
|
||
|
|
void kscm__strunquote(kscm_t* kscm, char *p, const char *s)
|
||
|
|
{
|
||
|
|
*p++ = '"';
|
||
|
|
for (; *s; ++s) {
|
||
|
|
if (*s == '"') {
|
||
|
|
*p++ = '\\';
|
||
|
|
*p++ = '"';
|
||
|
|
}
|
||
|
|
else if (*s == '\n') {
|
||
|
|
*p++ = '\\';
|
||
|
|
*p++ = 'n';
|
||
|
|
}
|
||
|
|
else
|
||
|
|
*p++ = *s;
|
||
|
|
}
|
||
|
|
*p++ = '"';
|
||
|
|
*p = '\0';
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
/* print atoms */
|
||
|
|
int kscm__printatom(kscm_t* kscm, kscm_object_t l, int f)
|
||
|
|
{
|
||
|
|
char *p = NULL;
|
||
|
|
|
||
|
|
if (l == kscm->NIL)
|
||
|
|
p = (char*)(void*)"()";
|
||
|
|
else if (l == kscm->T)
|
||
|
|
p = (char*)(void*)"#t";
|
||
|
|
else if (l == kscm->F)
|
||
|
|
p = (char*)(void*)"#f";
|
||
|
|
else if (kscm__isnumber(kscm, l)) {
|
||
|
|
p = kscm->strbuff;
|
||
|
|
sprintf(p, "%ld", kscm__ivalue(kscm, l));
|
||
|
|
}
|
||
|
|
else if (kscm__isfloat64(kscm, l)) {
|
||
|
|
p = kscm->strbuff;
|
||
|
|
sprintf(p, "%f", l->_object._float64._dvalue);
|
||
|
|
}
|
||
|
|
else if (kscm__isstring(kscm, l)) {
|
||
|
|
if (!f)
|
||
|
|
p = kscm__strvalue(kscm, l);
|
||
|
|
else {
|
||
|
|
p = kscm->strbuff;
|
||
|
|
kscm__strunquote(kscm, p, kscm__strvalue(kscm, l));
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else if (kscm__issymbol(kscm, l))
|
||
|
|
p = kscm__symname(kscm, l);
|
||
|
|
else if (kscm__isproc(kscm, l)) {
|
||
|
|
p = kscm->strbuff;
|
||
|
|
sprintf(p, "#<PROCEDURE %ld>", kscm__procnum(kscm, l));
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
}
|
||
|
|
else if (kscm__ismacro(kscm, l)) {
|
||
|
|
p = (char*)(void*)"#<MACRO>";
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
}
|
||
|
|
else if (kscm__isbuffer(kscm, l)) {
|
||
|
|
p = (char*)(void*)"#<BUFFER>";
|
||
|
|
}
|
||
|
|
else if (kscm__isabstraction(kscm, l)) {
|
||
|
|
p = (char*)(void*)"#<ABSTRACTION>";
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
}
|
||
|
|
else if (kscm__isobjx(kscm, l)) {
|
||
|
|
p = (char*)(void*)"#<OBJECT>";
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
else if (kscm__isclosure(kscm, l))
|
||
|
|
p = (char*)(void*)"#<CLOSURE>";
|
||
|
|
else if (kscm__iscontinuation(kscm, l))
|
||
|
|
p = (char*)(void*)"#<CONTINUATION>";
|
||
|
|
if (f < 0)
|
||
|
|
return strlen(p);
|
||
|
|
fputs(p, kscm->outfp);
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
/* ========== Rootines for Evaluation Cycle ========== */
|
||
|
|
|
||
|
|
/* make closure. c is code. e is environment */
|
||
|
|
kscm_object_t kscm__mk_closure(kscm_t* kscm, register kscm_object_t c, register kscm_object_t e)
|
||
|
|
{
|
||
|
|
register kscm_object_t x = kscm__get_cell(kscm, c, e);
|
||
|
|
|
||
|
|
kscm__type(kscm, x) = KSCM_T_CLOSURE;
|
||
|
|
kscm__car(kscm, x) = c;
|
||
|
|
kscm__cdr(kscm, x) = e;
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* make continuation. */
|
||
|
|
kscm_object_t kscm__mk_continuation(kscm_t* kscm, register kscm_object_t d)
|
||
|
|
{
|
||
|
|
register kscm_object_t x = kscm__get_cell(kscm, kscm->NIL, d);
|
||
|
|
|
||
|
|
kscm__type(kscm, x) = KSCM_T_CONTINUATION;
|
||
|
|
kscm__cont_dump(kscm, x) = d;
|
||
|
|
return (x);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* reverse list -- make new cells */
|
||
|
|
kscm_object_t kscm__reverse(kscm_t* kscm, register kscm_object_t a) /* a must be checked by gc */
|
||
|
|
{
|
||
|
|
register kscm_object_t p = kscm->NIL;
|
||
|
|
|
||
|
|
for (; kscm__ispair(kscm, a); a = kscm__cdr(kscm, a))
|
||
|
|
p = kscm__cons(kscm, kscm__car(kscm, a), p);
|
||
|
|
return (p);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* reverse list --- no make new cells */
|
||
|
|
kscm_object_t kscm__non_alloc_rev(kscm_t* kscm, kscm_object_t term, kscm_object_t list)
|
||
|
|
{
|
||
|
|
register kscm_object_t p = list, result = term, q;
|
||
|
|
|
||
|
|
while (p != kscm->NIL) {
|
||
|
|
q = kscm__cdr(kscm, p);
|
||
|
|
kscm__cdr(kscm, p) = result;
|
||
|
|
result = p;
|
||
|
|
p = q;
|
||
|
|
}
|
||
|
|
return (result);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* append list -- make new cells */
|
||
|
|
kscm_object_t kscm__append(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b)
|
||
|
|
{
|
||
|
|
register kscm_object_t p = b, q;
|
||
|
|
|
||
|
|
if (a != kscm->NIL) {
|
||
|
|
a = kscm__reverse(kscm, a);
|
||
|
|
while (a != kscm->NIL) {
|
||
|
|
q = kscm__cdr(kscm, a);
|
||
|
|
kscm__cdr(kscm, a) = p;
|
||
|
|
p = a;
|
||
|
|
a = q;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return (p);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* equivalence of atoms */
|
||
|
|
int kscm__eqv(kscm_t* kscm, register kscm_object_t a, register kscm_object_t b)
|
||
|
|
{
|
||
|
|
if (kscm__isstring(kscm, a)) {
|
||
|
|
if (kscm__isstring(kscm, b))
|
||
|
|
return (!strcmp(kscm__strvalue(kscm, a), kscm__strvalue(kscm, b)));
|
||
|
|
else
|
||
|
|
return (0);
|
||
|
|
}
|
||
|
|
else if (kscm__isnumber(kscm, a)) {
|
||
|
|
if (kscm__isnumber(kscm, b))
|
||
|
|
return (kscm__ivalue(kscm, a) == kscm__ivalue(kscm, b));
|
||
|
|
else
|
||
|
|
return (0);
|
||
|
|
}
|
||
|
|
else
|
||
|
|
return (a == b);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* true or false value macro */
|
||
|
|
#define kscm__istrue(kscm,p) ((p) != kscm->NIL && (p) != kscm->F)
|
||
|
|
#define kscm__isfalse(kscm,p) ((p) == kscm->NIL || (p) == kscm->F)
|
||
|
|
|
||
|
|
/* Error macro */
|
||
|
|
#ifdef KSCM_CONFIG_AVOID_HACK_LOOP
|
||
|
|
# define KSCM__BEGIN {
|
||
|
|
# define KSCM__END }
|
||
|
|
#else
|
||
|
|
/*
|
||
|
|
* I believe this is better, but some compiler complains....
|
||
|
|
*/
|
||
|
|
# define KSCM__BEGIN do {
|
||
|
|
# define KSCM__END } while (0)
|
||
|
|
#endif
|
||
|
|
|
||
|
|
#define kscm__error_0(kscm,s) KSCM__BEGIN \
|
||
|
|
kscm->args = kscm__cons(kscm, kscm__mk_string(kscm, (s)), kscm->NIL); \
|
||
|
|
kscm->_operator = (short)KSCM_OP_ERR0; \
|
||
|
|
return kscm->T; KSCM__END
|
||
|
|
|
||
|
|
#define kscm__error_1(kscm,s, a) KSCM__BEGIN \
|
||
|
|
kscm->args = kscm__cons(kscm, (a), kscm->NIL); \
|
||
|
|
kscm->args = kscm__cons(kscm, kscm__mk_string(kscm, (s)), kscm->args); \
|
||
|
|
kscm->_operator = (short)KSCM_OP_ERR0; \
|
||
|
|
return kscm->T; KSCM__END
|
||
|
|
|
||
|
|
/* control macros for Eval_Cycle */
|
||
|
|
#define kscm__s_goto(kscm,a) KSCM__BEGIN \
|
||
|
|
kscm->_operator = (short)(a); \
|
||
|
|
return kscm->T; KSCM__END
|
||
|
|
|
||
|
|
#define kscm__s_save(kscm,a, b, c) do{ \
|
||
|
|
kscm->dump = kscm__cons(kscm, kscm->envir, kscm__cons(kscm, (c), kscm->dump)); \
|
||
|
|
kscm->dump = kscm__cons(kscm, (b), kscm->dump); \
|
||
|
|
kscm->dump = kscm__cons(kscm, kscm__mk_number(kscm, (long)(a)), kscm->dump);}while(0)
|
||
|
|
|
||
|
|
|
||
|
|
#define kscm__s_return(kscm,a) KSCM__BEGIN \
|
||
|
|
kscm->value = (a); \
|
||
|
|
kscm->_operator = kscm__ivalue(kscm, kscm__car(kscm, kscm->dump)); \
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->dump); \
|
||
|
|
kscm->envir = kscm__caddr(kscm, kscm->dump); \
|
||
|
|
kscm->code = kscm__cadddr(kscm, kscm->dump); \
|
||
|
|
kscm->dump = kscm__cddddr(kscm, kscm->dump); \
|
||
|
|
return kscm->T; KSCM__END
|
||
|
|
|
||
|
|
#define kscm__s_retbool(kscm,tf) kscm__s_return(kscm, (tf) ? kscm->T : kscm->F)
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_0(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x;
|
||
|
|
register kscm_object_t y = NULL;
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_LOAD: /* load */
|
||
|
|
if (!kscm__isstring(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__error_0(kscm, "load -- argument is not string");
|
||
|
|
}
|
||
|
|
if (kscm->inputtop + 1 >= KSCM_CONFIG_MAXLOADS) {
|
||
|
|
kscm__error_0(kscm, "load -- depth of loaded files has reached the KSCM_CONFIG_MAXLOADS value");
|
||
|
|
}
|
||
|
|
if ((kscm->inputs[kscm->inputtop + 1] = fopen(kscm__strvalue(kscm, kscm__car(kscm, kscm->args)), "r")) == NULL) {
|
||
|
|
//kscm->inputs[kscm->inputtop] = stdin;
|
||
|
|
kscm__error_1(kscm, "Unable to open", kscm__car(kscm, kscm->args));
|
||
|
|
}
|
||
|
|
kscm->inputtop++;
|
||
|
|
if (!kscm->quiet)
|
||
|
|
fprintf(kscm->outfp, "loading %s", kscm__strvalue(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_T0LVL);
|
||
|
|
|
||
|
|
case KSCM_OP_T0LVL: /* top level */
|
||
|
|
if (!kscm->quiet)
|
||
|
|
fprintf(kscm->outfp, "\n");
|
||
|
|
kscm->dump = kscm->NIL;
|
||
|
|
kscm->envir = kscm->global_env;
|
||
|
|
kscm__s_save(kscm, KSCM_OP_VALUEPRINT, kscm->NIL, kscm->NIL);
|
||
|
|
kscm__s_save(kscm, KSCM_OP_T1LVL, kscm->NIL, kscm->NIL);
|
||
|
|
if (kscm->inputs[kscm->inputtop] == stdin && !kscm->quiet)
|
||
|
|
{printf(KSCM_CONFIG_PROMPT);fflush(stdout);}
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_READ);
|
||
|
|
|
||
|
|
case KSCM_OP_T1LVL: /* top level */
|
||
|
|
kscm->code = kscm->value;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_READ: /* read */
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
|
||
|
|
case KSCM_OP_VALUEPRINT: /* print evalution result */
|
||
|
|
kscm->print_flag = 1;
|
||
|
|
kscm->args = kscm->value;
|
||
|
|
if (kscm->quiet) {
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_T0LVL);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_T0LVL, kscm->NIL, kscm->NIL);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_EVAL: /* main part of evalution */
|
||
|
|
if (kscm__issymbol(kscm, kscm->code)) { /* symbol */
|
||
|
|
for (x = kscm->envir; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
for (y = kscm__car(kscm, x); y != kscm->NIL; y = kscm__cdr(kscm, y))
|
||
|
|
if (kscm__caar(kscm, y) == kscm->code)
|
||
|
|
break;
|
||
|
|
if (y != kscm->NIL)
|
||
|
|
break;
|
||
|
|
}
|
||
|
|
if (x != kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm__cdar(kscm, y));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_1(kscm, "Unbounded variable", kscm->code);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else if (kscm__ispair(kscm, kscm->code)) {
|
||
|
|
if (kscm__issyntax(kscm, x = kscm__car(kscm, kscm->code))) { /* SYNTAX */
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, kscm__syntaxnum(kscm, x));
|
||
|
|
}
|
||
|
|
else {/* first, eval top element and eval arguments */
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
kscm__s_save(kscm, KSCM_OP_E0ARGS, kscm->NIL, kscm->code);
|
||
|
|
#else
|
||
|
|
s_save(kscm, KSCM_OP_E1ARGS, kscm->NIL, cdr(code));
|
||
|
|
#endif
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->code);
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
case KSCM_OP_E0ARGS: /* eval arguments */
|
||
|
|
if (kscm__ismacro(kscm, kscm->value)) { /* macro expansion */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_DOMACRO, kscm->NIL, kscm->NIL);
|
||
|
|
kscm->args = kscm__cons(kscm, kscm->code, kscm->NIL);
|
||
|
|
kscm->code = kscm->value;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_APPLY);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_E1ARGS);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
case KSCM_OP_E1ARGS: /* eval arguments */
|
||
|
|
kscm->args = kscm__cons(kscm, kscm->value, kscm->args);
|
||
|
|
if (kscm__ispair(kscm, kscm->code)) { /* continue */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_E1ARGS, kscm->args, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
else { /* end */
|
||
|
|
kscm->args = kscm__reverse(kscm, kscm->args);
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->args = kscm__cdr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_APPLY);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_APPLY: /* apply 'code' to 'args' */
|
||
|
|
if (kscm__isproc(kscm, kscm->code)) {
|
||
|
|
kscm__s_goto(kscm, kscm__procnum(kscm, kscm->code)); /* PROCEDURE */
|
||
|
|
}
|
||
|
|
else if (kscm__isclosure(kscm, kscm->code)) { /* CLOSURE */
|
||
|
|
/* make environment */
|
||
|
|
kscm->envir = kscm__cons(kscm, kscm->NIL, kscm__closure_env(kscm, kscm->code));
|
||
|
|
y = kscm->args;
|
||
|
|
for (x = kscm__car(kscm, kscm__closure_code(kscm, kscm->code))/*, y = kscm->args*/;
|
||
|
|
kscm__ispair(kscm, x); x = kscm__cdr(kscm, x)/*, y = kscm__cdr(kscm, y)*/) {
|
||
|
|
if (y == kscm->NIL) {
|
||
|
|
kscm__error_0(kscm, "Few arguments");
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__car(kscm, x), kscm__car(kscm, y)), kscm__car(kscm, kscm->envir));
|
||
|
|
}
|
||
|
|
y = kscm__cdr(kscm, y);
|
||
|
|
}
|
||
|
|
if (x == kscm->NIL) {
|
||
|
|
/*--
|
||
|
|
* if (y != kscm->NIL) {
|
||
|
|
* Error_0("Many arguments");
|
||
|
|
* }
|
||
|
|
*/
|
||
|
|
}
|
||
|
|
else if (kscm__issymbol(kscm, x))
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, x, y), kscm__car(kscm, kscm->envir));
|
||
|
|
else {
|
||
|
|
kscm__error_0(kscm, "Syntax error in closure");
|
||
|
|
}
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm__closure_code(kscm, kscm->code));
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
}
|
||
|
|
else if (kscm__iscontinuation(kscm, kscm->code)) { /* CONTINUATION */
|
||
|
|
kscm->dump = kscm__cont_dump(kscm, kscm->code);
|
||
|
|
kscm__s_return(kscm, kscm->args != kscm->NIL ? kscm__car(kscm, kscm->args) : kscm->NIL);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_0(kscm, "Illegal function");
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
case KSCM_OP_DOMACRO: /* do macro */
|
||
|
|
kscm->code = kscm->value;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
#endif
|
||
|
|
|
||
|
|
case KSCM_OP_LAMBDA: /* lambda */
|
||
|
|
kscm__s_return(kscm, kscm__mk_closure(kscm, kscm->code, kscm->envir));
|
||
|
|
|
||
|
|
case KSCM_OP_QUOTE: /* quote */
|
||
|
|
kscm__s_return(kscm, kscm__car(kscm, kscm->code));
|
||
|
|
|
||
|
|
case KSCM_OP_DEF0: /* define */
|
||
|
|
if (kscm__ispair(kscm, kscm__car(kscm, kscm->code))) {
|
||
|
|
x = kscm__caar(kscm, kscm->code);
|
||
|
|
kscm->code = kscm__cons(kscm, kscm->LAMBDA, kscm__cons(kscm, kscm__cdar(kscm, kscm->code), kscm__cdr(kscm, kscm->code)));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
x = kscm__car(kscm, kscm->code);
|
||
|
|
kscm->code = kscm__cadr(kscm, kscm->code);
|
||
|
|
}
|
||
|
|
if (!kscm__issymbol(kscm, x)) {
|
||
|
|
kscm__error_0(kscm, "Variable is not symbol");
|
||
|
|
}
|
||
|
|
kscm__s_save(kscm, KSCM_OP_DEF1, kscm->NIL, x);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_DEF1: /* define */
|
||
|
|
for (x = kscm__car(kscm, kscm->envir); x != kscm->NIL; x = kscm__cdr(kscm, x))
|
||
|
|
if (kscm__caar(kscm, x) == kscm->code)
|
||
|
|
break;
|
||
|
|
if (x != kscm->NIL)
|
||
|
|
kscm__cdar(kscm, x) = kscm->value;
|
||
|
|
else
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm->code, kscm->value), kscm__car(kscm, kscm->envir));
|
||
|
|
kscm__s_return(kscm, kscm->code);
|
||
|
|
|
||
|
|
case KSCM_OP_SET0: /* set! */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_SET1, kscm->NIL, kscm__car(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__cadr(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_SET1: /* set! */
|
||
|
|
for (x = kscm->envir; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
for (y = kscm__car(kscm, x); y != kscm->NIL; y = kscm__cdr(kscm, y))
|
||
|
|
if (kscm__caar(kscm, y) == kscm->code)
|
||
|
|
break;
|
||
|
|
if (y != kscm->NIL)
|
||
|
|
break;
|
||
|
|
}
|
||
|
|
if (x != kscm->NIL) {
|
||
|
|
kscm__cdar(kscm, y) = kscm->value;
|
||
|
|
kscm__s_return(kscm, kscm->value);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_1(kscm, "Unbounded variable", kscm->code);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_BEGIN: /* begin */
|
||
|
|
if (!kscm__ispair(kscm, kscm->code)) {
|
||
|
|
kscm__s_return(kscm, kscm->code);
|
||
|
|
}
|
||
|
|
if (kscm__cdr(kscm, kscm->code) != kscm->NIL) {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_BEGIN, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
}
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_IF0: /* if */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_IF1, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_IF1: /* if */
|
||
|
|
if (kscm__istrue(kscm, kscm->value))
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
else
|
||
|
|
kscm->code = kscm__cadr(kscm, kscm->code); /* (if #f 1) ==> () because
|
||
|
|
* car(kscm->NIL) = kscm->NIL */
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_LET0: /* let */
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm->value = kscm->code;
|
||
|
|
kscm->code = kscm__issymbol(kscm, kscm__car(kscm, kscm->code)) ? kscm__cadr(kscm, kscm->code) : kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_LET1);
|
||
|
|
|
||
|
|
case KSCM_OP_LET1: /* let (caluculate parameters) */
|
||
|
|
kscm->args = kscm__cons(kscm, kscm->value, kscm->args);
|
||
|
|
if (kscm__ispair(kscm, kscm->code)) { /* continue */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_LET1, kscm->args, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__cadar(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
else { /* end */
|
||
|
|
kscm->args = kscm__reverse(kscm, kscm->args);
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->args = kscm__cdr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_LET2);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_LET2: /* let */
|
||
|
|
kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir);
|
||
|
|
y = kscm->args;
|
||
|
|
for (x = kscm__issymbol(kscm, kscm__car(kscm, kscm->code)) ? kscm__cadr(kscm, kscm->code) : kscm__car(kscm, kscm->code)/*, y = kscm->args*/;
|
||
|
|
y != kscm->NIL; x = kscm__cdr(kscm, x)/*, y = kscm__cdr(kscm, y)*/)
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__caar(kscm, x), kscm__car(kscm, y)), kscm__car(kscm, kscm->envir));
|
||
|
|
y = kscm__cdr(kscm, y);
|
||
|
|
if (kscm__issymbol(kscm, kscm__car(kscm, kscm->code))) { /* named let */
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
for (x = kscm__cadr(kscm, kscm->code) /*, kscm->args = kscm->NIL*/; x != kscm->NIL; x = kscm__cdr(kscm, x))
|
||
|
|
kscm->args = kscm__cons(kscm, kscm__caar(kscm, x), kscm->args);
|
||
|
|
x = kscm__mk_closure(kscm, kscm__cons(kscm, kscm__reverse(kscm, kscm->args), kscm__cddr(kscm, kscm->code)), kscm->envir);
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__car(kscm, kscm->code), x), kscm__car(kscm, kscm->envir));
|
||
|
|
kscm->code = kscm__cddr(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
}
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
|
||
|
|
case KSCM_OP_LET0AST: /* let* */
|
||
|
|
if (kscm__car(kscm, kscm->code) == kscm->NIL) {
|
||
|
|
kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir);
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
}
|
||
|
|
kscm__s_save(kscm, KSCM_OP_LET1AST, kscm__cdr(kscm, kscm->code), kscm__car(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__cadaar(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_LET1AST: /* let* (make new frame) */
|
||
|
|
kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_LET2AST);
|
||
|
|
|
||
|
|
case KSCM_OP_LET2AST: /* let* (caluculate parameters) */
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__caar(kscm, kscm->code), kscm->value), kscm__car(kscm, kscm->envir));
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm->code);
|
||
|
|
if (kscm__ispair(kscm, kscm->code)) { /* continue */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_LET2AST, kscm->args, kscm->code);
|
||
|
|
kscm->code = kscm__cadar(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
else { /* end */
|
||
|
|
kscm->code = kscm->args;
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
}
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_1(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y;
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_LET0REC: /* letrec */
|
||
|
|
kscm->envir = kscm__cons(kscm, kscm->NIL, kscm->envir);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm->value = kscm->code;
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_LET1REC);
|
||
|
|
|
||
|
|
case KSCM_OP_LET1REC: /* letrec (caluculate parameters) */
|
||
|
|
kscm->args = kscm__cons(kscm, kscm->value, kscm->args);
|
||
|
|
if (kscm__ispair(kscm, kscm->code)) { /* continue */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_LET1REC, kscm->args, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__cadar(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
else { /* end */
|
||
|
|
kscm->args = kscm__reverse(kscm, kscm->args);
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->args = kscm__cdr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_LET2REC);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_LET2REC: /* letrec */
|
||
|
|
y = kscm->args;
|
||
|
|
for (x = kscm__car(kscm, kscm->code)/*, y = kscm->args*/; y != kscm->NIL; x = kscm__cdr(kscm, x)/*, y = kscm__cdr(kscm, y)*/) {
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm__caar(kscm, x), kscm__car(kscm, y)), kscm__car(kscm, kscm->envir));
|
||
|
|
y = kscm__cdr(kscm, y);
|
||
|
|
}
|
||
|
|
kscm->code = kscm__cdr(kscm, kscm->code);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
|
||
|
|
case KSCM_OP_COND0: /* cond */
|
||
|
|
if (!kscm__ispair(kscm, kscm->code)) {
|
||
|
|
kscm__error_0(kscm, "Syntax error in cond");
|
||
|
|
}
|
||
|
|
kscm__s_save(kscm, KSCM_OP_COND1, kscm->NIL, kscm->code);
|
||
|
|
kscm->code = kscm__caar(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_COND1: /* cond */
|
||
|
|
if (kscm__istrue(kscm, kscm->value)) {
|
||
|
|
if ((kscm->code = kscm__cdar(kscm, kscm->code)) == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->value);
|
||
|
|
}
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
if ((kscm->code = kscm__cdr(kscm, kscm->code)) == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_COND1, kscm->NIL, kscm->code);
|
||
|
|
kscm->code = kscm__caar(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_DELAY: /* delay */
|
||
|
|
x = kscm__mk_closure(kscm, kscm__cons(kscm, kscm->NIL, kscm->code), kscm->envir);
|
||
|
|
kscm__setpromise(kscm, x);
|
||
|
|
kscm__s_return(kscm, x);
|
||
|
|
|
||
|
|
case KSCM_OP_AND0: /* and */
|
||
|
|
if (kscm->code == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
}
|
||
|
|
kscm__s_save(kscm, KSCM_OP_AND1, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_AND1: /* and */
|
||
|
|
if (kscm__isfalse(kscm, kscm->value)) {
|
||
|
|
kscm__s_return(kscm, kscm->value);
|
||
|
|
}
|
||
|
|
else if (kscm->code == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->value);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_AND1, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_OR0: /* or */
|
||
|
|
if (kscm->code == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_save(kscm, KSCM_OP_OR1, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_OR1: /* or */
|
||
|
|
if (kscm__istrue(kscm, kscm->value)) {
|
||
|
|
kscm__s_return(kscm, kscm->value);
|
||
|
|
}
|
||
|
|
else if (kscm->code == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->value);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_OR1, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_C0STREAM: /* cons-stream */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_C1STREAM, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_C1STREAM: /* cons-stream */
|
||
|
|
kscm->args = kscm->value; /* save value to register args for gc */
|
||
|
|
x = kscm__mk_closure(kscm, kscm__cons(kscm, kscm->NIL, kscm->code), kscm->envir);
|
||
|
|
kscm__setpromise(kscm, x);
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->args, x));
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
case KSCM_OP_0MACRO: /* macro */
|
||
|
|
x = kscm__car(kscm, kscm->code);
|
||
|
|
kscm->code = kscm__cadr(kscm, kscm->code);
|
||
|
|
if (!kscm__issymbol(kscm, x)) {
|
||
|
|
kscm__error_0(kscm, "Variable is not symbol");
|
||
|
|
}
|
||
|
|
kscm__s_save(kscm, KSCM_OP_1MACRO, kscm->NIL, x);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_1MACRO: /* macro */
|
||
|
|
kscm__type(kscm, kscm->value) |= KSCM_T_MACRO;
|
||
|
|
for (x = kscm__car(kscm, kscm->envir); x != kscm->NIL; x = kscm__cdr(kscm, x))
|
||
|
|
if (kscm__caar(kscm, x) == kscm->code)
|
||
|
|
break;
|
||
|
|
if (x != kscm->NIL)
|
||
|
|
kscm__cdar(kscm, x) = kscm->value;
|
||
|
|
else
|
||
|
|
kscm__car(kscm, kscm->envir) = kscm__cons(kscm, kscm__cons(kscm, kscm->code, kscm->value), kscm__car(kscm, kscm->envir));
|
||
|
|
kscm__s_return(kscm, kscm->code);
|
||
|
|
#endif
|
||
|
|
|
||
|
|
case KSCM_OP_CASE0: /* case */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_CASE1, kscm->NIL, kscm__cdr(kscm, kscm->code));
|
||
|
|
kscm->code = kscm__car(kscm, kscm->code);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_CASE1: /* case */
|
||
|
|
for (x = kscm->code; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
if (!kscm__ispair(kscm, y = kscm__caar(kscm, x)))
|
||
|
|
break;
|
||
|
|
for (; y != kscm->NIL; y = kscm__cdr(kscm, y))
|
||
|
|
if (kscm__eqv(kscm, kscm__car(kscm, y), kscm->value))
|
||
|
|
break;
|
||
|
|
if (y != kscm->NIL)
|
||
|
|
break;
|
||
|
|
}
|
||
|
|
if (x != kscm->NIL) {
|
||
|
|
if (kscm__ispair(kscm, kscm__caar(kscm, x))) {
|
||
|
|
kscm->code = kscm__cdar(kscm, x);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
}
|
||
|
|
else {/* else */
|
||
|
|
kscm__s_save(kscm, KSCM_OP_CASE2, kscm->NIL, kscm__cdar(kscm, x));
|
||
|
|
kscm->code = kscm__caar(kscm, x);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_CASE2: /* case */
|
||
|
|
if (kscm__istrue(kscm, kscm->value)) {
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_BEGIN);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
case KSCM_OP_PAPPLY: /* apply */
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_APPLY);
|
||
|
|
|
||
|
|
case KSCM_OP_PEVAL: /* eval */
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_EVAL);
|
||
|
|
|
||
|
|
case KSCM_OP_CONTINUATION: /* call-with-current-continuation */
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->args = kscm__cons(kscm, kscm__mk_continuation(kscm, kscm->dump), kscm->NIL);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_APPLY);
|
||
|
|
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_2(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y;
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
int32_t v;
|
||
|
|
#else
|
||
|
|
register long v;
|
||
|
|
#endif
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_ADD: /* + */
|
||
|
|
v = 0;
|
||
|
|
for (x = kscm->args/*, v = 0*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
if (!kscm__isnumber(kscm, kscm__car(kscm, x))) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
int64_t lv = ((int64_t)v) + ((int64_t)kscm__ivalue(kscm, kscm__car(kscm, x)));
|
||
|
|
v = (int32_t)lv;
|
||
|
|
if (((int64_t)v) != lv) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
v += kscm__ivalue(kscm, kscm__car(kscm, x));
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, v));
|
||
|
|
|
||
|
|
case KSCM_OP_SUB: /* - */
|
||
|
|
v = v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args));
|
||
|
|
for (x = kscm__cdr(kscm, kscm->args)/*, v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args))*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
if (!kscm__isnumber(kscm, kscm__car(kscm, x))) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
int64_t lv = ((int64_t)v) - ((int64_t)kscm__ivalue(kscm, kscm__car(kscm, x)));
|
||
|
|
v = (int32_t)lv;
|
||
|
|
if (((int64_t)v) != lv) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
v -= kscm__ivalue(kscm, kscm__car(kscm, x));
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, v));
|
||
|
|
|
||
|
|
case KSCM_OP_MUL: /* * */
|
||
|
|
v = 1;
|
||
|
|
for (x = kscm->args/*, v = 1*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
if (!kscm__isnumber(kscm, kscm__car(kscm, x))) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
int64_t lv = ((int64_t)v) * ((int64_t)kscm__ivalue(kscm, kscm__car(kscm, x)));
|
||
|
|
v = (int32_t)lv;
|
||
|
|
if (((int64_t)v) != lv) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
v *= kscm__ivalue(kscm, kscm__car(kscm, x));
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, v));
|
||
|
|
|
||
|
|
case KSCM_OP_DIV: /* / */
|
||
|
|
v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args));
|
||
|
|
for (x = kscm__cdr(kscm, kscm->args)/*, v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args))*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
if (!kscm__isnumber(kscm, kscm__car(kscm, x))) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
if (kscm__ivalue(kscm, kscm__car(kscm, x)) != 0)
|
||
|
|
v /= kscm__ivalue(kscm, kscm__car(kscm, x));
|
||
|
|
else {
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
#else
|
||
|
|
kscm__error_0(kscm, "Divided by zero");
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, v));
|
||
|
|
|
||
|
|
case KSCM_OP_REM: /* remainder */
|
||
|
|
v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args));
|
||
|
|
for (x = kscm__cdr(kscm, kscm->args)/*, v = kscm__ivalue(kscm, kscm__car(kscm, kscm->args))*/; x != kscm->NIL; x = kscm__cdr(kscm, x)) {
|
||
|
|
if (!kscm__isnumber(kscm, kscm__car(kscm, x))) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
if (kscm__ivalue(kscm, kscm__car(kscm, x)) != 0)
|
||
|
|
v %= kscm__ivalue(kscm, kscm__car(kscm, x));
|
||
|
|
else {
|
||
|
|
#ifdef KSCM_CONFIG_USE_PRECISE
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
#else
|
||
|
|
kscm__error_0(kscm, "Divided by zero");
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, v));
|
||
|
|
|
||
|
|
case KSCM_OP_CAR: /* car */
|
||
|
|
if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__s_return(kscm, kscm__caar(kscm, kscm->args));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_0(kscm, "Unable to car for non-cons cell");
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_CDR: /* cdr */
|
||
|
|
if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__s_return(kscm, kscm__cdar(kscm, kscm->args));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_0(kscm, "Unable to cdr for non-cons cell");
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_CONS: /* cons */
|
||
|
|
kscm__cdr(kscm, kscm->args) = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_return(kscm, kscm->args);
|
||
|
|
|
||
|
|
case KSCM_OP_SETCAR: /* set-car! */
|
||
|
|
if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__caar(kscm, kscm->args) = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_return(kscm, kscm__car(kscm, kscm->args));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_0(kscm, "Unable to set-car! for non-cons cell");
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_SETCDR: /* set-cdr! */
|
||
|
|
if (kscm__ispair(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__cdar(kscm, kscm->args) = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_return(kscm, kscm__car(kscm, kscm->args));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__error_0(kscm, "Unable to set-cdr! for non-cons cell");
|
||
|
|
}
|
||
|
|
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_3(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y;
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_NOT: /* not */
|
||
|
|
kscm__s_retbool(kscm, kscm__isfalse(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_BOOL: /* boolean? */
|
||
|
|
kscm__s_retbool(kscm, kscm__car(kscm, kscm->args) == kscm->F || kscm__car(kscm, kscm->args) == kscm->T);
|
||
|
|
case KSCM_OP_NULL: /* null? */
|
||
|
|
kscm__s_retbool(kscm, kscm__car(kscm, kscm->args) == kscm->NIL);
|
||
|
|
case KSCM_OP_ZEROP: /* zero? */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) == 0);
|
||
|
|
case KSCM_OP_POSP: /* positive? */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) > 0);
|
||
|
|
case KSCM_OP_NEGP: /* negative? */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) < 0);
|
||
|
|
case KSCM_OP_NEQ: /* = */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) == kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_LESS: /* < */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) < kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_GRE: /* > */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) > kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_LEQ: /* <= */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) <= kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_GEQ: /* >= */
|
||
|
|
kscm__s_retbool(kscm, kscm__ivalue(kscm, kscm__car(kscm, kscm->args)) >= kscm__ivalue(kscm, kscm__cadr(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_SYMBOL: /* symbol? */
|
||
|
|
kscm__s_retbool(kscm, kscm__issymbol(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_NUMBER: /* number? */
|
||
|
|
kscm__s_retbool(kscm, kscm__isnumber(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_STRING: /* string? */
|
||
|
|
kscm__s_retbool(kscm, kscm__isstring(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_PROC: /* procedure? */
|
||
|
|
/*--
|
||
|
|
* continuation should be procedure by the example
|
||
|
|
* (call-with-current-continuation procedure?) ==> #t
|
||
|
|
* in R^3 report sec. 6.9
|
||
|
|
*/
|
||
|
|
kscm__s_retbool(kscm, kscm__isproc(kscm, kscm__car(kscm, kscm->args)) || kscm__isclosure(kscm, kscm__car(kscm, kscm->args))
|
||
|
|
|| kscm__iscontinuation(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_PAIR: /* pair? */
|
||
|
|
kscm__s_retbool(kscm, kscm__ispair(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_EQ: /* eq? */
|
||
|
|
kscm__s_retbool(kscm, kscm__car(kscm, kscm->args) == kscm__cadr(kscm, kscm->args));
|
||
|
|
case KSCM_OP_EQV: /* eqv? */
|
||
|
|
kscm__s_retbool(kscm, kscm__eqv(kscm, kscm__car(kscm, kscm->args), kscm__cadr(kscm, kscm->args)));
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_4(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y;
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_FORCE: /* force */
|
||
|
|
kscm->code = kscm__car(kscm, kscm->args);
|
||
|
|
if (kscm__ispromise(kscm, kscm->code)) {
|
||
|
|
kscm->args = kscm->NIL;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_APPLY);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->code);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_WRITE: /* write */
|
||
|
|
kscm->print_flag = 1;
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
|
||
|
|
case KSCM_OP_DISPLAY: /* display */
|
||
|
|
kscm->print_flag = 0;
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
|
||
|
|
case KSCM_OP_NEWLINE: /* newline */
|
||
|
|
fprintf(kscm->outfp, "\n");
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
|
||
|
|
case KSCM_OP_ERR0: /* error */
|
||
|
|
if (!kscm__isstring(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__error_0(kscm, "error -- first argument must be string");
|
||
|
|
}
|
||
|
|
kscm->tmpfp = kscm->outfp;
|
||
|
|
kscm->outfp = stderr;
|
||
|
|
if (kscm->all_errors_fatal) {
|
||
|
|
kscm__fatal_error(kscm, kscm__strvalue(kscm, kscm__car(kscm, kscm->args)), NULL, NULL, NULL);
|
||
|
|
}
|
||
|
|
fprintf(kscm->outfp, "Error: ");
|
||
|
|
fprintf(kscm->outfp, "%s", kscm__strvalue(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
kscm->args = kscm__cdr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_ERR1);
|
||
|
|
|
||
|
|
case KSCM_OP_ERR1: /* error */
|
||
|
|
fprintf(kscm->outfp, " ");
|
||
|
|
if (kscm->args != kscm->NIL) {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_ERR1, kscm__cdr(kscm, kscm->args), kscm->NIL);
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->print_flag = 1;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
fprintf(kscm->outfp, "\n");
|
||
|
|
kscm__resetinput(kscm);
|
||
|
|
kscm->outfp = kscm->tmpfp;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_T0LVL);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_REVERSE: /* reverse */
|
||
|
|
kscm__s_return(kscm, kscm__reverse(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
|
||
|
|
case KSCM_OP_APPEND: /* append */
|
||
|
|
kscm__s_return(kscm, kscm__append(kscm, kscm__car(kscm, kscm->args), kscm__cadr(kscm, kscm->args)));
|
||
|
|
|
||
|
|
case KSCM_OP_PUT: /* put */
|
||
|
|
if (!kscm__hasprop(kscm, kscm__car(kscm, kscm->args)) || !kscm__hasprop(kscm, kscm__cadr(kscm, kscm->args))) {
|
||
|
|
kscm__error_0(kscm, "Illegal use of put");
|
||
|
|
}
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
for (x = kscm__symprop(kscm, kscm__car(kscm, kscm->args))/*, y = kscm__cadr(kscm, kscm->args)*/; x != kscm->NIL; x = kscm__cdr(kscm, x))
|
||
|
|
if (kscm__caar(kscm, x) == y)
|
||
|
|
break;
|
||
|
|
if (x != kscm->NIL)
|
||
|
|
kscm__cdar(kscm, x) = kscm__caddr(kscm, kscm->args);
|
||
|
|
else
|
||
|
|
kscm__symprop(kscm, kscm__car(kscm, kscm->args)) = kscm__cons(kscm, kscm__cons(kscm, y, kscm__caddr(kscm, kscm->args)),
|
||
|
|
kscm__symprop(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
|
||
|
|
case KSCM_OP_GET: /* get */
|
||
|
|
if (!kscm__hasprop(kscm, kscm__car(kscm, kscm->args)) || !kscm__hasprop(kscm, kscm__cadr(kscm, kscm->args))) {
|
||
|
|
kscm__error_0(kscm, "Illegal use of get");
|
||
|
|
}
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
for (x = kscm__symprop(kscm, kscm__car(kscm, kscm->args))/*, y = kscm__cadr(kscm, kscm->args)*/; x != kscm->NIL; x = kscm__cdr(kscm, x))
|
||
|
|
if (kscm__caar(kscm, x) == y)
|
||
|
|
break;
|
||
|
|
if (x != kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm__cdar(kscm, x));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_QUIT: /* quit */
|
||
|
|
return (kscm->NIL);
|
||
|
|
|
||
|
|
case KSCM_OP_GC: /* gc */
|
||
|
|
kscm__gc(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
|
||
|
|
case KSCM_OP_GCVERB: /* gc-verbose */
|
||
|
|
{ int was = kscm->gc_verbose;
|
||
|
|
|
||
|
|
kscm->gc_verbose = (kscm__car(kscm, kscm->args) != kscm->F);
|
||
|
|
kscm__s_retbool(kscm, was);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_NEWSEGMENT: /* new-segment */
|
||
|
|
if (!kscm__isnumber(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
kscm__error_0(kscm, "new-segment -- argument must be number");
|
||
|
|
}
|
||
|
|
fprintf(kscm->outfp, "allocate %d new segments\n",
|
||
|
|
kscm__alloc_cellseg(kscm, (int)kscm__ivalue(kscm, kscm__car(kscm, kscm->args))));
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_5(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y;
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
/* ========== reading part ========== */
|
||
|
|
case KSCM_OP_RDSEXPR:
|
||
|
|
switch (kscm->tok) {
|
||
|
|
case KSCM_TOK_COMMENT:
|
||
|
|
while (kscm__inchar(kscm) != '\n')
|
||
|
|
;
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
case KSCM_TOK_LPAREN:
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
if (kscm->tok == KSCM_TOK_RPAREN) {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
else if (kscm->tok == KSCM_TOK_DOT) {
|
||
|
|
kscm__error_0(kscm, "syntax error -- illegal dot expression");
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDLIST, kscm->NIL, kscm->NIL);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
}
|
||
|
|
case KSCM_TOK_QUOTE:
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDQUOTE, kscm->NIL, kscm->NIL);
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
case KSCM_TOK_BQUOTE:
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDQQUOTE, kscm->NIL, kscm->NIL);
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
case KSCM_TOK_COMMA:
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDUNQUOTE, kscm->NIL, kscm->NIL);
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
case KSCM_TOK_ATMARK:
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDUQTSP, kscm->NIL, kscm->NIL);
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
#endif
|
||
|
|
case KSCM_TOK_ATOM:
|
||
|
|
kscm__s_return(kscm, kscm__mk_atom(kscm, kscm__readstr(kscm, "();\t\n ")));
|
||
|
|
case KSCM_TOK_DQUOTE:
|
||
|
|
kscm__s_return(kscm, kscm__mk_string(kscm, kscm__readstrexp(kscm)));
|
||
|
|
case KSCM_TOK_SHARP:
|
||
|
|
if ((x = kscm__mk_const(kscm, kscm__readstr(kscm, "();\t\n "))) == kscm->NIL) {
|
||
|
|
kscm__error_0(kscm, "Undefined sharp expression");
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, x);
|
||
|
|
}
|
||
|
|
default:
|
||
|
|
kscm__error_0(kscm, "syntax error -- illegal token");
|
||
|
|
}
|
||
|
|
break;
|
||
|
|
|
||
|
|
case KSCM_OP_RDLIST:
|
||
|
|
kscm->args = kscm__cons(kscm, kscm->value, kscm->args);
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
if (kscm->tok == KSCM_TOK_COMMENT) {
|
||
|
|
while (kscm__inchar(kscm) != '\n')
|
||
|
|
;
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
}
|
||
|
|
if (kscm->tok == KSCM_TOK_RPAREN) {
|
||
|
|
kscm__s_return(kscm, kscm__non_alloc_rev(kscm, kscm->NIL, kscm->args));
|
||
|
|
}
|
||
|
|
else if (kscm->tok == KSCM_TOK_DOT) {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDDOT, kscm->args, kscm->NIL);
|
||
|
|
kscm->tok = kscm__token(kscm);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_RDLIST, kscm->args, kscm->NIL);;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_RDSEXPR);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_RDDOT:
|
||
|
|
if (kscm__token(kscm) != KSCM_TOK_RPAREN) {
|
||
|
|
kscm__error_0(kscm, "syntax error -- illegal dot expression");
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm__non_alloc_rev(kscm, kscm->value, kscm->args));
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_RDQUOTE:
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->QUOTE, kscm__cons(kscm, kscm->value, kscm->NIL)));
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
case KSCM_OP_RDQQUOTE:
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->QQUOTE, kscm__cons(kscm, kscm->value, kscm->NIL)));
|
||
|
|
|
||
|
|
case KSCM_OP_RDUNQUOTE:
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->UNQUOTE, kscm__cons(kscm, kscm->value, kscm->NIL)));
|
||
|
|
|
||
|
|
case KSCM_OP_RDUQTSP:
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->UNQUOTESP, kscm__cons(kscm, kscm->value, kscm->NIL)));
|
||
|
|
#endif
|
||
|
|
|
||
|
|
/* ========== printing part ========== */
|
||
|
|
case KSCM_OP_P0LIST:
|
||
|
|
if (!kscm__ispair(kscm, kscm->args)) {
|
||
|
|
kscm__printatom(kscm, kscm->args, kscm->print_flag);
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->QUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
fprintf(kscm->outfp, "'");
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->QQUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
fprintf(kscm->outfp, "`");
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTE && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
fprintf(kscm->outfp, ",");
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTESP && kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
fprintf(kscm->outfp, ",@");
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
fprintf(kscm->outfp, "(");
|
||
|
|
kscm__s_save(kscm, KSCM_OP_P1LIST, kscm__cdr(kscm, kscm->args), kscm->NIL);
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_P1LIST:
|
||
|
|
if (kscm__ispair(kscm, kscm->args)) {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_P1LIST, kscm__cdr(kscm, kscm->args), kscm->NIL);
|
||
|
|
fprintf(kscm->outfp, " ");
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0LIST);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
if (kscm->args != kscm->NIL) {
|
||
|
|
fprintf(kscm->outfp, " . ");
|
||
|
|
kscm__printatom(kscm, kscm->args, kscm->print_flag);
|
||
|
|
}
|
||
|
|
fprintf(kscm->outfp, ")");
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
}
|
||
|
|
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
|
||
|
|
}
|
||
|
|
return kscm->T;
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_6(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y;
|
||
|
|
register long v;
|
||
|
|
static long w;
|
||
|
|
char buffer[32];
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_LIST_LENGTH: /* list-length */ /* a.k */
|
||
|
|
v = 0;
|
||
|
|
for (x = kscm__car(kscm, kscm->args)/*, v = 0*/; kscm__ispair(kscm, x); x = kscm__cdr(kscm, x))
|
||
|
|
++v;
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, v));
|
||
|
|
|
||
|
|
case KSCM_OP_ASSQ: /* assq */ /* a.k */
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
for (y = kscm__cadr(kscm, kscm->args); kscm__ispair(kscm, y); y = kscm__cdr(kscm, y)) {
|
||
|
|
if (!kscm__ispair(kscm, kscm__car(kscm, y))) {
|
||
|
|
kscm__error_0(kscm, "Unable to handle non pair element");
|
||
|
|
}
|
||
|
|
if (x == kscm__caar(kscm, y))
|
||
|
|
break;
|
||
|
|
}
|
||
|
|
if (kscm__ispair(kscm, y)) {
|
||
|
|
kscm__s_return(kscm, kscm__car(kscm, y));
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_PRINT_WIDTH: /* print-width */ /* a.k */
|
||
|
|
w = 0;
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm->print_flag = -1;
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
|
||
|
|
case KSCM_OP_P0_WIDTH:
|
||
|
|
if (!kscm__ispair(kscm, kscm->args)) {
|
||
|
|
w += kscm__printatom(kscm, kscm->args, kscm->print_flag);
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, w));
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->QUOTE
|
||
|
|
&& kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
++w;
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->QQUOTE
|
||
|
|
&& kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
++w;
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTE
|
||
|
|
&& kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
++w;
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
}
|
||
|
|
else if (kscm__car(kscm, kscm->args) == kscm->UNQUOTESP
|
||
|
|
&& kscm__ok_abbrev(kscm, kscm__cdr(kscm, kscm->args))) {
|
||
|
|
w += 2;
|
||
|
|
kscm->args = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
++w;
|
||
|
|
kscm__s_save(kscm, KSCM_OP_P1_WIDTH, kscm__cdr(kscm, kscm->args), kscm->NIL);
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_P1_WIDTH:
|
||
|
|
if (kscm__ispair(kscm, kscm->args)) {
|
||
|
|
kscm__s_save(kscm, KSCM_OP_P1_WIDTH, kscm__cdr(kscm, kscm->args), kscm->NIL);
|
||
|
|
++w;
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
kscm__s_goto(kscm, KSCM_OP_P0_WIDTH);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
if (kscm->args != kscm->NIL)
|
||
|
|
w += 3 + kscm__printatom(kscm, kscm->args, kscm->print_flag);
|
||
|
|
++w;
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, w));
|
||
|
|
}
|
||
|
|
|
||
|
|
case KSCM_OP_GET_CLOSURE: /* get-closure-code */ /* a.k */
|
||
|
|
kscm->args = kscm__car(kscm, kscm->args);
|
||
|
|
if (kscm->args == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
else if (kscm__isclosure(kscm, kscm->args)) {
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->LAMBDA, kscm__closure_code(kscm, kscm->value)));
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
}
|
||
|
|
else if (kscm__ismacro(kscm, kscm->args)) {
|
||
|
|
kscm__s_return(kscm, kscm__cons(kscm, kscm->LAMBDA, kscm__closure_code(kscm, kscm->value)));
|
||
|
|
#endif
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
case KSCM_OP_CLOSUREP: /* closure? */
|
||
|
|
/*
|
||
|
|
* Note, macro object is also a closure.
|
||
|
|
* Therefore, (closure? <#MACRO>) ==> #t
|
||
|
|
*/
|
||
|
|
if (kscm__car(kscm, kscm->args) == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_retbool(kscm, kscm__isclosure(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
case KSCM_OP_MACROP: /* macro? */
|
||
|
|
if (kscm__car(kscm, kscm->args) == kscm->NIL) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_retbool(kscm, kscm__ismacro(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
#endif
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T; /* NOTREACHED */
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_PERSIST
|
||
|
|
unsigned int kscm_get_persistent_address(kscm_t* kscm, kscm_object_t obj) {
|
||
|
|
int i;
|
||
|
|
if (obj == kscm->NIL) {
|
||
|
|
return 0;
|
||
|
|
} else if (obj == kscm->F) {
|
||
|
|
return 1;
|
||
|
|
} else if (obj == kscm->T) {
|
||
|
|
return 2;
|
||
|
|
}
|
||
|
|
|
||
|
|
uintptr_t addr = (uintptr_t)obj;
|
||
|
|
//fprintf(stderr, "addr is %d\n", addr);
|
||
|
|
for (i = 0; i <= kscm->last_cell_seg; i++) {
|
||
|
|
uintptr_t segaddr = (uintptr_t)(kscm->cell_seg[i]);
|
||
|
|
//fprintf(stderr, "segaddr %d is %d\n", i, segaddr);
|
||
|
|
if (segaddr != 0 && addr >= segaddr && addr < segaddr + (KSCM_CONFIG_CELL_SEGSIZE * sizeof(struct kscm_cell))) {
|
||
|
|
//fprintf(stderr, "it's in here!\n");
|
||
|
|
int segment = i + 1;
|
||
|
|
uintptr_t offset = addr - segaddr;
|
||
|
|
if ((offset % sizeof(struct kscm_cell))) {
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
int index = offset / sizeof(struct kscm_cell);
|
||
|
|
return (segment * KSCM_CONFIG_CELL_SEGSIZE) + index;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
int kscm__fwrite_byte(kscm_t* kscm, FILE* f, char val) {
|
||
|
|
fputc(val, f);
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
int kscm__fwrite_int(kscm_t* kscm, FILE* f, int val) {
|
||
|
|
//fprintf(stderr, "writing %x %x %x %x\n", val & 0xFF, (val >> 8) & 0xFF, (val >> 16) & 0xFF, (val >> 24) & 0xFF);
|
||
|
|
fputc((val & 0xFF), f);
|
||
|
|
fputc(((val >> 8) & 0xFF), f);
|
||
|
|
fputc(((val >> 16) & 0xFF), f);
|
||
|
|
fputc(((val >> 24) & 0xFF), f);
|
||
|
|
return 4;
|
||
|
|
}
|
||
|
|
int kscm__fwrite_strl(kscm_t* kscm, FILE* f, const char* str, int len) {
|
||
|
|
if (str == NULL) {
|
||
|
|
return kscm__fwrite_int(kscm, f, 0);
|
||
|
|
}
|
||
|
|
int written = kscm__fwrite_int(kscm, f, len);
|
||
|
|
if (written != 4) {
|
||
|
|
return written;
|
||
|
|
}
|
||
|
|
int i;
|
||
|
|
for (i = 0; i < len; i++) {
|
||
|
|
fputc(str[i], f);
|
||
|
|
written++;
|
||
|
|
}
|
||
|
|
return written;
|
||
|
|
}
|
||
|
|
int kscm__fwrite_str(kscm_t* kscm, FILE* f, const char* str) {
|
||
|
|
return kscm__fwrite_strl(kscm, f, str, strlen(str));
|
||
|
|
}
|
||
|
|
|
||
|
|
int kscm_save_state(kscm_t* kscm, const char* filename, const char* opts) {
|
||
|
|
if (filename == NULL || strlen(filename) < 1) {
|
||
|
|
fprintf(stderr, "Filename expected\n");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
FILE* f = fopen(filename, "wb");
|
||
|
|
if (f == NULL) {
|
||
|
|
fprintf(stderr, "Failed to open '%s' for writing\n", filename);
|
||
|
|
return -1; // Not saved
|
||
|
|
}
|
||
|
|
fprintf(stderr, "Saving state to '%s' opts '%s'...\n", filename, opts);
|
||
|
|
|
||
|
|
kscm__fwrite_str(kscm, f, KSCM_CONFIG_PERSIST_MAGIC);
|
||
|
|
//fclose(f); if (1) return 0;
|
||
|
|
kscm__fwrite_int(kscm, f, KSCM_CONFIG_PERSIST_VERSION);
|
||
|
|
|
||
|
|
// Bytes per id (higher bits may be reused later for flags)
|
||
|
|
kscm__fwrite_int(kscm, f, kscm->_stateformat);
|
||
|
|
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->NIL));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->F));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->T));
|
||
|
|
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->oblist));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->global_env));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->LAMBDA));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->QUOTE));
|
||
|
|
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->QQUOTE));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->UNQUOTE));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->UNQUOTESP));
|
||
|
|
|
||
|
|
/* NOTE: The format has been reorganised (as of "version 2" of the format) to allow for
|
||
|
|
* multithreading, which isn't supported on this implementation, but now thread-specific
|
||
|
|
* data is stored separately.
|
||
|
|
*/
|
||
|
|
/* Begin by writing the number of threads (always 1, for now). */
|
||
|
|
kscm__fwrite_int(kscm, f, 1);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm->_threadstate);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadname));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadopts));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadobject));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->args));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->envir));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->code));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->dump));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->value));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm->_operator);
|
||
|
|
|
||
|
|
//fprintf(stderr, "Persistent addresses: ->T=%d ->F=%d ->NIL=%d\n", kscm_get_persistent_address(kscm, kscm->T), kscm_get_persistent_address(kscm, kscm->F), kscm_get_persistent_address(kscm, kscm->NIL));
|
||
|
|
|
||
|
|
//fprintf(stderr, "Persistent addresses: ->args=%d ->envir=%d ->code=%d ->dump=%d\n", kscm_get_persistent_address(kscm, kscm->args), kscm_get_persistent_address(kscm, kscm->envir), kscm_get_persistent_address(kscm, kscm->code), kscm_get_persistent_address(kscm, kscm->dump));
|
||
|
|
|
||
|
|
int s;
|
||
|
|
for (s = 0; s <= kscm->last_cell_seg; s++) {
|
||
|
|
fprintf(stderr, ".");
|
||
|
|
int i;
|
||
|
|
for (i = 0; i < KSCM_CONFIG_CELL_SEGSIZE; i++) {
|
||
|
|
kscm_object_t obj = (kscm->cell_seg[s])+i;//&(kscm->cell_seg[s][i]);
|
||
|
|
if (obj->_flag == 0) { // free ?
|
||
|
|
//fprintf(stderr, "Object at %d:%d is free\n", s, i);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
fprintf(stderr, "Object at %d:%d is non-free\n", s, i);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, obj));
|
||
|
|
if (kscm__isnumber(kscm, obj)) {
|
||
|
|
if (!kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "int isn't atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TINT32);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm__ivalue(kscm, obj));
|
||
|
|
}
|
||
|
|
else if (kscm__issymbol(kscm, obj)) {
|
||
|
|
if (kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "symbol is atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, kscm__issyntax(kscm, obj) ? KSCM_PERSIST_TSYNTAX : KSCM_PERSIST_TSYMBOL);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj)));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj)));
|
||
|
|
}
|
||
|
|
else if (kscm__isstring(kscm, obj)) {
|
||
|
|
if (!kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "string isn't atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TSTRING);
|
||
|
|
kscm__fwrite_int(kscm, f, obj->_object._string._keynum);
|
||
|
|
kscm__fwrite_str(kscm, f, kscm__strvalue(kscm, obj));
|
||
|
|
}
|
||
|
|
else if (kscm__ispair(kscm, obj)) {
|
||
|
|
if (kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "pair is atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TPAIR);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj)));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj)));
|
||
|
|
}
|
||
|
|
else if (kscm__isproc(kscm, obj)) {
|
||
|
|
if (!kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "proc isn't atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TPROC);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm__ivalue(kscm, obj));
|
||
|
|
}
|
||
|
|
else if (kscm__isclosure(kscm, obj)) {
|
||
|
|
if (kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "closure is atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TCLOSURE);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj)));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj)));
|
||
|
|
}
|
||
|
|
else if (kscm__iscontinuation(kscm, obj)) {
|
||
|
|
if (kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "closure is atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TCONTINUATION);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj)));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj)));
|
||
|
|
}
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
else if (kscm__isabstraction(kscm, obj)) {
|
||
|
|
if (kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "abstraction is atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TABSTRACTION);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__car(kscm, obj)));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm__cdr(kscm, obj)));
|
||
|
|
}
|
||
|
|
else if (kscm__isbuffer(kscm, obj)) {
|
||
|
|
if (!kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "buffer isn't atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TBUFFER);
|
||
|
|
kscm__fwrite_strl(kscm, f, (const char*)(obj->_object._buffer._data), obj->_object._buffer._length);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_FLOATS
|
||
|
|
else if (kscm__isfloat64(kscm, obj)) {
|
||
|
|
double tmp = obj->_object._float64._dvalue;
|
||
|
|
char* bytes = (char*)(void*)(&tmp) /*obj->_object._float64._dvalue*/;
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TFLOAT64);
|
||
|
|
// NOTE: This assumes floating-point endian is the same on all platforms
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[0]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[1]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[2]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[3]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[4]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[5]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[6]);
|
||
|
|
kscm__fwrite_byte(kscm, f, bytes[7]);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
else if (kscm__isobjx(kscm, obj)) {
|
||
|
|
if (kscm__isatom(kscm, obj)) {
|
||
|
|
fprintf(stderr, "object is atom\n");
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
kscm__fwrite_byte(kscm, f, KSCM_PERSIST_TOBJX);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, obj->_object._objx._type));
|
||
|
|
kscm__fwrite_int(kscm, f, obj->_object._objx._count);
|
||
|
|
int i;
|
||
|
|
for (i = 0; i < obj->_object._objx._count; i++) {
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, obj->_object._objx._elements[i]));
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
else {
|
||
|
|
fprintf(stderr, "Object at %d:%d is non-free but unknown type: %d\n", s, i, obj->_flag);
|
||
|
|
return -1; // Not saved
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm__fwrite_int(kscm, f, 0); // Zero address to indicate end of objects
|
||
|
|
kscm__fwrite_int(kscm, f, 0); // Additional zero to indicate no additional data (may be extended in future versions)
|
||
|
|
fclose(f);
|
||
|
|
|
||
|
|
fprintf(stderr, "\n");
|
||
|
|
|
||
|
|
return 0; // Saved
|
||
|
|
}
|
||
|
|
|
||
|
|
int kscm__fread_byte(kscm_t* kscm, FILE* f, char* result) {
|
||
|
|
int r = fgetc(f);
|
||
|
|
*result = r;
|
||
|
|
return 1;
|
||
|
|
}
|
||
|
|
int kscm__fread_int(kscm_t* kscm, FILE* f, int* result) {
|
||
|
|
*result = 0;
|
||
|
|
*result |= (fgetc(f) & 0xff);
|
||
|
|
*result |= (fgetc(f) & 0xff) << 8;
|
||
|
|
*result |= (fgetc(f) & 0xff) << 16;
|
||
|
|
*result |= (fgetc(f) & 0xff) << 24;
|
||
|
|
return 4;
|
||
|
|
}
|
||
|
|
int kscm__fread_str(kscm_t* kscm, FILE* f, const char** result) {
|
||
|
|
int len;
|
||
|
|
if (kscm__fread_int(kscm, f, &len) != 4) {
|
||
|
|
*result = NULL;
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
//fprintf(stderr, "Got length %d\n", len);
|
||
|
|
if (len > 1000) {
|
||
|
|
*result = NULL;
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
*result = (const char*) calloc(len + 1, 1);
|
||
|
|
if (*result == NULL) {
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
int i;
|
||
|
|
for (i = 0; i < len; i++) {
|
||
|
|
((* (char**)result)[i]) = (char)fgetc(f);
|
||
|
|
}
|
||
|
|
return len;
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm_object_t kscm_get_object_address(kscm_t* kscm, int persistent_address) {
|
||
|
|
if (persistent_address == 0) {
|
||
|
|
return kscm->NIL;
|
||
|
|
} else if (persistent_address == 1) {
|
||
|
|
return kscm->F;
|
||
|
|
} else if (persistent_address == 2) {
|
||
|
|
return kscm->T;
|
||
|
|
}
|
||
|
|
int idx = persistent_address % KSCM_CONFIG_CELL_SEGSIZE;
|
||
|
|
int segnum = persistent_address / KSCM_CONFIG_CELL_SEGSIZE;
|
||
|
|
if (segnum < 1) {
|
||
|
|
return NULL;
|
||
|
|
}
|
||
|
|
segnum--;
|
||
|
|
if (segnum >= KSCM_CONFIG_CELL_NSEGMENT) {
|
||
|
|
return NULL;
|
||
|
|
}
|
||
|
|
while (segnum > kscm->last_cell_seg) {
|
||
|
|
kscm->last_cell_seg++;
|
||
|
|
kscm->cell_seg[kscm->last_cell_seg] = (kscm_object_t) calloc(KSCM_CONFIG_CELL_SEGSIZE, sizeof(struct kscm_cell));
|
||
|
|
}
|
||
|
|
return kscm->cell_seg[segnum] + idx; //&kscm->cell_seg[segnum][idx];
|
||
|
|
}
|
||
|
|
|
||
|
|
int kscm_resume_state(kscm_t* kscm, const char* filename, const char* opts) {
|
||
|
|
if (filename == NULL || strlen(filename) < 1) {
|
||
|
|
fprintf(stderr, "Filename expected\n");
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
FILE* f = fopen(filename, "rb");
|
||
|
|
if (f == NULL) {
|
||
|
|
fprintf(stderr, "Failed to open '%s' for reading\n", filename);
|
||
|
|
return -1; // Not saved
|
||
|
|
}
|
||
|
|
fprintf(stderr, "Reading state from '%s' opts '%s'...\n", filename, opts);
|
||
|
|
|
||
|
|
const char* tmpstr;
|
||
|
|
int tmpint;
|
||
|
|
kscm__fread_str(kscm, f, &tmpstr);
|
||
|
|
|
||
|
|
if (tmpstr == NULL || strcmp(tmpstr, KSCM_CONFIG_PERSIST_MAGIC) != 0) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad magic string\n", filename);
|
||
|
|
free((void*)tmpstr);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
free((void*)tmpstr);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
if (tmpint != KSCM_CONFIG_PERSIST_VERSION) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad version number, expected %d but got %d\n", filename, KSCM_CONFIG_PERSIST_VERSION, tmpint);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
if (tmpint != 4) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad format options, expected 4 but got %d\n", filename, tmpint);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
kscm->_stateformat = tmpint;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
if (tmpint != 0) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad NIL index, expected %d but got %d\n", filename, 0, tmpint);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
if (tmpint != 1) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad F index, expected %d but got %d\n", filename, 1, tmpint);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
if (tmpint != 2) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad T index, expected %d but got %d\n", filename, 2, tmpint);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->oblist = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->global_env = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->LAMBDA = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->QUOTE = kscm_get_object_address(kscm, tmpint);
|
||
|
|
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->QQUOTE = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->UNQUOTE = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->UNQUOTESP = kscm_get_object_address(kscm, tmpint);
|
||
|
|
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
if (tmpint != 1) {
|
||
|
|
fprintf(stderr, "Failed to read '%s': Bad number of threads, this VM only supports 1 thread but got %d\n", filename, tmpint);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
/*
|
||
|
|
|
||
|
|
kscm__fwrite_int(kscm, f, 1);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm->_threadstate);
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadname));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadopts));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->_threadobject));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->args));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->envir));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->code));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->dump));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm_get_persistent_address(kscm, kscm->value));
|
||
|
|
kscm__fwrite_int(kscm, f, kscm->_operator);
|
||
|
|
*/
|
||
|
|
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->_threadstate = tmpint;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->_threadname = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->_threadopts = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->_threadobject = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->args = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->envir = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->code = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->dump = kscm_get_object_address(kscm, tmpint);
|
||
|
|
|
||
|
|
/* At least for the main thread, the value/operator options are discarded. */
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
kscm->value = kscm->NIL; //kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm->_operator = 0;
|
||
|
|
|
||
|
|
//fprintf(stderr, "Persistent addresses: ->T=%d ->F=%d ->NIL=%d\n", kscm_get_persistent_address(kscm, kscm->T), kscm_get_persistent_address(kscm, kscm->F), kscm_get_persistent_address(kscm, kscm->NIL));
|
||
|
|
|
||
|
|
//fprintf(stderr, "Persistent addresses: ->args=%d ->envir=%d ->code=%d ->dump=%d\n", kscm_get_persistent_address(kscm, kscm->args), kscm_get_persistent_address(kscm, kscm->envir), kscm_get_persistent_address(kscm, kscm->code), kscm_get_persistent_address(kscm, kscm->dump));
|
||
|
|
|
||
|
|
/* Clear all of the cell memory. Any new blocks that get automatically allocated will be cleared upon allocation. */
|
||
|
|
int i;
|
||
|
|
for (i = 0; i <= kscm->last_cell_seg; i++) {
|
||
|
|
memset(kscm->cell_seg[i], 0, sizeof(struct kscm_cell) * KSCM_CONFIG_CELL_SEGSIZE);
|
||
|
|
}
|
||
|
|
|
||
|
|
int objid;
|
||
|
|
do {
|
||
|
|
if (kscm__fread_int(kscm, f, &objid) != 4) {
|
||
|
|
fprintf(stderr, "WTFERR1\n");
|
||
|
|
exit(-1);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
if (objid == 0) break;
|
||
|
|
|
||
|
|
kscm_object_t obj = kscm_get_object_address(kscm, objid);
|
||
|
|
if (obj == NULL) {
|
||
|
|
fprintf(stderr, "WTFERR2\n");
|
||
|
|
exit(-1);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
char typ = 0;
|
||
|
|
if (kscm__fread_byte(kscm, f, &typ) != 1) {
|
||
|
|
fprintf(stderr, "WTFERR3\n");
|
||
|
|
exit(-1);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
fprintf(stderr, "Got type %d\n", typ);
|
||
|
|
const char* tmpstr;
|
||
|
|
switch (typ) {
|
||
|
|
case KSCM_PERSIST_TINT32:
|
||
|
|
obj->_flag = KSCM_T_NUMBER | KSCM_T_ATOM;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._number._ivalue = tmpint;
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TSTRING:
|
||
|
|
obj->_flag = KSCM_T_STRING | KSCM_T_ATOM;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._string._keynum = tmpint;
|
||
|
|
tmpint = kscm__fread_str(kscm, f, &tmpstr);
|
||
|
|
if (tmpint < 0) {
|
||
|
|
fprintf(stderr, "WTFERR4\n");
|
||
|
|
exit(-1);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
//fprintf(stderr, "Got str len %d '%s'\n", tmpint, tmpstr);
|
||
|
|
#ifdef __WIN32
|
||
|
|
obj->_object._string._svalue = _strdup(tmpstr);//kscm__store_string(kscm, tmpstr);
|
||
|
|
#else
|
||
|
|
obj->_object._string._svalue = strdup(tmpstr);//kscm__store_string(kscm, tmpstr);
|
||
|
|
#endif
|
||
|
|
free((void*)tmpstr);
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TSYMBOL:
|
||
|
|
obj->_flag = KSCM_T_SYMBOL;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._car = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint);
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TPAIR:
|
||
|
|
obj->_flag = KSCM_T_PAIR;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._car = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint);
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TPROC:
|
||
|
|
obj->_flag = KSCM_T_PROC | KSCM_T_ATOM;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._number._ivalue = tmpint;
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TCLOSURE:
|
||
|
|
obj->_flag = KSCM_T_CLOSURE;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._car = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint);
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TSYNTAX:
|
||
|
|
obj->_flag = KSCM_T_SYMBOL | KSCM_T_SYNTAX;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._car = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint);
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TCONTINUATION:
|
||
|
|
obj->_flag = KSCM_T_CONTINUATION;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._car = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint);
|
||
|
|
break;
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
case KSCM_PERSIST_TABSTRACTION:
|
||
|
|
obj->_flag = KSCM_T_ABSTRACTION;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._car = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._cons._cdr = kscm_get_object_address(kscm, tmpint);
|
||
|
|
break;
|
||
|
|
case KSCM_PERSIST_TBUFFER:
|
||
|
|
obj->_flag = KSCM_T_BUFFER | KSCM_T_ATOM;
|
||
|
|
tmpint = kscm__fread_str(kscm, f, &tmpstr);
|
||
|
|
obj->_object._buffer._length = tmpint;
|
||
|
|
if (tmpint < 0) {
|
||
|
|
fprintf(stderr, "WTFERR4\n");
|
||
|
|
exit(-1);
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
//fprintf(stderr, "Got str len %d '%s'\n", tmpint, tmpstr);
|
||
|
|
obj->_object._buffer._data = (unsigned char*) tmpstr; //kscm__store_string(kscm, tmpstr);
|
||
|
|
//free((void*)tmpstr);
|
||
|
|
break;
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_FLOATS
|
||
|
|
case KSCM_PERSIST_TFLOAT64: {
|
||
|
|
obj->_flag = KSCM_T_FLOAT64 | KSCM_T_ATOM;
|
||
|
|
double tmp;
|
||
|
|
char* bytes = (char*)(void*)&tmp; //obj->_object._float64._dvalue;
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[0]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[1]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[2]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[3]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[4]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[5]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[6]);
|
||
|
|
kscm__fread_byte(kscm, f, &bytes[7]);
|
||
|
|
obj->_object._float64._dvalue = tmp;
|
||
|
|
} break;
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
case KSCM_PERSIST_TOBJX:
|
||
|
|
obj->_flag = KSCM_T_OBJX;
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._objx._type = kscm_get_object_address(kscm, tmpint);
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._objx._count = tmpint;
|
||
|
|
obj->_object._objx._elements = (kscm_object_t*) calloc(sizeof(kscm_object_t), obj->_object._objx._count);
|
||
|
|
// TODO Check non-null (ideally check size is sane before attempting to allocate/fill)
|
||
|
|
for (i = 0; i < obj->_object._objx._count; i++) {
|
||
|
|
kscm__fread_int(kscm, f, &tmpint);
|
||
|
|
obj->_object._objx._elements[i] = kscm_get_object_address(kscm, tmpint);
|
||
|
|
}
|
||
|
|
break;
|
||
|
|
#endif
|
||
|
|
default:
|
||
|
|
fprintf(stderr, "Unknown object type #%d\n", typ);
|
||
|
|
exit(1);
|
||
|
|
if (1) return 0;
|
||
|
|
}
|
||
|
|
} while (objid != 0);
|
||
|
|
|
||
|
|
kscm->free_cell = kscm->NIL;
|
||
|
|
kscm->fcells = 0;
|
||
|
|
return 0; // Resumed
|
||
|
|
}
|
||
|
|
/* From ifdef KSCM_CONFIG_USE_PERSIST */
|
||
|
|
#endif
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_7(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y, z;
|
||
|
|
char* str1;
|
||
|
|
char* str2;
|
||
|
|
char* str3;
|
||
|
|
register long v;
|
||
|
|
static long w;
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
case KSCM_OP_STRCAT:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
if (!kscm__isstring(kscm, x) || !kscm__isstring(kscm, y)) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
str1 = kscm__strvalue(kscm, x);
|
||
|
|
str2 = kscm__strvalue(kscm, y);
|
||
|
|
str3 = (char*)calloc(strlen(str1) + strlen(str2) + 1, 1);
|
||
|
|
if (str3 == NULL) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
strcat(str3, str1);
|
||
|
|
strcat(str3, str2);
|
||
|
|
z = kscm__mk_string(kscm, str3);
|
||
|
|
free(str3);
|
||
|
|
kscm__s_return(kscm, z);
|
||
|
|
case KSCM_OP_STRLEN:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
if (!kscm__isstring(kscm, x)) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
str1 = kscm__strvalue(kscm, x);
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, strlen(str1)));
|
||
|
|
case KSCM_OP_STRGET:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
if (!kscm__isstring(kscm, x) || !kscm__isnumber(kscm, y)) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
str1 = kscm__strvalue(kscm, x);
|
||
|
|
v = kscm__ivalue(kscm, y);
|
||
|
|
if (v < 0 || v >= strlen(str1)) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, ((int)(str1[v])) & 0xFF));
|
||
|
|
#ifdef KSCM_CONFIG_USE_PERSIST
|
||
|
|
case KSCM_OP_SAVE_STATE:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
str1 = kscm__strvalue(kscm, x);
|
||
|
|
str2 = kscm__strvalue(kscm, y);
|
||
|
|
if (kscm_save_state(kscm, str1, str2) == 0) {
|
||
|
|
kscm__s_return(kscm, kscm__mk_symbol(kscm, "saved"));
|
||
|
|
} else {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
case KSCM_OP_RESUME_STATE:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
str1 = kscm__strvalue(kscm, x);
|
||
|
|
str2 = kscm__strvalue(kscm, y);
|
||
|
|
if (kscm_resume_state(kscm, str1, str2) == 0) {
|
||
|
|
kscm__s_return(kscm, kscm__mk_symbol(kscm, "resumed"));
|
||
|
|
} else {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
case KSCM_OP_BUFFER:
|
||
|
|
kscm__s_retbool(kscm, kscm__isbuffer(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_BUFFER_NEW:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
if (kscm__isstring(kscm, x)) {
|
||
|
|
const char* strval = kscm__strvalue(kscm, x);
|
||
|
|
size_t slen = strlen(strval);
|
||
|
|
y = kscm__mk_buffer(kscm, slen);
|
||
|
|
size_t iter;
|
||
|
|
for (iter = 0; iter < slen; iter++) {
|
||
|
|
y->_object._buffer._data[iter] = strval[iter];
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, y);
|
||
|
|
} else if (!kscm__isnumber(kscm, x)) {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_buffer(kscm, kscm__ivalue(kscm, x)));
|
||
|
|
case KSCM_OP_BUFFER_LEN:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
if (!kscm__isbuffer(kscm, x)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, x->_object._buffer._length));
|
||
|
|
case KSCM_OP_BUFFER_GET:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
if (!kscm__isbuffer(kscm, x) || !kscm__isnumber(kscm, y)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
v = kscm__ivalue(kscm, y);
|
||
|
|
if (v < 0 || v >= x->_object._buffer._length) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, ((long)(x->_object._buffer._data[v])) & 0xFF));
|
||
|
|
case KSCM_OP_BUFFER_SET:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
z = kscm__caddr(kscm, kscm->args);
|
||
|
|
if (!kscm__isbuffer(kscm, x) || !kscm__isnumber(kscm, y) || !kscm__isnumber(kscm, z)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
v = kscm__ivalue(kscm, y);
|
||
|
|
if (v < 0 || v >= x->_object._buffer._length) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
x->_object._buffer._data[v] = (unsigned char)kscm__ivalue(kscm, z);
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
case KSCM_OP_BUFFER_LOAD:
|
||
|
|
kscm__s_return(kscm, kscm__mk_string(kscm, "TODO"));
|
||
|
|
case KSCM_OP_BUFFER_SAVE:
|
||
|
|
kscm__s_return(kscm, kscm__mk_string(kscm, "TODO"));
|
||
|
|
case KSCM_OP_ABSTRACTION:
|
||
|
|
kscm__s_retbool(kscm, kscm__isabstraction(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_ABSTRACTION_NEW:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
kscm__s_return(kscm, kscm__mk_abstraction(kscm, x, y));
|
||
|
|
case KSCM_OP_ABSTRACTION_TYPE:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
if (kscm__isobjx(kscm, x)) {
|
||
|
|
kscm__s_return(kscm, x->_object._objx._type);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
if (!kscm__isabstraction(kscm, x)) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__car(kscm, x));
|
||
|
|
case KSCM_OP_ABSTRACTION_VALUE:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
if (!kscm__isabstraction(kscm, x)) {
|
||
|
|
kscm__s_retbool(kscm, 0);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__cdr(kscm, x));
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
case KSCM_OP_OBJECT:
|
||
|
|
kscm__s_retbool(kscm, kscm__isobjx(kscm, kscm__car(kscm, kscm->args)));
|
||
|
|
case KSCM_OP_OBJECT_NEW:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
if (!kscm__isnumber(kscm, y)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_objx(kscm, x, kscm__ivalue(kscm, y)));
|
||
|
|
case KSCM_OP_OBJECT_LEN:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
if (!kscm__isobjx(kscm, x)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, x->_object._objx._count));
|
||
|
|
case KSCM_OP_OBJECT_GET:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
if (!kscm__isobjx(kscm, x) || !kscm__isnumber(kscm, y)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
v = kscm__ivalue(kscm, y);
|
||
|
|
if (v < 0 || v >= x->_object._objx._count) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
kscm__s_return(kscm, x->_object._objx._elements[v]);
|
||
|
|
case KSCM_OP_OBJECT_SET:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
z = kscm__caddr(kscm, kscm->args);
|
||
|
|
if (!kscm__isobjx(kscm, x) || !kscm__isnumber(kscm, y)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
v = kscm__ivalue(kscm, y);
|
||
|
|
if (v < 0 || v >= x->_object._objx._count) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
x->_object._objx._elements[v] = z;
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
case KSCM_OP_OBJECT_RETYPE:
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
y = kscm__cadr(kscm, kscm->args);
|
||
|
|
if (!kscm__isobjx(kscm, x)) {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
x->_object._objx._type = y;
|
||
|
|
kscm__s_return(kscm, kscm->T);
|
||
|
|
#endif
|
||
|
|
case KSCM_OP_SYMBOL_TO_STRING:
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
/* We handle buffer->string in the same function if structs are enabled. */
|
||
|
|
if (kscm__isbuffer(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
x = kscm__car(kscm, kscm->args);
|
||
|
|
char* tmp_buffer = (char*) calloc(x->_object._buffer._length, 1);
|
||
|
|
if (tmp_buffer == NULL) {
|
||
|
|
kscm__s_return(kscm, kscm->NIL);
|
||
|
|
}
|
||
|
|
size_t iter;
|
||
|
|
for (iter = 0; iter < x->_object._buffer._length; iter++) {
|
||
|
|
tmp_buffer[iter] = x->_object._buffer._data[iter];
|
||
|
|
}
|
||
|
|
/* Note: All the messaround above was only to keep the string-creation API consistent.
|
||
|
|
* It would be easy to optimise the buffer->string case by creating the string object manually.
|
||
|
|
*/
|
||
|
|
y = kscm__mk_string(kscm, tmp_buffer);
|
||
|
|
free(tmp_buffer);
|
||
|
|
kscm__s_return(kscm, y);
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
if (kscm__issymbol(kscm, kscm__car(kscm, kscm->args))) {
|
||
|
|
x = kscm__caar(kscm, kscm->args);
|
||
|
|
kscm__s_return(kscm, x);
|
||
|
|
}
|
||
|
|
else {
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
}
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T; /* NOTREACHED */
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm_object_t kscm__opexe_8(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
register kscm_object_t x, y, z;
|
||
|
|
char* str1;
|
||
|
|
char* str2;
|
||
|
|
char* str3;
|
||
|
|
register long v;
|
||
|
|
static long w;
|
||
|
|
#ifdef KSCM_CONFIG_USE_CONSOLE
|
||
|
|
struct winsize ws;
|
||
|
|
int fd;
|
||
|
|
#endif
|
||
|
|
|
||
|
|
switch (op) {
|
||
|
|
#ifdef KSCM_CONFIG_USE_CONSOLE
|
||
|
|
case KSCM_OP_CONSOLE_MODE:
|
||
|
|
x = kscm__mk_string(kscm, ttyname(STDIN_FILENO));
|
||
|
|
kscm__s_return(kscm, x);
|
||
|
|
case KSCM_OP_CONSOLE_WIDTH:
|
||
|
|
case KSCM_OP_CONSOLE_HEIGHT:
|
||
|
|
str1 = ttyname(STDIN_FILENO); // NOTE: "/dev/tty" may work if this isn't available!
|
||
|
|
fd = open(str1, O_RDWR);
|
||
|
|
if (fd < 0) {
|
||
|
|
kscm__error_0(kscm, "Failed to open console device");
|
||
|
|
}
|
||
|
|
/* Get window size of terminal. */
|
||
|
|
if (ioctl(fd, TIOCGWINSZ, &ws) < 0) {
|
||
|
|
kscm__error_0(kscm, "Failed to get console info");
|
||
|
|
}
|
||
|
|
close(fd);
|
||
|
|
if (op == KSCM_OP_CONSOLE_WIDTH) {
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, ws.ws_row));
|
||
|
|
} else {
|
||
|
|
kscm__s_return(kscm, kscm__mk_number(kscm, ws.ws_row));
|
||
|
|
}
|
||
|
|
#else
|
||
|
|
case KSCM_OP_CONSOLE_MODE:
|
||
|
|
kscm__s_return(kscm, kscm->F);
|
||
|
|
#endif
|
||
|
|
/*
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_MODE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_NEXT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_POLL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_WIDTH);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_HEIGHT);
|
||
|
|
*/
|
||
|
|
default:
|
||
|
|
sprintf(kscm->strbuff, "%d is illegal operator", kscm->_operator);
|
||
|
|
kscm__error_0(kscm, kscm->strbuff);
|
||
|
|
}
|
||
|
|
return kscm->T; /* NOTREACHED */
|
||
|
|
}
|
||
|
|
|
||
|
|
typedef kscm_object_t(*kscm_dispatchf_t)(kscm_t* kscm, register short op);
|
||
|
|
|
||
|
|
kscm_dispatchf_t kscm__shared_dispatch_table[256];
|
||
|
|
|
||
|
|
void kscm__eval_set(kscm_t* kscm, kscm_dispatchf_t func, int tag) {
|
||
|
|
kscm__shared_dispatch_table[tag] = func;
|
||
|
|
}
|
||
|
|
|
||
|
|
void kscm__eval_setup(kscm_t* kscm) {
|
||
|
|
if (kscm__shared_dispatch_table[KSCM_OP_LOAD] == &kscm__opexe_0) {
|
||
|
|
return;
|
||
|
|
}
|
||
|
|
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LOAD);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_T0LVL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_T1LVL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_READ);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_VALUEPRINT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_EVAL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_E0ARGS);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_E1ARGS);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_APPLY);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_DOMACRO);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LAMBDA);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_QUOTE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_DEF0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_DEF1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_BEGIN);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_IF0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_IF1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_SET0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_SET1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET2);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET0AST);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET1AST);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_0, KSCM_OP_LET2AST);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_LET0REC);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_LET1REC);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_LET2REC);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_COND0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_COND1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_DELAY);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_AND0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_AND1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_OR0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_OR1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_C0STREAM);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_C1STREAM);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_0MACRO);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_1MACRO);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CASE0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CASE1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CASE2);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_PEVAL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_PAPPLY);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_1, KSCM_OP_CONTINUATION);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_ADD);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_SUB);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_MUL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_DIV);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_REM);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_CAR);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_CDR);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_CONS);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_SETCAR);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_2, KSCM_OP_SETCDR);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NOT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_BOOL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NULL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_ZEROP);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_POSP);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NEGP);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NEQ);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_LESS);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_GRE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_LEQ);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_GEQ);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_SYMBOL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_NUMBER);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_STRING);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_PROC);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_PAIR);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_EQ);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_3, KSCM_OP_EQV);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_FORCE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_WRITE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_DISPLAY);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_NEWLINE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_ERR0);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_ERR1);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_REVERSE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_APPEND);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_PUT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_GET);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_QUIT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_GC);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_GCVERB);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_4, KSCM_OP_NEWSEGMENT);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDSEXPR);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDLIST);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDDOT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDQUOTE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDQQUOTE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDUNQUOTE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_RDUQTSP);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_P0LIST);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_5, KSCM_OP_P1LIST);
|
||
|
|
//
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_LIST_LENGTH);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_ASSQ);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_PRINT_WIDTH);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_P0_WIDTH);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_P1_WIDTH);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_GET_CLOSURE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_CLOSUREP);
|
||
|
|
//#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_6, KSCM_OP_MACROP);
|
||
|
|
//#endif Removed ifdef to keep ordering consistent. -Zak.
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_STRCAT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_STRLEN);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_STRGET);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_SAVE_STATE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_RESUME_STATE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_NEW);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_LEN);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_GET);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_SET);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION_NEW);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION_TYPE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_ABSTRACTION_VALUE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_NEW);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_LEN);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_GET);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_SET);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_OBJECT_RETYPE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_SYMBOL_TO_STRING);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_LOAD);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_7, KSCM_OP_BUFFER_SAVE);
|
||
|
|
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_MODE);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_NEXT);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_POLL);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_WIDTH);
|
||
|
|
kscm__eval_set(kscm, &kscm__opexe_8, KSCM_OP_CONSOLE_HEIGHT);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* These and the commented-out parts of kscm__eval_cycle can be re-enabled if you need to make sure the interpreter is running.
|
||
|
|
int fixme_reccheck = 0;
|
||
|
|
int fixme_ops = 0;
|
||
|
|
*/
|
||
|
|
/* kernel of this intepreter */
|
||
|
|
kscm_object_t kscm__eval_cycle(kscm_t* kscm, register short op)
|
||
|
|
{
|
||
|
|
kscm__eval_setup(kscm);
|
||
|
|
/*fixme_reccheck++;
|
||
|
|
if (fixme_reccheck > 1) {
|
||
|
|
fprintf(stderr, "Warning reccheck=%d\n", fixme_reccheck);
|
||
|
|
}*/
|
||
|
|
kscm->_operator = op;
|
||
|
|
for (;;) {
|
||
|
|
kscm_object_t(*func)(kscm_t* kscm, register short op) = kscm__shared_dispatch_table[kscm->_operator];
|
||
|
|
if (func == NULL) {
|
||
|
|
fprintf(stderr, "Error! Opcode %d leads to NULL!\n", kscm->_operator);
|
||
|
|
exit(-1);
|
||
|
|
}
|
||
|
|
if (/*(*kscm__shared_dispatch_table[kscm->_operator])*/ func(kscm, kscm->_operator) == kscm->NIL) {
|
||
|
|
//fixme_reccheck--;
|
||
|
|
return kscm->NIL;
|
||
|
|
}
|
||
|
|
/*if ((fixme_ops % 1000) == 0) {
|
||
|
|
fprintf(stderr, "Just did op %d\n", fixme_ops);
|
||
|
|
}
|
||
|
|
fixme_ops++;*/
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* ========== Initialization of internal keywords ========== */
|
||
|
|
|
||
|
|
void kscm__mk_syntax(kscm_t* kscm, unsigned short op, const char *name)
|
||
|
|
{
|
||
|
|
kscm_object_t x;
|
||
|
|
|
||
|
|
x = kscm__cons(kscm, kscm__mk_string(kscm, name), kscm->NIL);
|
||
|
|
kscm__type(kscm, x) = (KSCM_T_SYNTAX | KSCM_T_SYMBOL);
|
||
|
|
kscm__syntaxnum(kscm, x) = op;
|
||
|
|
kscm->oblist = kscm__cons(kscm, x, kscm->oblist);
|
||
|
|
}
|
||
|
|
|
||
|
|
void kscm__mk_proc(kscm_t* kscm, unsigned short op, const char *name)
|
||
|
|
{
|
||
|
|
kscm_object_t x, y;
|
||
|
|
|
||
|
|
x = kscm__mk_symbol(kscm, name);
|
||
|
|
y = kscm__get_cell(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
kscm__type(kscm, y) = (KSCM_T_PROC | KSCM_T_ATOM);
|
||
|
|
kscm__ivalue(kscm, y) = (long)op;
|
||
|
|
kscm__car(kscm, kscm->global_env) = kscm__cons(kscm, kscm__cons(kscm, x, y), kscm__car(kscm, kscm->global_env));
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
void kscm__init_vars_global(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
kscm_object_t x;
|
||
|
|
|
||
|
|
/* init input/output file */
|
||
|
|
kscm->inputs[kscm->inputtop] = stdin;
|
||
|
|
kscm->outfp = stdout;
|
||
|
|
/* init kscm->NIL */
|
||
|
|
kscm__type(kscm, kscm->NIL) = (KSCM_T_ATOM | KSCM_MARK);
|
||
|
|
kscm__car(kscm, kscm->NIL) = kscm__cdr(kscm, kscm->NIL) = kscm->NIL;
|
||
|
|
/* init T */
|
||
|
|
kscm__type(kscm, kscm->T) = (KSCM_T_ATOM | KSCM_MARK);
|
||
|
|
kscm__car(kscm, kscm->T) = kscm__cdr(kscm, kscm->T) = kscm->T;
|
||
|
|
/* init F */
|
||
|
|
kscm__type(kscm, kscm->F) = (KSCM_T_ATOM | KSCM_MARK);
|
||
|
|
kscm__car(kscm, kscm->F) = kscm__cdr(kscm, kscm->F) = kscm->F;
|
||
|
|
/* init global_env */
|
||
|
|
kscm->global_env = kscm__cons(kscm, kscm->NIL, kscm->NIL);
|
||
|
|
/* init else */
|
||
|
|
x = kscm__mk_symbol(kscm, "else");
|
||
|
|
kscm__car(kscm, kscm->global_env) = kscm__cons(kscm, kscm__cons(kscm, x, kscm->T), kscm__car(kscm, kscm->global_env));
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
void kscm__init_syntax(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
/* init syntax */
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_LAMBDA, "lambda");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_QUOTE, "quote");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_DEF0, "define");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_IF0, "if");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_BEGIN, "begin");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_SET0, "set!");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_LET0, "let");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_LET0AST, "let*");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_LET0REC, "letrec");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_COND0, "cond");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_DELAY, "delay");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_AND0, "and");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_OR0, "or");
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_C0STREAM, "cons-stream");
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_0MACRO, "macro");
|
||
|
|
#endif
|
||
|
|
kscm__mk_syntax(kscm, KSCM_OP_CASE0, "case");
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
void kscm__init_procs(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
/* init procedure */
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_PEVAL, "eval");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_PAPPLY, "apply");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONTINUATION, "call-with-current-continuation");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_FORCE, "force");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CAR, "car");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CDR, "cdr");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONS, "cons");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_SETCAR, "set-car!");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_SETCDR, "set-cdr!");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ADD, "+");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_SUB, "-");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_MUL, "*");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_DIV, "/");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_REM, "remainder");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NOT, "not");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BOOL, "boolean?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_SYMBOL, "symbol?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NUMBER, "number?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_STRING, "string?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_PROC, "procedure?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_PAIR, "pair?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_EQV, "eqv?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_EQ, "eq?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NULL, "null?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ZEROP, "zero?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_POSP, "positive?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NEGP, "negative?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NEQ, "=");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_LESS, "<");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_GRE, ">");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_LEQ, "<=");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_GEQ, ">=");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_READ, "read");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_WRITE, "write");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_DISPLAY, "display");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NEWLINE, "newline");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_LOAD, "load");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ERR0, "error");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_REVERSE, "reverse");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_APPEND, "append");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_PUT, "put");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_GET, "get");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_GC, "gc");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_GCVERB, "gc-verbose");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_NEWSEGMENT, "new-segment");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_LIST_LENGTH, "list-length"); /* a.k */
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ASSQ, "assq"); /* a.k */
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_PRINT_WIDTH, "print-width"); /* a.k */
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_GET_CLOSURE, "get-closure-code"); /* a.k */
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CLOSUREP, "closure?"); /* a.k */
|
||
|
|
#ifdef KSCM_CONFIG_USE_MACRO
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_MACROP, "macro?"); /* a.k */
|
||
|
|
#endif
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_STRCAT, "string-cat");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_STRLEN, "string-length");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_STRGET, "string-get");
|
||
|
|
#ifdef KSCM_CONFIG_USE_PERSIST
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_SAVE_STATE, "save-state");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_RESUME_STATE, "resume-state");
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_STRUCTS
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER, "buffer?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER_NEW, "buffer-new");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER_LEN, "buffer-length");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER_GET, "buffer-get");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER_SET, "buffer-set!");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION, "abstraction?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION_NEW, "abstraction-new");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION_TYPE, "abstraction-type");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_ABSTRACTION_VALUE, "abstraction-value");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER_LOAD, "buffer-load");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_BUFFER_SAVE, "buffer-save");
|
||
|
|
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONSOLE_MODE, "console-mode");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONSOLE_NEXT, "console-next");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONSOLE_POLL, "console-poll");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONSOLE_WIDTH, "console-width");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_CONSOLE_HEIGHT, "console-height");
|
||
|
|
#endif
|
||
|
|
#ifdef KSCM_CONFIG_USE_OBJECTS
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_OBJECT, "object?");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_OBJECT_NEW, "object-new");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_OBJECT_LEN, "object-length");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_OBJECT_GET, "object-get");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_OBJECT_SET, "object-set!");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_OBJECT_RETYPE, "object-retype!");
|
||
|
|
/* NOTE: There is no object-type function, the abstraction-type function handles all custom-typed values. */
|
||
|
|
#endif
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_SYMBOL_TO_STRING, "symbol->string");
|
||
|
|
kscm__mk_proc(kscm, KSCM_OP_QUIT, "quit");
|
||
|
|
}
|
||
|
|
|
||
|
|
|
||
|
|
/* initialize several globals */
|
||
|
|
void kscm__init_globals(kscm_t* kscm)
|
||
|
|
{
|
||
|
|
kscm__init_vars_global(kscm);
|
||
|
|
kscm__init_syntax(kscm);
|
||
|
|
kscm__init_procs(kscm);
|
||
|
|
/* intialization of global pointers to special symbols */
|
||
|
|
kscm->LAMBDA = kscm__mk_symbol(kscm, "lambda");
|
||
|
|
kscm->QUOTE = kscm__mk_symbol(kscm, "quote");
|
||
|
|
#ifdef KSCM_CONFIG_USE_QQUOTE
|
||
|
|
kscm->QQUOTE = kscm__mk_symbol(kscm, "quasiquote");
|
||
|
|
kscm->UNQUOTE = kscm__mk_symbol(kscm, "unquote");
|
||
|
|
kscm->UNQUOTESP = kscm__mk_symbol(kscm, "unquote-splicing");
|
||
|
|
#endif
|
||
|
|
|
||
|
|
}
|
||
|
|
|
||
|
|
/* ========== Error ========== */
|
||
|
|
|
||
|
|
void kscm__fatal_error(kscm_t* kscm, const char *fmt, const char *a, const char *b, const char *c)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "Fatal error: ");
|
||
|
|
fprintf(stderr, fmt, a, b, c);
|
||
|
|
fprintf(stderr, "\n");
|
||
|
|
exit(1);
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_CONFIG_USE_SETJMP
|
||
|
|
void kscm__error(kscm_t* kscm, const char *fmt, const char *a, const char *b, const char *c)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "Error: ");
|
||
|
|
fprintf(stderr, fmt, a, b, c);
|
||
|
|
fprintf(stderr, "\n");
|
||
|
|
kscm__resetinput(kscm);
|
||
|
|
longjmp(kscm->error_jmp, KSCM_OP_T0LVL);
|
||
|
|
}
|
||
|
|
|
||
|
|
#endif
|
||
|
|
|
||
|
|
/* ========== Main ========== */
|
||
|
|
|
||
|
|
#ifdef CMDLINE
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
#else
|
||
|
|
int main()
|
||
|
|
#endif
|
||
|
|
{
|
||
|
|
short i;
|
||
|
|
short op = (short)KSCM_OP_LOAD;
|
||
|
|
|
||
|
|
#ifdef CMDLINE
|
||
|
|
for (i = 1; i < argc; i++) {
|
||
|
|
if (strcmp(argv[i], "-e") == 0) {
|
||
|
|
all_errors_fatal = 1;
|
||
|
|
}
|
||
|
|
else if (strcmp(argv[i], "-q") == 0) {
|
||
|
|
quiet = 1;
|
||
|
|
}
|
||
|
|
}
|
||
|
|
#endif
|
||
|
|
|
||
|
|
kscm_t* kscm = (kscm_t*) calloc(1, sizeof(kscm_t));
|
||
|
|
kscm->cell_seg = calloc(KSCM_CONFIG_CELL_NSEGMENT, sizeof(kscm_object_t));
|
||
|
|
kscm->gcstate = calloc(4000, sizeof(kscm_gcstate_t));
|
||
|
|
kscm->gcstate_max = 4000;
|
||
|
|
|
||
|
|
if (!kscm->quiet)
|
||
|
|
printf(KSCM_CONFIG_BANNER);
|
||
|
|
kscm__init_scheme(kscm);
|
||
|
|
kscm->args = kscm__cons(kscm, kscm__mk_string(kscm, KSCM_CONFIG_INITFILE), kscm->NIL);
|
||
|
|
#ifdef KSCM_CONFIG_USE_SETJMP
|
||
|
|
op = setjmp(kscm->error_jmp);
|
||
|
|
#endif
|
||
|
|
kscm__eval_cycle(kscm, op);
|
||
|
|
exit(0);
|
||
|
|
}
|
||
|
|
|
||
|
|
#ifdef KSCM_PLUSPLUS
|
||
|
|
}
|
||
|
|
#endif
|