Add more string handling and cool macros in defun.lisp

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
 

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))
+                 )))
+               ))
+          ))
+        ))
+)

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

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

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