\ Lisp read and print in -*- Forth -*-
\ Token counting, omitting \ comments:
\ perl -lne 'while (m,\\\s.*|(\." [^"]*"|\S+)\s*,g) { print $1 if $1 }'
[ifdef] readprint readprint [endif] marker readprint \ gforthism to permit reload
create nursery 32768 allot  nursery value cons-pointer

\ Lisp values or “sexes“ (Symbolic EXpressions).  Initially let’s just
\ support ints and lists of sexes and use 0 as nil.  We can use a
\ low-order 1 bit as an int tag, and require all cons pointers to be
\ 4-byte aligned.  And nil won’t be an atom.
: sextag  3 and ;  : atom?  sextag ;  : null?  0= ;  : pair?  sextag 0= ;
' 2/ alias sex2int  : int2sex  2* 1+ ;  0 constant nil
\ cons takes operands cdr first, car second; decons returns in the same order.
: cons  cons-pointer >r  r@ ! r@ cell+ !  r@ 2 cells + to cons-pointer  r> ;
: decons  dup cell+ @ swap @ ;

\ Printing.
defer print  0 value (sign)
: printnum  sex2int s>d  dup to (sign) dabs  <# #s (sign) sign  #> type  ;
: print-atom  printnum ;
\ Only handle proper lists so far
: print-body  begin  dup null? if  drop exit  then  decons print
    dup null? 0= if  space  then  again ;
: print-list  ." (" print-body ." )" ;
: (print)  dup atom? if print-atom else print-list then ;  ' (print) is print
\ nil 3 int2sex cons -7 int2sex cons 8 int2sex cons print
\ Great, in 40 minutes I got it to print lists of integers.  Does it work for
\ NESTED lists?
\ nil 3 int2sex cons nil -2 int2sex cons 0 int2sex cons cons 7 int2sex cons print
\ Making that work took another 10 minutes.  I was leaving a 0 on the
\ stack in print-body!

\ Reading.  Read reads from a c-addr u kind of buffer, like
\ s" (3 4)" read.  c-addr is stored in readp, and the end of string is
\ stored in readend.  Reading off the end of input throws an error.
defer (read)  0 value readp  0 value readend  37 value (sign)
s" expected sex" exception constant eoderror
: eod?  readp readend = ;  : peek  eod? if  eoderror throw  then  readp c@ ;
: getc  peek  readp 1+ to readp ;  : wsp  begin peek bl =  while  getc drop  repeat ;
: isdigit  [char] 0 [char] 9 1+ within ;  : digit  swap 10 * swap [char] 0 - + ;
: (read-num)  0  begin  eod? if exit then
        peek [char] - = if  -1 to (sign)  getc drop
        else  peek isdigit if  getc digit  else  exit  then  then  again ;
\ That took me like half an hour to debug because I was confusing char
\ and [char].
: read-num  1 to (sign)  (read-num)  (sign) *  int2sex ;

: read-tail  wsp  peek [char] ) = if getc drop nil else
        (read) recurse swap cons then ;
: ((read))  wsp  peek [char] ( ( ) = if getc drop read-tail else read-num then ;
' ((read)) is (read)
: study  over + to readend  to readp ;
: read  study (read)  0 to readp  0 to readend ;
s" (3 4 (5  6 -7) 888 9 -10 () () )" read print cr
\ Okay, those 30 lines of code took me over 2 hours.  No GC tho.