#console
includepath "$\inc\"
'$filename "OxyLISP.exe"
'include "Rtl32.inc"
include "Console.inc"
indexbase 0
// C COMPATIBLE STUFF
' =================== setjmp/longjmp ======================
'/*
' * The buffer used by setjmp to store the information used by longjmp
' * to perform it's evil goto-like work. The size of this buffer was
' * determined through experimentation; it's contents are a mystery.
' * NOTE: This was determined on an i386 (actually a Pentium). The
' * contents could be different on an Alpha or something else.
' */
#define _JBLEN 16
#define _JBTYPE int
// typedef _JBTYPE jmp_buf[_JBLEN]
'/*
'* The function provided by CRTDLL which appears to do the actual work
'* of setjmp.
'*/
! function _setjmp cdecl lib "msvcrt.dll" (DWORD jmp_buf) as int
#define setjmp(x) _setjmp(x)
'/*
'* Return to the last setjmp call and act as if setjmp had returned
'* nVal (which had better be non-zero!).
'*/
! sub longjmp cdecl lib "msvcrt.dll" (DWORD jmp_buf, int i)
' =========================================================
type FILE
char* _ptr
int _cnt
char* _base
int _flag
int _file
int _charbuf
int _bufsiz
char* _tmpfname
end type
extern cdecl lib "msvcrt.dll" // 32 bits only regardless of "sys"!!!
! __p__iob () as sys
! _open_osfhandle (sys a, b) as sys
! _fdopen (sys a, char* b) as sys
! setvbuf (sys a, char* b, sys c, d)
// ----------------------------------------------
! fprintf (sys a, char* b, ...)
! fgets (sys a, b, c) as sys
! fputs (sys a, b)
! feof (sys a) as sys
! fclose (sys a)
// ----------------------------------------------
! printf (char* a, ...)
! sprintf (char* a, b, ...)
! sscanf (char* a, b, ...)
// ----------------------------------------------
! malloc (sys a) as sys
! memcpy (sys a, b, c)
// ----------------------------------------------
! strcmp (char* a, b) as sys
! strcpy (char* a, b) as sys
! strlwr (char* a) as sys
// ----------------------------------------------
! isdigit (int a) as sys
! isspace (int a) as sys
// ----------------------------------------------
! atof (char* a) as double
! _atoi64 (char* a) ' returns __i64, not quad!!!
end extern
#define _IONBF &H4
#define _O_TEXT &H4000
#define STDIN_FILENO 0
#define STDOUT_FILENO 1
#define STDERR_FILENO 2
#define stdin @_iob[STDIN_FILENO]
#define stdout @_iob[STDOUT_FILENO]
#define stderr @_iob[STDERR_FILENO]
FILE* _iob = @(__p__iob())
sys hCrt = _open_osfhandle(ConsIn, _O_TEXT)
sys hf = _fdopen(hCrt, "r")
memcpy stdin, hf, sizeof(FILE)
setvbuf stdin, NULL, _IONBF, 0
hCrt = _open_osfhandle(ConsOut, _O_TEXT)
hf = _fdopen(hCrt, "w")
memcpy stdout, hf, sizeof(FILE)
setvbuf stdout, NULL, _IONBF, 0
ConsErr = GetStdHandle STD_ERROR_HANDLE // not gotten in Console.inc!!!
hCrt = _open_osfhandle(ConsErr, _O_TEXT)
hf = _fdopen(hCrt, "w")
memcpy stderr, hf, sizeof(FILE)
setvbuf stderr, NULL, _IONBF, 0
// NANOSCHEME PROPER
//#define VERBOSE
#define USE_SETJMP
#define BACKQUOTE 0x60
'/*
'* Basic memory allocation units
'*/
#define CELL_SEGSIZE 5000 /* # of cells in one segment */
#define CELL_NSEGMENT 100 /* # of segments for cells */
#define STR_SEGSIZE 2500 /* bytes of one string segment */
#define STR_NSEGMENT 100 /* # of segments for strings */
#define banner "===========================" & cr & "OxySCHEME Interpreter Alpha" & cr & "===========================" & cr & cr
#define prompt "> "
#define InitFile "nsinit.scm"
#define FIRST_CELLSEGS 3
'/* cell structure */
type cell
sys _A // placeholder
sys _B // placeholder
sys _flag
end type
#define T_STRING 1 /* 0000000000000001 */
#define T_NUMBER 2 /* 0000000000000010 */
#define T_SYMBOL 4 /* 0000000000000100 */
#define T_SYNTAX 8 /* 0000000000001000 */
#define T_PROC 16 /* 0000000000010000 */
#define T_PAIR 32 /* 0000000000100000 */
#define T_CLOSURE 64 /* 0000000001000000 */
#define T_CONTINUATION 128 /* 0000000010000000 */
#define T_MACRO 256 /* 0000000100000000 */
#define T_PROMISE 512 /* 0000001000000000 */
#define T_ATOM 16384 /* 0100000000000000 *//* only for gc */
#define CLRATOM 114687 /* 11011111111111111 *//* only for gc */
#define MARK 32768 /* 01000000000000000 */
#define UNMARK 98303 /* 10111111111111111 */
#define T_FIXNUM T_NUMBER
#define T_FLONUM 65538 /* 10000000000000010 *//* also implies T_NUMBER */
'/* macros for cell operations */
// #define ctype(p) p##._flag
#define ctype(p) *(c + sizeof(sys) + sizeof(sys))
#define isstring(p) (ctype(p) & T_STRING)
// #define strvalue(p) p##._svalue
// #define keynum(p) p##._keynum
#define strvalue(p) cast string* c
#define keynum(p) *(c + sizeof(sys))
// #define ivalue(p) p##._ivalue
// #define rvalue(p) p##._rvalue
#define ivalue(p) cast quad* c
#define rvalue(p) cast double* c
#define isnumber(p) (ctype(p) & T_NUMBER)
#define isfixnum(p) ((ctype(p) & T_FLONUM) == T_FIXNUM)
#define isflonum(p) ((ctype(p) & T_FLONUM) == T_FLONUM)
#define isflint(p) ((quad)rvalue(p) == rvalue(p))
// #define num_ivalue(p) (isfixnum(p) ? ivalue(p) : (__int64)rvalue(p))
// #define num_rvalue(p) (isflonum(p) ? rvalue(p) : (double)ivalue(p))
quad num_ivalue(sys p) at num_ivalue_asm
double num_rvalue(sys p) at num_rvalue_asm
#define ispair(p) (ctype(p) & T_PAIR)
// #define car(p) p##._car
// #define cdr(p) p##._cdr
#define car(p) *c
#define cdr(p) *(c + sizeof(sys))
#define issymbol(p) (ctype(p) & T_SYMBOL)
#define symname(p) strvalue(car(p))
#define hasprop(p) (ctype(p) & T_SYMBOL)
#define symprop(p) cdr(p)
#define issyntax(p) (ctype(p) & T_SYNTAX)
#define isproc(p) (ctype(p) & T_PROC)
#define syntaxname(p) strvalue(car(p))
#define syntaxnum(p) keynum(car(p))
#define procnum(p) ivalue(p)
#define isclosure(p) (ctype(p) & T_CLOSURE)
#define ismacro(p) (ctype(p) & T_MACRO)
#define closure_code(p) car(p)
#define closure_env(p) cdr(p)
#define iscontinuation(p) (ctype(p) & T_CONTINUATION)
#define cont_dump(p) cdr(p)
#define ispromise(p) (ctype(p) & T_PROMISE)
#define setpromise(p) ctype(p) |= T_PROMISE
#define isatom(p) (ctype(p) & T_ATOM)
#define setatom(p) ctype(p) |= T_ATOM
#define clratom(p) ctype(p) &= CLRATOM
#define ismark(p) (ctype(p) & MARK)
#define setmark(p) ctype(p) |= MARK
#define clrmark(p) ctype(p) &= UNMARK
#define backchar() currentline--
#define clearinput() currentline = endline = linebuff
#define caar(p) car(car(p))
#define cadr(p) car(cdr(p))
#define cdar(p) cdr(car(p))
#define cddr(p) cdr(cdr(p))
#define cadar(p) car(cdr(car(p)))
#define caddr(p) car(cdr(cdr(p)))
#define cadaar(p) car(cdr(car(car(p))))
#define cadddr(p) car(cdr(cdr(cdr(p))))
#define cddddr(p) cdr(cdr(cdr(cdr(p))))
'/* token types */
enum TOKS (
TOK_EOF = -1,
TOK_LPAREN = 0,
TOK_RPAREN,
TOK_DOT,
TOK_ATOM,
TOK_QUOTE,
TOK_COMMENT,
TOK_DQUOTE,
TOK_BQUOTE,
TOK_COMMA,
TOK_ATMARK,
TOK_SHARP
)
'/* operator codes */
enum OPS (
OP_LOAD = 0,
OP_T0LVL,
OP_T1LVL,
OP_READ,
OP_VALUEPRINT,
OP_EVAL,
OP_E0ARGS,
OP_E1ARGS,
OP_APPLY,
OP_DOMACRO,
OP_LAMBDA,
OP_QUOTE,
OP_DEF0,
OP_DEF1,
OP_BEGIN,
OP_IF0,
OP_IF1,
OP_SET0,
OP_SET1,
OP_LET0,
OP_LET1,
OP_LET2,
OP_LET0AST,
OP_LET1AST,
OP_LET2AST,
OP_LET0REC,
OP_LET1REC,
OP_LET2REC,
OP_COND0,
OP_COND1,
OP_DELAY,
OP_AND0,
OP_AND1,
OP_OR0,
OP_OR1,
OP_C0STREAM,
OP_C1STREAM,
OP_0MACRO,
OP_1MACRO,
OP_CASE0,
OP_CASE1,
OP_CASE2,
OP_PEVAL,
OP_PAPPLY,
OP_CONTINUATION,
OP_ADD,
OP_SUB,
OP_MUL,
OP_DIV,
OP_REM,
OP_CAR,
OP_CDR,
OP_CONS,
OP_SETCAR,
OP_SETCDR,
OP_NOT,
OP_BOOL,
OP_NULL,
OP_ZEROP,
OP_POSP,
OP_NEGP,
OP_NEQ,
OP_LESS,
OP_GRE,
OP_LEQ,
OP_GEQ,
OP_SYMBOL,
OP_NUMBER,
OP_STRING,
OP_PROC,
OP_PAIR,
OP_EQ,
OP_EQV,
OP_FORCE,
OP_WRITE,
OP_DISPLAY,
OP_NEWLINE,
OP_ERR0,
OP_ERR1,
OP_REVERSE,
OP_APPEND,
OP_PUT,
OP_GET,
OP_QUIT,
OP_GC,
OP_GCVERB,
OP_NEWSEGMENT,
OP_RDSEXPR,
OP_RDLIST,
OP_RDDOT,
OP_RDQUOTE,
OP_RDQQUOTE,
OP_RDUNQUOTE,
OP_RDUQTSP,
OP_P0LIST,
OP_P1LIST,
OP_LIST_LENGTH,
OP_ASSQ,
OP_PRINT_WIDTH,
OP_P0_WIDTH,
OP_P1_WIDTH,
OP_GET_CLOSURE,
OP_CLOSUREP,
OP_MACROP
)
'/* arrays for segments */
sys cell_seg[CELL_NSEGMENT]
sys last_cell_seg = -1
char* str_seg[STR_NSEGMENT]
sys str_seglast = -1
'/* We use 4 registers. */
sys args '/* register for arguments of function */
sys envir '/* stack register for current environment */
sys code '/* register for current code */
sys dump '/* stack register for next evaluation */
cell _NIL
sys NIL = @_NIL '/* special cell representing empty cell */
cell _T
sys T = @_T '/* special cell representing #t */
cell _F
sys F = @_F '/* special cell representing #f */
cell _EOF_OBJ
sys EOF_OBJ = @_EOF_OBJ '/* special cell representing EOF */
sys oblist = @_NIL '/* pointer to symbol table */
sys global_env '/* pointer to global environment */
'/* global pointers to special symbols */
sys LAMBDA '/* pointer to syntax lambda */
sys QUOTE '/* pointer to syntax quote */
sys QQUOTE '/* pointer to symbol quasiquote */
sys UNQUOTE '/* pointer to symbol unquote */
sys UNQUOTESP '/* pointer to symbol unquote-splicing */
sys free_cell = @_NIL '/* pointer to top of free cells */
sys fcells = 0 '/* # of free cells */
FILE* infp '/* input file */
FILE* outfp '/* output file */
#ifdef USE_SETJMP
_JBTYPE error_jmp[_JBLEN]
#endif
char gc_verbose '/* if gc_verbose is not zero, print gc status */
FILE* tmpfp
sys tok
sys print_flag
sys value
sys operator
// helper funcs
! ExitProcess lib "kernel32.dll" (DWORD uExitCode)
// forward declarations
! sub init_globals ()
! sub gc (sys a, b)
! sub flushinput ()
! sys isnotdelim (char* s, char c)
! quad atoll (char* a) at atoll_asm
sub init_globals()
'
end sub
sub gc()
'
end sub
sub flushinput()
'
end sub
function isnotdelim(char* s, char c) as sys
'
end function
// Oxygen Specific Macros
.num_ivalue_asm ' 32 bits only!
mov eax, [esp + 4] ' first param 'pointer'
(
mov ecx, T_FLONUM
and ecx, [eax + 8]
cmp ecx, T_FIXNUM
jnz exit
fild qword [eax]
ret 4
)
fld qword [eax]
frndint ' rounding makes it much slower than .num_rvalue_asm below
ret 4
.num_rvalue_asm ' 32 bits only!
mov eax, [esp + 4] ' first param 'pointer'
(
mov ecx, T_FLONUM
and ecx, [eax + 8]
cmp ecx, T_FLONUM
jnz exit
fld qword [eax]
ret 4
)
fild qword [eax]
ret 4
.atoll_asm ' 32 bits only!
push [esp + 4] ' char*
call _atoi64 ' returns __i64, not quad!
push edx
push eax
fild qword [esp]
add esp, 12 ' +4 for cdecl
ret 4
