diff --git a/doc/DRAWL.md b/doc/DRAWL.md index 9539754..75e52be 100644 --- a/doc/DRAWL.md +++ b/doc/DRAWL.md @@ -4,7 +4,6 @@ LISP interpreted on a bytecode VM running on a 1 MHz 6502 is going to be sssllll ## Missing features of LISP 1.5 in DRAWL -- FUNCTION operation. Use QUOTE for functions that don't use higher up bound variables - General recursion. The 6502 architecture limits recursion (but see tail recursion below), so don't expect too much here However, the code is partitioned to allow for easy extension so some of these missing features could be implemented. @@ -17,6 +16,8 @@ However, the code is partitioned to allow for easy extension so some of these mi - Optionally read LISP source file at startup - The PROG feature now present! - Arrays of up to four dimensions +- FUNCTION operation with bound variables +- Additional testing/looping construct: IF, FOR, WHILE, UNTIL LISP is one of the earliest computer languages. As such, it holds a special place in the anals of computer science. I've always wanted to learn why LISP is held in such high regard by so many, so I went about learning LISP by actually implementing a LISP interpreter in PLASMA. PLASMA is well suited to implement other languages due to its rich syntax, performance and libraries. diff --git a/src/lisp/drawl.pla b/src/lisp/drawl.pla index d9e5aee..7be627d 100644 --- a/src/lisp/drawl.pla +++ b/src/lisp/drawl.pla @@ -16,6 +16,7 @@ import sexpr const ARRAY_TYPE = $40 const MARK_BIT = $80 const MARK_MASK = $7F + const NULL_HACK = 1 // Hack so we can set elements to NULL struc t_elem word link @@ -46,7 +47,6 @@ import sexpr predef new_int(intlo, inthi)#1 predef new_sym(symstr)#1 predef new_assoc(symptr, valptr)#0 - predef set_assoc(symptr, valptr)#0 predef print_expr(expr)#0 predef parse_expr(evalptr, level, refill)#2 predef eval_expr(expr)#1 @@ -59,7 +59,7 @@ import smath end var prog, prog_expr, prog_return // Current PROG expressions -var sym_cond, sym_fpint, sym_fpfrac +var sym_cond, sym_if, sym_fpint, sym_fpfrac var pred_true const FILEBUF_SIZE = 128 @@ -99,6 +99,13 @@ def natv_prog(symptr, expr) fin cond_expr = cond_expr=>cdr loop + elsif prog_car=>car == sym_if // Inline if() evaluation + cond_expr = prog_car=>cdr + if eval_expr(cond_expr=>car) + eval_expr(cond_expr=>cdr=>car) // Drop result + elsif cond_expr=>cdr=>cdr=>car + eval_expr(cond_expr=>cdr=>cdr=>car) // Drop result + fin else eval_expr(prog_car) // Drop result fin @@ -108,8 +115,10 @@ def natv_prog(symptr, expr) // fin loop - prog = prog_enter - return eval_expr(prog_return) + prog = prog_enter + expr = eval_expr(prog_return) + prog_return = FALSE + return expr end def natv_return(symptr, expr) @@ -136,21 +145,15 @@ end // def natv_fpint(symptr, expr) - var fmt - fmt_fpint = eval_int(expr)=>intval - fmt = new_int(fmt_fpint, 0) - set_assoc(sym_fpint, fmt) - return fmt + sym_fpint=>apval = fmt_fpint ^ NULL_HACK + return sym_fpint end def natv_fpfrac(symptr, expr) - var fmt - fmt_fpfrac = eval_int(expr)=>intval - fmt = new_int(fmt_fpfrac, 0) - set_assoc(sym_fpfrac, fmt) - return fmt + sym_fpfrac=>apval = fmt_fpfrac ^ NULL_HACK + return sym_fpfrac end def natv_gc(symptr, expr) @@ -251,19 +254,20 @@ end // puts("DRAWL (LISP 1.5) symbolic processor\n") -pred_true = bool_pred(TRUE) // Capture value of TRUE -sym_fpint = new_sym("FMTFPI") -sym_fpfrac = new_sym("FMTFPF") -sym_fpint=>natv = @natv_fpint -sym_fpfrac=>natv = @natv_fpfrac -new_assoc(sym_fpint, new_int(fmt_fpint, 0)) -new_assoc(sym_fpfrac, new_int(fmt_fpfrac, 0)) -sym_cond = new_sym("COND") // This should actually match COND +pred_true = bool_pred(TRUE) // Capture value of TRUE +sym_fpint = new_sym("FMTFPI") +sym_fpfrac = new_sym("FMTFPF") +sym_fpint=>natv = @natv_fpint +sym_fpfrac=>natv = @natv_fpfrac +sym_fpint=>apval = new_int(fmt_fpint, 0) ^ NULL_HACK +sym_fpfrac=>apval = new_int(fmt_fpfrac, 0) ^ NULL_HACK +sym_cond = new_sym("COND") // This should actually match COND +sym_if = new_sym("IF") // This should actually match IF new_sym("PROG")=>natv = @natv_prog new_sym("GO")=>natv = @natv_go new_sym("RETURN")=>natv = @natv_return new_sym("GC")=>natv = @natv_gc -new_sym("QUIT")=>natv = @natv_bye +new_sym("QUIT")=>natv = @natv_bye parse_cmdline while not quit diff --git a/src/lisp/loop.lisp b/src/lisp/loop.lisp index 9a582df..282fe7f 100644 --- a/src/lisp/loop.lisp +++ b/src/lisp/loop.lisp @@ -10,11 +10,11 @@ (PRINTLN 'TAIL) (LOOP 1 100 LPRINT) -(PRINTLN 'FOR) +(PRINT 'FOR) (FOR I 1 1 (< I 100) (PRINT I)) -(PRINTLN 'WHILE) -(SETQ N 0) -(WHILE (< N 100) (PRINT N) (SETQ N (+ N 1))) -(PRINTLN 'UNTIL) -(SETQ N 1) -(UNTIL (> N 99) (PRINT N) (SETQ N (+ N 1))) +(PRINT 'WHILE) +(CSETQ I 0) +(WHILE (< I 100) (PRINT I) (CSETQ I (+ I 1))) +(PRINT 'UNTIL) +(CSETQ I 1) +(UNTIL (> I 99) (PRINT I) (CSETQ I (+ I 1))) diff --git a/src/lisp/maplist.lisp b/src/lisp/maplist.lisp index da7681a..0537a49 100644 --- a/src/lisp/maplist.lisp +++ b/src/lisp/maplist.lisp @@ -1,7 +1,7 @@ (define (ydot (lambda (x y) - (maplist x '(lambda (j) (cons (car j) y))) + (maplist x (function (lambda (j) (cons (car j) y)))) ) ) (maplist diff --git a/src/lisp/prog.lisp b/src/lisp/prog.lisp index c10a504..3e18e62 100644 --- a/src/lisp/prog.lisp +++ b/src/lisp/prog.lisp @@ -1,11 +1,22 @@ -(label length (lambda (l) - (prog (u v) - (setq v 0) - (setq u l) - a (cond ((null u),(return v))) - (setq u (cdr u)) - (setq v (+ 1 v)) - (go a) - ) +(label lengthc (lambda (l) + (prog (u v) + (setq v 0) + (setq u l) + a (cond ((null u),(return v))) + (setq v (+ 1 v)) + (setq u (cdr u)) + (go a) + ) + ) +) + +(label lengthi (lambda (l) + (prog (u v) + (setq v 0) + (setq u l) + a (if (null u) (return v) (setq v (+ 1 v))) + (setq u (cdr u)) + (go a) + ) ) ) diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index 3bc36bf..4772a72 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -13,7 +13,6 @@ const NUM_TYPE = $30 const NUM_INT = $31 const NUM_FLOAT = $32 const ARRAY_TYPE = $40 -const FUNC_TYPE = $50 const MARK_BIT = $80 const MARK_MASK = $7F const NULL_HACK = 1 // Hack so we can set elements to NULL @@ -27,21 +26,14 @@ struc t_cons word car word cdr end -struc t_func +struc t_sym res[t_elem] word natv word lambda -end -struc t_sym - res[t_func] word array word apval char name[0] end -struc t_funcenv - res[t_func] - word environ -end struc t_numint res[t_elem] word intval[2] @@ -62,19 +54,18 @@ const fmt_fp = FPSTR_FIXED|FPSTR_STRIP|FPSTR_FLEX export var fmt_fpint = 6 export var fmt_fpfrac = 4 -var assoc_list = NULL // Local SYM->value association list -var global_list = NULL // Global SYM->value association list +byte prhex = FALSE // Hex output flag for integers + +var assoc_list = NULL // SYM->value association list var cons_list = NULL var cons_free = NULL var int_list = NULL var int_free = NULL var float_list = NULL var float_free = NULL -var func_list = NULL -var func_free = NULL var sym_list = NULL -var sym_nil, sym_quote, sym_lambda, sym_set +var sym_nil, sym_quote, sym_lambda, sym_funarg, sym_set var sym_cond, sym_if, sym_for, sym_space, sym_cr res[t_elem] pred_true = 0, 0, BOOL_TRUE predef print_expr(expr)#0 @@ -82,6 +73,10 @@ predef eval_expr(expr)#1 // // Garbage collector +// - note, anytime eval_expr is called there is the possibility of +// garbage collecting. If there are any in-flight elements (cons, +// int, float) they may be collected and returned to the free list. +// Use the sweep_stack to temporarily keep a reference to these elements. // const SWEEPSTACK_MAX = 64 @@ -104,7 +99,6 @@ def mark_elems#0 mark_list(cons_list) mark_list(int_list) mark_list(float_list) - mark_list(func_list) end def sweep_expr(expr)#0 @@ -123,7 +117,6 @@ end def sweep_used#0 var symptr, i, memptr, size - sweep_expr(global_list) sweep_expr(assoc_list) sweep_expr(eval_last) symptr = sym_list @@ -205,7 +198,6 @@ def collect_unused#0 cons_list, cons_free = collect_list(cons_list, cons_free) int_list, int_free = collect_list(int_list, int_free) float_list, float_free = collect_list(float_list, float_free) - func_list, func_free = collect_list(func_list, func_free) end export def gc#0 @@ -272,25 +264,6 @@ export def new_float(extptr)#1 return floatptr end -def new_func - var funcptr - - if func_free - funcptr = func_free - func_free = func_free=>link - else - gc_pull++ - funcptr = heapalloc(t_func) - fin - funcptr=>link = func_list - func_list = funcptr - funcptr->type = FUNC_TYPE - funcptr=>natv = NULL - funcptr=>lambda = NULL - funcptr=>environ = NULL - return funcptr -end - def new_array(dim0, dim1, dim2, dim3) var ofst0, ofst1, ofst2, ofst3 var size, aptr, memptr @@ -390,8 +363,13 @@ def print_atom(atom)#0 is NUM_TYPE when atom->type is NUM_INT - if atom=>intval[1] >= 0; putc(' '); fin // Add space for pos - puti32(atom + intval) + if prhex + putc('$') + puth(atom=>intval[1]); puth(atom=>intval[0]) + else + if atom=>intval[1] >= 0; putc(' '); fin // Add space for pos + puti32(atom + intval) + fin break is NUM_FLOAT puts(ext2str(atom + floatval, @prstr, fmt_fpint, fmt_fpfrac, fmt_fp)) @@ -439,14 +417,6 @@ def print_atom(atom)#0 next puts("]\n") break - is FUNC_TYPE - puts("FUNCTION:\n") - if atom=>natv; puts("NATV") - elsif atom=>lambda; print_expr(atom=>lambda) - else puts("???") - fin - puts("\nENVIRON:\n"); print_expr(atom=>environ); putln - break otherwise puts("Unknown atom type: $"); putb(atom->type); putln wend @@ -485,6 +455,12 @@ end def is_num(cptr) if ^cptr == '-' or ^cptr == '+'; cptr++; fin + if ^cptr == '$' + cptr++ + if toupper(^cptr) >= 'A' and toupper(^cptr) <= 'F' + return TRUE + fin + fin return ^cptr >= '0' and ^cptr <= '9' end @@ -495,7 +471,7 @@ end def parse_num(evalptr)#2 // return evalptr, intptr var startptr var int[2], ext[5] - byte sign + byte sign, h sign = FALSE if ^evalptr == '-' @@ -504,34 +480,51 @@ def parse_num(evalptr)#2 // return evalptr, intptr elsif ^evalptr == '+' evalptr++ fin - startptr = evalptr - while ^evalptr >= '0' and ^evalptr <= '9' + if ^evalptr == '$' evalptr++ - loop - if (evalptr - startptr > 10) or ^evalptr == '.' or toupper(^evalptr) == 'E' - if ^evalptr == '.' + h = toupper(^evalptr) + zero32 + while h >= '0' and h <= 'F' + if h > '9' + h = h - 'A' + 10 + if h > 16; break; fin + else + h = h - '0' + fin + muli16(16); addi16(h) evalptr++ - while ^evalptr >= '0' and ^evalptr <= '9' - evalptr++ - loop - fin - if toupper(^evalptr) == 'E' + h = toupper(^evalptr) + loop + else + startptr = evalptr + while ^evalptr >= '0' and ^evalptr <= '9' evalptr++ - if ^evalptr == '-' or ^evalptr == '+'; evalptr++; fin - while ^evalptr >= '0' and ^evalptr <= '9' + loop + if (evalptr - startptr > 10) or ^evalptr == '.' or toupper(^evalptr) == 'E' + if ^evalptr == '.' evalptr++ - loop + while ^evalptr >= '0' and ^evalptr <= '9' + evalptr++ + loop + fin + if toupper(^evalptr) == 'E' + evalptr++ + if ^evalptr == '-' or ^evalptr == '+'; evalptr++; fin + while ^evalptr >= '0' and ^evalptr <= '9' + evalptr++ + loop + fin + if sign; startptr--; fin + ^(startptr - 1) = evalptr - startptr + str2ext(startptr - 1, @ext) + return evalptr, new_float(@ext) fin - if sign; startptr--; fin - ^(startptr - 1) = evalptr - startptr - str2ext(startptr - 1, @ext) - return evalptr, new_float(@ext) + zero32 + while startptr <> evalptr + muli16(10); addi16(^startptr - '0') + startptr++ + loop fin - zero32 - while startptr <> evalptr - muli16(10); addi16(^startptr - '0') - startptr++ - loop if sign; neg32; fin store32(@int) return evalptr, new_int(int[0], int[1]) @@ -653,27 +646,19 @@ end // export def new_assoc(symptr, valptr)#0 - var pair, addlist + var pair, pairlist if symptr and (symptr->type & TYPE_MASK <> SYM_TYPE) puts("Not a SYM in new_assoc\n") return fin - pair = new_cons - pair=>car = symptr - pair=>cdr = valptr - if global_list // Add to end of global_list - addlist = global_list - while addlist=>cdr - addlist = addlist=>cdr - loop - addlist=>cdr = new_cons - addlist = addlist=>cdr - else // New list - global_list = new_cons - addlist = global_list - fin - addlist=>car = pair + pair = new_cons + pair=>car = symptr + pair=>cdr = valptr + pairlist = new_cons + pairlist=>car = pair + pairlist=>cdr = assoc_list + assoc_list = pairlist end def assoc_pair(symptr) @@ -689,20 +674,10 @@ def assoc_pair(symptr) fin pair = pair=>cdr loop - // - // Search global association list for symbol - // - pair = global_list - while pair - if (pair=>car=>car == symptr) - return pair=>car - fin - pair = pair=>cdr - loop return NULL // SYM not associated end -export def set_assoc(symptr, valptr)#0 +export def set_assoc(symptr, valptr)#1 var pair // @@ -711,9 +686,8 @@ export def set_assoc(symptr, valptr)#0 pair = assoc_pair(symptr) if pair pair=>cdr = valptr // Update association - else - new_assoc(symptr, valptr) // Add global association if unknown fin + return pair end def assoc(symptr) @@ -729,16 +703,6 @@ def assoc(symptr) fin pair = pair=>cdr loop - // - // Search global association list for symbol - // - pair = global_list - while pair - if (pair=>car=>car == symptr) - return pair=>car=>cdr - fin - pair = pair=>cdr - loop return NULL // SYM not associated end @@ -746,8 +710,8 @@ end // Evaluate expression // -def enter_lambda(curl, expr, params)#2 // curl, expr - var args, arglist, pairlist, parambase +def apply_args(curl, expr, argvals)#2 // curl, expr + var argsyms, arglist, pairlist, argbase if !expr or expr=>car <> sym_lambda puts("Invalid LAMBDA expression: "); print_expr(expr); putln @@ -757,35 +721,35 @@ def enter_lambda(curl, expr, params)#2 // curl, expr // Evaluate the parameters // - manipulate sweep_stack directly for performance // - parambase = sweep_stack_top - while params - sweep_stack[sweep_stack_top] = eval_expr(params=>car) + argbase = sweep_stack_top + while argvals + sweep_stack[sweep_stack_top] = eval_expr(argvals=>car) sweep_stack_top++ if sweep_stack_top >= SWEEPSTACK_MAX - puts("Parameter overflow:"); print_expr(expr); putln + puts("Arg val overflow:"); print_expr(expr); putln return NULL, NULL fin - params = params=>cdr + argvals = argvals=>cdr loop - args = expr=>cdr=>car - sweep_stack_top = parambase + argsyms = expr=>cdr=>car + sweep_stack_top = argbase if curl == expr // // Set associations // arglist = assoc_list - while args - arglist=>car=>cdr = sweep_stack[parambase] + while argsyms + arglist=>car=>cdr = sweep_stack[argbase] arglist = arglist=>cdr - args = args=>cdr - parambase++ + argsyms = argsyms=>cdr + argbase++ loop else // // Build arg list before prepending to assoc_list // arglist = NULL - while args + while argsyms // // Build argument/value pairs // @@ -797,10 +761,10 @@ def enter_lambda(curl, expr, params)#2 // curl, expr pairlist = arglist fin pairlist=>car = new_cons - pairlist=>car=>car = args=>car - pairlist=>car=>cdr = sweep_stack[parambase] - args = args=>cdr - parambase++ + pairlist=>car=>car = argsyms=>car + pairlist=>car=>cdr = sweep_stack[argbase] + argsyms = argsyms=>cdr + argbase++ loop if arglist pairlist=>cdr = assoc_list @@ -810,12 +774,64 @@ def enter_lambda(curl, expr, params)#2 // curl, expr return expr, expr=>cdr=>cdr=>car end +def eval_funarg(funarg, argvals) + var funexpr, argsyms, arglist, pairlist, argbase + + funexpr = funarg=>cdr=>car // Lambda expression + argsyms = funexpr=>cdr=>car + // + // Evaluate the parameters + // - manipulate sweep_stack directly for performance + // + argbase = sweep_stack_top + while argvals + sweep_stack[sweep_stack_top] = eval_expr(argvals=>car) + sweep_stack_top++ + if sweep_stack_top >= SWEEPSTACK_MAX + puts("Parameter overflow:"); print_expr(funexpr); putln + return NULL + fin + argvals = argvals=>cdr + loop + sweep_stack_top = argbase + // + // Build arg list before prepending to new assoc_list + // + arglist = NULL + while argsyms + // + // Build argument/value pairs + // + if arglist + pairlist=>cdr = new_cons + pairlist = pairlist=>cdr + else + arglist = new_cons + pairlist = arglist + fin + pairlist=>car = new_cons + pairlist=>car=>car = argsyms=>car + pairlist=>car=>cdr = sweep_stack[argbase] + argsyms = argsyms=>cdr + argbase++ + loop + push_sweep_stack(assoc_list) + assoc_list = funarg=>cdr=>cdr=>car // Swap associcate list pointer + if arglist + pairlist=>cdr = assoc_list + assoc_list = arglist + fin + funexpr = eval_expr(funexpr=>cdr=>cdr=>car) + funarg=>cdr=>cdr=>car = assoc_list // Save current environ + assoc_list = pop_sweep_stack + return funexpr +end + export def eval_expr(expr)#1 - var alist_enter, curl, expr_car + var curl, expr_car if gc_pull > GC_TRIGGER; gc; fin curl = NULL // Current lambda - alist_enter = assoc_list while expr if expr->type == CONS_TYPE // @@ -827,7 +843,7 @@ export def eval_expr(expr)#1 expr = expr_car=>natv(expr_car, expr=>cdr) // Native function break elsif expr_car=>lambda // DEFINEd lambda S-expression - curl, expr = enter_lambda(curl, expr_car=>lambda, expr=>cdr) + curl, expr = apply_args(curl, expr_car=>lambda, expr=>cdr) elsif expr_car == sym_cond // Inline cond() evaluation expr = expr=>cdr while expr @@ -847,11 +863,22 @@ export def eval_expr(expr)#1 expr = expr=>car fin fin - else // Symbol associated with lambda - curl, expr = enter_lambda(curl, assoc(expr_car), expr=>cdr) + else // Associated symbol + expr_car = assoc(expr_car) + if expr_car->type == CONS_TYPE + if expr_car=>car == sym_funarg + expr = eval_funarg(expr_car, expr=>cdr) + break + elsif expr_car=>car == sym_lambda + curl, expr = apply_args(NULL, expr_car, expr=>cdr) + else + puts("Unknown function:"); print_expr(expr); putln + expr = NULL + fin + fin fin elsif expr_car->type == CONS_TYPE and expr_car=>car == sym_lambda - curl, expr = enter_lambda(NULL, expr_car, expr=>cdr) // Inline lambda + curl, expr = apply_args(NULL, expr_car, expr=>cdr) // Inline lambda fin else // @@ -871,7 +898,6 @@ export def eval_expr(expr)#1 break fin loop - assoc_list = alist_enter return expr end @@ -882,6 +908,37 @@ export def eval_quote(expr)#1 return expr end +// +// Make a copy of an expr +// + +def copy_expr(expr) + var copy + + if expr and expr->type == CONS_TYPE + // + // Copy cons structure + // + copy = push_sweep_stack(new_cons) + while expr + if expr=>car and expr=>car->type == CONS_TYPE + copy=>car = copy_expr(expr=>car) + else + copy=>car = expr=>car + fin + if expr=>cdr and expr=>cdr->type == CONS_TYPE + copy=>cdr = new_cons + copy = copy=>cdr + expr = expr=>cdr + else // End of list + copy=>cdr = expr=>cdr + expr = NULL + fin + loop + return pop_sweep_stack + fin + return expr +end // // Base native functions // @@ -985,18 +1042,35 @@ end def natv_label(symptr, expr) symptr = expr=>cdr=>car - set_assoc(expr=>car, symptr) + if !set_assoc(expr=>car, symptr) + new_assoc(expr=>car, symptr) + fin return symptr end +def natv_function(symptr, expr) + var funptr + + funptr = new_cons + symptr = funptr + symptr=>car = sym_funarg + symptr=>cdr = new_cons + symptr = symptr=>cdr + symptr=>car = expr=>car + symptr=>cdr = new_cons + symptr = symptr=>cdr + symptr=>car = copy_expr(assoc_list) + return funptr +end + def natv_define(symptr, expr) - var funclist, funcptr + var deflist, funcptr - funclist = NULL + deflist = NULL if expr - funclist = new_cons - funcptr = funclist + deflist = new_cons + funcptr = deflist fin while expr symptr = expr=>car=>car @@ -1008,7 +1082,7 @@ def natv_define(symptr, expr) funcptr = funcptr=>cdr fin loop - return funclist + return deflist end def eval_index(arrayptr, expr) @@ -1116,9 +1190,10 @@ def natv_setq(symptr, expr) return symptr end -def natv_print(symptr, expr) +def natv_pri(symptr, expr) var result + result = NULL while expr if expr=>car == sym_space result = sym_space @@ -1135,8 +1210,15 @@ def natv_print(symptr, expr) return result end -def natv_println(symptr, expr) - expr = natv_print(symptr, expr) +def natv_prhex(symptr, expr) + if expr + prhex = eval_expr(expr=>car) + fin + return bool_pred(prhex) +end + +def natv_print(symptr, expr) + expr = natv_pri(symptr, expr) putln return expr end @@ -1238,39 +1320,42 @@ end // Install default functions // -new_sym("T")=>apval = @pred_true ^ NULL_HACK -new_sym("F")=>apval = NULL_HACK -sym_space = new_sym("SPACE") -sym_cr = new_sym("CR") -sym_nil = new_sym("NIL") -sym_nil=>apval = NULL_HACK -sym_lambda = new_sym("LAMBDA") -sym_cond = new_sym("COND") -sym_if = new_sym("IF") -sym_set = new_sym("SET") -sym_quote = new_sym("QUOTE") -sym_quote=>natv = @natv_quote -new_sym("CAR")=>natv = @natv_car -new_sym("CDR")=>natv = @natv_cdr -new_sym("CONS")=>natv = @natv_cons -new_sym("LIST")=>natv = @natv_list -new_sym("ATOM")=>natv = @natv_atom -new_sym("EQ")=>natv = @natv_eq -new_sym("NOT")=>natv = @natv_null -new_sym("AND")=>natv = @natv_and -new_sym("OR")=>natv = @natv_or -new_sym("NULL")=>natv = @natv_null -new_sym("LABEL")=>natv = @natv_label -new_sym("DEFINE")=>natv = @natv_define -new_sym("ARRAY")=>natv = @natv_array -new_sym("CSET")=>natv = @natv_cset -new_sym("CSETQ")=>natv = @natv_csetq -new_sym("SET")=>natv = @natv_set -new_sym("SETQ")=>natv = @natv_setq -new_sym("PRINT")=>natv = @natv_print -new_sym("PRINTLN")=>natv = @natv_println -new_sym("FOR")=>natv = @natv_for -new_sym("WHILE")=>natv = @natv_while -new_sym("UNTIL")=>natv = @natv_until +new_sym("T")=>apval = @pred_true ^ NULL_HACK +new_sym("F")=>apval = NULL_HACK +sym_space = new_sym("SPACE") +sym_cr = new_sym("CR") +sym_nil = new_sym("NIL") +sym_nil=>apval = NULL_HACK +sym_lambda = new_sym("LAMBDA") +sym_funarg = new_sym("FUNARG") +sym_cond = new_sym("COND") +sym_if = new_sym("IF") +sym_set = new_sym("SET") +sym_quote = new_sym("QUOTE") +sym_quote=>natv = @natv_quote +new_sym("CAR")=>natv = @natv_car +new_sym("CDR")=>natv = @natv_cdr +new_sym("CONS")=>natv = @natv_cons +new_sym("LIST")=>natv = @natv_list +new_sym("ATOM")=>natv = @natv_atom +new_sym("EQ")=>natv = @natv_eq +new_sym("NOT")=>natv = @natv_null +new_sym("AND")=>natv = @natv_and +new_sym("OR")=>natv = @natv_or +new_sym("NULL")=>natv = @natv_null +new_sym("FUNCTION")=>natv = @natv_function +new_sym("LABEL")=>natv = @natv_label +new_sym("DEFINE")=>natv = @natv_define +new_sym("ARRAY")=>natv = @natv_array +new_sym("CSET")=>natv = @natv_cset +new_sym("CSETQ")=>natv = @natv_csetq +new_sym("SET")=>natv = @natv_set +new_sym("SETQ")=>natv = @natv_setq +new_sym("PRI")=>natv = @natv_pri +new_sym("PRHEX")=>natv = @natv_prhex +new_sym("PRINT")=>natv = @natv_print +new_sym("FOR")=>natv = @natv_for +new_sym("WHILE")=>natv = @natv_while +new_sym("UNTIL")=>natv = @natv_until return modkeep | modinitkeep done diff --git a/src/lisp/s-math.pla b/src/lisp/s-math.pla index 3da9838..5568cdc 100644 --- a/src/lisp/s-math.pla +++ b/src/lisp/s-math.pla @@ -658,6 +658,119 @@ def natv_annuityY(symptr, expr) return new_float(@ext) end +// +// Bit-wise operations +// + +def natv_bitnot(symptr, expr) + symptr = eval_int(expr) + return new_int(~symptr=>intval[0], ~symptr=>intval[1]) +end + +def natv_bitand(symptr, expr) + var[2] bitval + + symptr = eval_int(expr) + bitval[0] = symptr=>intval[0] + bitval[1] = symptr=>intval[1] + symptr = eval_int(expr=>cdr) + return new_int(bitval[0] & symptr=>intval[0], bitval[1] & symptr=>intval[1]) +end + +def natv_bitor(symptr, expr) + var[2] bitval + + symptr = eval_int(expr) + bitval[0] = symptr=>intval[0] + bitval[1] = symptr=>intval[1] + symptr = eval_int(expr=>cdr) + return new_int(bitval[0] | symptr=>intval[0], bitval[1] | symptr=>intval[1]) +end + +def natv_bitxor(symptr, expr) + var[2] bitval + + symptr = eval_int(expr) + bitval[0] = symptr=>intval[0] + bitval[1] = symptr=>intval[1] + symptr = eval_int(expr=>cdr) + return new_int(bitval[0] ^ symptr=>intval[0], bitval[1] ^ symptr=>intval[1]) +end + +def natv_shift(symptr, expr) + var[2] bitval + var shift + + symptr = eval_int(expr) + bitval[0] = symptr=>intval[0] + bitval[1] = symptr=>intval[1] + symptr = eval_int(expr=>cdr) + shift = symptr=>intval[0] + if shift < 0 + // + // Shift right + // + while shift < 0 + bitval[0] = bitval[0] >> 1 + if bitval[1] & 1 + bitval[0] = bitval[0] | $8000 + else + bitval[0] = bitval[0] & $7FFF + fin + bitval[1] = bitval[1] >> 1 + shift++ + loop + else + // + // Shift left + // + while shift > 0 + bitval[1] = bitval[1] << 1 + if bitval[0] & $8000 + bitval[1] = bitval[1] | 1 + fin + bitval[0] = bitval[0] << 1 + shift-- + loop + fin + return new_int(bitval[0], bitval[1]) +end + +def natv_rotate(symptr, expr) + var[2] bitval + var rotate, wrap + + symptr = eval_int(expr) + bitval[0] = symptr=>intval[0] + bitval[1] = symptr=>intval[1] + symptr = eval_int(expr=>cdr) + rotate = symptr=>intval[0] + if rotate < 0 + while rotate < 0 + wrap = bitval[0] & 1 ?? $8000 :: 0 + bitval[0] = bitval[0] >> 1 + if bitval[1] & 1 + bitval[0] = bitval[0] | $8000 + else + bitval[0] = bitval[0] & $7FFF + fin + bitval[1] = wrap | (bitval[1] >> 1) + rotate++ + loop + else + while rotate > 0 + wrap = bitval[1] & $8000 ?? 1 :: 0 + bitval[1] = bitval[1] << 1 + if bitval[0] & $8000 + bitval[1] = bitval[1] | 1 + fin + bitval[0] = wrap | (bitval[0] << 1) + rotate-- + loop + fin + return new_int(bitval[0], bitval[1]) +end + // // Install math functions // @@ -697,6 +810,12 @@ new_sym("POW_I")=>natv = @natv_powI new_sym("POWY")=>natv = @natv_powY new_sym("COMP")=>natv = @natv_compY new_sym("ANNUITY")=>natv = @natv_annuityY +new_sym("BITNOT")=>natv = @natv_bitnot +new_sym("BITAND")=>natv = @natv_bitand +new_sym("BITOR")=>natv = @natv_bitor +new_sym("BITXOR")=>natv = @natv_bitxor +new_sym("SHIFT")=>natv = @natv_shift +new_sym("ROTATE")=>natv = @natv_rotate fpu:reset() return modkeep | modinitkeep done