diff --git a/doc/DRAWL.md b/doc/DRAWL.md index 1b3d93a..5c7af06 100644 --- a/doc/DRAWL.md +++ b/doc/DRAWL.md @@ -58,6 +58,7 @@ The DRAWL implementation comes with the following built-in functions: - OR(...) - NULL() - NUMBERP() +- STRINGP() ### Misc @@ -139,6 +140,8 @@ The DRAWL implementation comes with the following built-in functions: - PI() = Constant value of pi - MATH_E() = Constant value of e +- NUMBER() = Convert atom to number (symbol and array return NIL) +- INTEGER() = Convert number to integer - LOGB() - SCALEB_I() - TRUNCATE() @@ -163,11 +166,12 @@ The DRAWL implementation comes with the following built-in functions: ### Strings -- SUBS = SUB String offset length -- CATS = conCATenate Strings -- LENS = LENgth String -- CHARS = CHARacter String from integer value -- ASCII = ASCII value of first character in string +- STRING() = Convert atom to string +- SUBS() = SUB String offset length +- CATS(...) = conCATenate Strings +- LENS() = LENgth String +- CHARS() = CHARacter String from integer value +- ASCII() = ASCII value of first character in string ### Lo-Res Graphics diff --git a/images/apple/DRAWL.po b/images/apple/DRAWL.po index 035b2e9..1770b99 100644 Binary files a/images/apple/DRAWL.po and b/images/apple/DRAWL.po differ diff --git a/src/lisp/defun.lisp b/src/lisp/defun.lisp index cc4fab8..e210f53 100644 --- a/src/lisp/defun.lisp +++ b/src/lisp/defun.lisp @@ -1,7 +1,21 @@ ; ; USE MACRO TO SIMPLIFY FUNCTION DEFINITION ; -(DEFINE (DEFUN (MACRO (L) - (EVAL (CONS 'DEFINE +(DEFINE (CADR (LAMBDA (L) (CAR (CDR L)))) + (CDDR (LAMBDA (L) (CDR (CDR L)))) + (CADDR (LAMBDA (L) (CAR (CDR (CDR L))))) + (CDDDR (LAMBDA (L) (CDR (CDR (CDR L))))) + (DEFUN (MACRO (L) + (EVAL (CONS 'DEFINE (LIST (CONS (CAR L) (LIST (CONS 'LAMBDA (CDR L))))))) -))) + )) + (DEFPRO (MACRO (L) + (EVAL (CONS 'DEFINE + (LIST (CONS (CAR L) + (LIST (CONS 'LAMBDA (LIST (CADR L) + (CONS 'PROG (CDDR L)) + ))) + )) + )) + )) +) diff --git a/src/lisp/drawl.pla b/src/lisp/drawl.pla index de8929e..3423e0c 100644 --- a/src/lisp/drawl.pla +++ b/src/lisp/drawl.pla @@ -5,20 +5,21 @@ include "inc/conio.plh" include "inc/longjmp.plh" import sexpr - const TYPE_MASK = $70 - const NIL = $00 - const BOOL_FALSE = $00 - const BOOL_TRUE = $01 - const CONS_TYPE = $10 - const SYM_TYPE = $20 - const SYM_LEN = $0F - const NUM_TYPE = $30 - const NUM_INT = $31 - const NUM_FLOAT = $32 - const ARRAY_TYPE = $40 - const MARK_BIT = $80 - const MARK_MASK = $7F - const NULL_HACK = 1 // Hack so we can set APVALs to NULL + const TYPE_MASK = $70 + const NIL = $00 + const BOOL_FALSE = $00 + const BOOL_TRUE = $01 + const CONS_TYPE = $10 + const SYM_TYPE = $20 + const SYM_LEN = $0F + const NUM_TYPE = $30 + const NUM_INT = $31 + const NUM_FLOAT = $32 + const ARRAY_TYPE = $40 + const STRING_TYPE = $50 + const MARK_BIT = $80 + const MARK_MASK = $7F + const NULL_HACK = 1 // Hack so we can set APVALs to NULL struc t_elem word link @@ -41,6 +42,10 @@ import sexpr res[t_elem] word intval[2] end + struc t_string + res[t_elem] + byte stringstr[1] + end var hook_eval var assoc_list @@ -51,6 +56,7 @@ import sexpr predef gc#0 predef new_int(intlo, inthi)#1 + predef new_string(strptr)#1 predef new_sym(symstr)#1 predef print_expr(expr)#0 predef parse_expr(evalptr, level, refill)#2 @@ -104,32 +110,15 @@ def natv_gc(symptr, expr) return new_int(heapavail, 0) end +def natv_bye(symptr, expr) + quit = TRUE + return new_sym("GOODBYE!") +end + // // Useful Apple II features // -def natv_read(symptr, expr) - return readfn() -end - -def natv_printer(symptr, expr) - byte slot - - slot = eval_int16(expr) & 7 - if slot - if !scrncsw - scrncsw = *csw - fin - *csw = $C000 | (slot << 8) - else - if scrncsw - *csw = scrncsw - fin - scrncsw = 0 - fin - return new_int(slot, 0) -end - def natv_gr(symptr, expr) if eval_expr(expr=>car) @@ -154,9 +143,43 @@ def natv_plot(symptr, expr) return expr end -def natv_bye(symptr, expr) - quit = TRUE - return new_sym("GOODBYE!") +def natv_printer(symptr, expr) + byte slot + + slot = eval_int16(expr) & 7 + if slot + if !scrncsw + scrncsw = *csw + fin + *csw = $C000 | (slot << 8) + else + if scrncsw + *csw = scrncsw + fin + scrncsw = 0 + fin + return new_int(slot, 0) +end + +def natv_read(symptr, expr) + return readfn() +end + +def natv_readstring(symptr, expr) + var len + + if fileref // Reading from file + len = fileio:read(fileref, filebuf, FILEBUF_SIZE-1) + if len + if ^(filebuf + len - 1) == $0D + len-- // Remove trailing carriage return + fin + return new_string(filebuf) + fin + fileio:close(fileref) // End of file, fall through to keyboard + fileref = 0 + fin + return new_string(gets(':'|$80)) end // @@ -196,7 +219,8 @@ def read_fileline ^(filebuf + len) = 0 // NULL terminate else fileio:close(fileref) - readfn = @read_keybd + fileref = 0 + readfn = @read_keybd return FALSE fin until len @@ -221,6 +245,26 @@ def read_file return expr end +def natv_readfile(symptr, expr) + symptr = eval_expr(expr=>car) + if symptr->type <> STRING_TYPE + puts("Not string in READFILE:"); print_expr(expr); putln + return NULL + fin + fileref = fileio:open(symptr + stringstr) + if fileref + fileio:newline(fileref, $7F, $0D) + readfn = @read_file + if !filebuf + filebuf = heapalloc(FILEBUF_SIZE) + fin + else + puts("Unable to open: "); puts(symptr + stringstr); putln + symptr = NULL + fin + return symptr +end + // // Handle command line options // @@ -274,20 +318,22 @@ end // puts("DRAWL (LISP 1.5) v1.0 symbolic processor\n") -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 -new_sym("CLEAR")=>natv = @natv_clear -new_sym("GC")=>natv = @natv_gc -new_sym("READ")=>natv = @natv_read -new_sym("PRINTER")=>natv = @natv_printer -new_sym("GR")=>natv = @natv_gr -new_sym("COLOR")=>natv = @natv_color -new_sym("PLOT")=>natv = @natv_plot -new_sym("QUIT")=>natv = @natv_bye +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 +new_sym("CLEAR")=>natv = @natv_clear +new_sym("QUIT")=>natv = @natv_bye +new_sym("GC")=>natv = @natv_gc +new_sym("GR")=>natv = @natv_gr +new_sym("COLOR")=>natv = @natv_color +new_sym("PLOT")=>natv = @natv_plot +new_sym("PRINTER")=>natv = @natv_printer +new_sym("READ")=>natv = @natv_read +new_sym("READSTRING")=>natv = @natv_readstring +new_sym("READFILE")=>natv = @natv_readfile parse_cmdline hook_eval = @hookfn diff --git a/src/lisp/s-expr.pla b/src/lisp/s-expr.pla index 22ae3a8..7538e91 100644 --- a/src/lisp/s-expr.pla +++ b/src/lisp/s-expr.pla @@ -1077,6 +1077,25 @@ def natv_eq(symptr, expr) return bool_pred(iseq) end +def natv_number(symptr, expr) + var num + + expr = eval_expr(expr=>car) + if not expr; return NULL; fin + when expr->type & TYPE_MASK + is STRING_TYPE // Convert string to number + memcpy(tempstr, expr + stringstr, expr->stringstr + 1) + ^(tempstr + ^tempstr + 1) = 0 + drop, expr = parse_num(tempstr + 1) + break + is SYM_TYPE + is ARRAY_TYPE + expr = NULL + is NUM_TYPE + wend + return expr +end + def natv_numberp(symptr, expr) expr = eval_expr(expr=>car) return bool_pred(expr and (expr->type & TYPE_MASK == NUM_TYPE)) @@ -1458,6 +1477,42 @@ def natv_setq(symptr, expr) return expr ?? expr=>cdr :: NULL end +def natv_string(symptr, expr) + expr = eval_expr(expr=>car) + if not expr; return NULL; fin + ^tempstr = 0 + when expr->type & TYPE_MASK + is NUM_TYPE + when expr->type + is NUM_INT + i32tos(expr + intval, tempstr) + break + is NUM_FLOAT + ext2str(expr + floatval, tempstr, fmt_fpint, fmt_fpfrac, fmt_fp) + if ^(tempstr + 1) == ' ' // Remove leading space + memcpy (tempstr + 1, tempstr + 2, ^tempstr) + ^tempstr-- + fin + break + wend + break + is SYM_TYPE + ^tempstr = expr->type & SYM_LEN + memcpy(tempstr + 1, expr + name, ^tempstr) + break; + is ARRAY_TYPE + ^tempstr = 2 + ^(tempstr + 1) = '[' + ^(tempstr + 2) = ']' + break; + wend + return new_string(tempstr) +end + +def natv_stringp(symptr, expr) + return bool_pred(eval_expr(expr=>car)->type == STRING_TYPE) +end + def natv_subs(symptr, expr) var stringptr byte ofst, len @@ -1565,6 +1620,7 @@ new_sym("LIST")=>natv = @natv_list new_sym("ATOM")=>natv = @natv_atom new_sym("EQ")=>natv = @natv_eq new_sym("NUMBERP")=>natv = @natv_numberp +new_sym("NUMBER")=>natv = @natv_number new_sym("NOT")=>natv = @natv_null new_sym("AND")=>natv = @natv_and new_sym("OR")=>natv = @natv_or @@ -1586,6 +1642,8 @@ new_sym("GO")=>natv = @natv_go new_sym("RETURN")=>natv = @natv_return new_sym("SET")=>natv = @natv_set new_sym("SETQ")=>natv = @natv_setq +new_sym("STRINGP")=>natv = @natv_stringp +new_sym("STRING")=>natv = @natv_string new_sym("SUBS")=>natv = @natv_subs new_sym("CATS")=>natv = @natv_cats new_sym("LENS")=>natv = @natv_lens diff --git a/src/lisp/s-math.pla b/src/lisp/s-math.pla index 945867b..f0b30e9 100644 --- a/src/lisp/s-math.pla +++ b/src/lisp/s-math.pla @@ -135,6 +135,10 @@ export def eval_int16(expr)#1 // Always return an int return result=>intval end +def natv_integer(symptr, expr) + return eval_int(expr) +end + def natv_sum(symptr, expr) var num, extptr word[2] intsum @@ -775,6 +779,7 @@ end sane:initFP() new_sym("PI")=>apval = new_float(@ext_pi) ^ NULL_HACK new_sym("MATH_E")=>apval = new_float(@ext_e) ^ NULL_HACK +new_sym("INTEGER")=>natv = @natv_integer new_sym("SUM")=>natv = @natv_sum new_sym("+")=>natv = @natv_sum new_sym("-")=>natv = @natv_sub