From cbedf170e32fac7c559f01b890ae2355a6b2666b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 4 Feb 2015 00:45:07 -0500
Subject: forth: Start experimenting

---
 forth/types.f | 247 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 247 insertions(+)
 create mode 100644 forth/types.f

(limited to 'forth')

diff --git a/forth/types.f b/forth/types.f
new file mode 100644
index 0000000..e30733f
--- /dev/null
+++ b/forth/types.f
@@ -0,0 +1,247 @@
+\ === classic lisp list === /
+: cons { addr val -- new-list-address }
+  2 cells allocate throw
+  dup addr val rot 2! ;
+
+: cdr ( addr -- next-addr )
+  cell+ @ ;
+
+: int-pr ( num -- )
+  s>d <# #s #> type ;
+
+: prn ( list-address -- )
+  ." (" 2@ int-pr
+  begin
+    space 2@ int-pr
+    dup 0=
+  until
+  .\" )\n" ;
+
+0 1 cons 2 cons 3 cons 4 cons
+prn
+
+
+\ === mutable vector === /
+\ Singly-linked list, with an "object" pair that points to both ends.
+\ This allows fast append and fast iteration from beginning to end,
+\ like a vector.  ...but buys simplicity with mutability
+: new-mutvec ( -- mutvec-addr )
+  2 cells allocate throw
+  dup 0 0 rot 2! ;
+
+: mutvec-append { mutvec-addr value -- }
+  2 cells allocate throw    \ new pair
+  dup nil value rot 2!      \ put value in new pair
+  dup mutvec-addr @
+    ?dup 0= if mutvec-addr endif
+    cell+ !                 \ update old tail
+  mutvec-addr !             \ update object
+  ;
+
+new-mutvec
+dup 5 mutvec-append
+dup 4 mutvec-append
+dup 3 mutvec-append
+dup 2 mutvec-append
+cdr prn
+
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size.  When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+  str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+  2
+  begin
+    1 lshift 2dup <
+  until
+  swap drop ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+  buf-str-len str-len +
+  { new-len }
+  new-len str-base-size > if
+    buf-str-len new-len xor buf-str-len > if
+      buf-addr new-len round-up resize throw
+      to buf-addr
+    endif
+  endif
+  str-addr buf-addr buf-str-len + str-len cmove
+  buf-addr new-len ;
+
+
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+new-str
+s" hello there" str-append a-space
+s" is this getting ...." str-append a-space
+s\" interesting yet?\n" str-append
+type
+
+\ A rewrite of the list-printer above, but now using string buffer:
+: int-pr-str2 ( num -- str-addr str-len )
+  s>d <# #s #> ;
+
+: pr-str2 ( strbuf str-len list-address -- )
+  -rot s" (" str-append rot
+  2@ 2swap rot int-pr-str2 str-append
+  begin
+    a-space
+    rot 2@ 2swap rot int-pr-str2 str-append
+    2 pick 0=
+  until
+  s" )" str-append rot drop ;
+
+new-str
+0 1 cons 2 cons 3 cons 4 cons
+pr-str2 type
+cr
+
+: test=
+  2dup = if
+    2drop
+  else
+    cr ." assert failed on line " sourceline# .
+    swap cr ." | got " . cr ." | expected " . cr
+  endif ;
+
+\ new-class
+
+struct
+  cell% 2 * field MalTypeType-struct
+  cell% field MalTypeType-methods
+end-struct MalTypeType%
+
+struct
+  cell% field mal-type
+  \ cell% field ref-count \ Ha, right.
+end-struct MalType%
+
+: new ( MalTypeType -- obj )
+  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
+  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
+  ;
+
+: deftype* ( struct-align struct-len -- MalTypeType )
+  MalTypeType% %allot                ( s-a s-l MalTypeType )
+  dup 2swap rot                      ( MalTypeType s-a s-l MalTypeType )
+  MalTypeType-struct 2!              ( MalTypeType ) \ store struct info
+  dup MalTypeType-methods nil swap ! ( MalTypeType ) \ init methods to nil
+  ;
+
+\ Example:
+
+MalType%
+  cell% field obj-list/car
+  cell% field obj-list/cdr
+deftype* constant ObjList
+
+ObjList new
+ObjList new
+= 0 test=
+
+ObjList new dup obj-list/car 5 swap ! obj-list/car @   5 test=
+
+\ search a sorted array for key, returning the index of where it was
+\ found. If key is not in the array, return the index where it would
+\ be if added.
+: aarray-find { aa-length aa-addr key -- index }
+  0 aa-length ( start end )
+  begin
+    \ cr 2dup . .
+    2dup + 2 / dup ( start end middle middle )
+    cells aa-addr + @ ( start end middle mid-val )
+    dup key < if
+      drop rot ( end middle start )
+      2dup = if
+        2drop dup ( end end )
+      else
+        drop swap ( middle end )
+      endif
+    else
+      key > if ( start end middle )
+        swap drop ( start middle )
+      else
+        -rot 2drop dup ( middle middle )
+      endif
+    endif
+  2dup = until
+  drop
+  ;
+
+create zaa 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
+
+7 zaa 2 aarray-find   0 test=
+7 zaa 6 aarray-find   1 test=
+7 zaa 10 aarray-find  3 test=
+7 zaa 81 aarray-find  6 test=
+7 zaa 12 aarray-find  4 test=
+7 zaa 8  aarray-find  3 test=
+7 zaa 100 aarray-find 7 test=
+7 zaa 1 aarray-find   0 test=
+
+\ manual protocol method
+
+0 value method-count
+
+: pr-str ( ?? obj -- ?? )
+  dup mal-type @ MalTypeType-methods @ ( obj methods )
+  [ method-count ] literal aarray-find ( obj xt )
+  execute ;
+
+
+(
+  method-count 1+ to method-count
+
+protocol IPrintable
+  method% pr-str
+end-protocol
+)
+
+(
+ObjList IPrintable extend
+
+  ' pr-str :noname drop s" <unprintable>" ; extend-method*
+
+  extend-method pr-str
+    drop s" <unprintable>" ;
+end-extend
+)
+
+\ new-obj
+
+\ new-instance
+
+
+\ maybe useful for debugging?
+: p dup . ;
+: @p dup @ dup . ;
+
+(
+
+create buff 128 allot
+
+." user> "
+
+buff 128 stdin read-line throw
+
+buff c@ .
+buff 5 + c@ .
+
+S" Hello" dup . type
+
+
+bye
+
+)
+
+cr ." Done loading" cr
-- 
cgit v1.2.3


From b745d1914925626c8e48fff3f95dcf440bb58755 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 4 Feb 2015 20:05:03 -0500
Subject: forth: Add basic protocol functionality

---
 forth/types.f  | 247 ----------------------------------------
 forth/types.fs | 351 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 351 insertions(+), 247 deletions(-)
 delete mode 100644 forth/types.f
 create mode 100644 forth/types.fs

(limited to 'forth')

diff --git a/forth/types.f b/forth/types.f
deleted file mode 100644
index e30733f..0000000
--- a/forth/types.f
+++ /dev/null
@@ -1,247 +0,0 @@
-\ === classic lisp list === /
-: cons { addr val -- new-list-address }
-  2 cells allocate throw
-  dup addr val rot 2! ;
-
-: cdr ( addr -- next-addr )
-  cell+ @ ;
-
-: int-pr ( num -- )
-  s>d <# #s #> type ;
-
-: prn ( list-address -- )
-  ." (" 2@ int-pr
-  begin
-    space 2@ int-pr
-    dup 0=
-  until
-  .\" )\n" ;
-
-0 1 cons 2 cons 3 cons 4 cons
-prn
-
-
-\ === mutable vector === /
-\ Singly-linked list, with an "object" pair that points to both ends.
-\ This allows fast append and fast iteration from beginning to end,
-\ like a vector.  ...but buys simplicity with mutability
-: new-mutvec ( -- mutvec-addr )
-  2 cells allocate throw
-  dup 0 0 rot 2! ;
-
-: mutvec-append { mutvec-addr value -- }
-  2 cells allocate throw    \ new pair
-  dup nil value rot 2!      \ put value in new pair
-  dup mutvec-addr @
-    ?dup 0= if mutvec-addr endif
-    cell+ !                 \ update old tail
-  mutvec-addr !             \ update object
-  ;
-
-new-mutvec
-dup 5 mutvec-append
-dup 4 mutvec-append
-dup 3 mutvec-append
-dup 2 mutvec-append
-cdr prn
-
-
-\ === mutable string buffer === /
-\ string buffer that maintains an allocation larger than the current
-\ string size.  When appending would cause the string size exceed the
-\ current allocation, resize is used to double the allocation. The
-\ current allocation is not stored anywhere, but computed based on
-\ current string size or str-base-size, whichever is larger.
-64 constant str-base-size
-
-: new-str ( -- addr length )
-  str-base-size allocate throw 0 ;
-
-: round-up ( n -- n )
-  2
-  begin
-    1 lshift 2dup <
-  until
-  swap drop ;
-
-: str-append { buf-addr buf-str-len str-addr str-len }
-  buf-str-len str-len +
-  { new-len }
-  new-len str-base-size > if
-    buf-str-len new-len xor buf-str-len > if
-      buf-addr new-len round-up resize throw
-      to buf-addr
-    endif
-  endif
-  str-addr buf-addr buf-str-len + str-len cmove
-  buf-addr new-len ;
-
-
-bl c,
-here constant space-str
-: a-space space-str 1 str-append ;
-
-new-str
-s" hello there" str-append a-space
-s" is this getting ...." str-append a-space
-s\" interesting yet?\n" str-append
-type
-
-\ A rewrite of the list-printer above, but now using string buffer:
-: int-pr-str2 ( num -- str-addr str-len )
-  s>d <# #s #> ;
-
-: pr-str2 ( strbuf str-len list-address -- )
-  -rot s" (" str-append rot
-  2@ 2swap rot int-pr-str2 str-append
-  begin
-    a-space
-    rot 2@ 2swap rot int-pr-str2 str-append
-    2 pick 0=
-  until
-  s" )" str-append rot drop ;
-
-new-str
-0 1 cons 2 cons 3 cons 4 cons
-pr-str2 type
-cr
-
-: test=
-  2dup = if
-    2drop
-  else
-    cr ." assert failed on line " sourceline# .
-    swap cr ." | got " . cr ." | expected " . cr
-  endif ;
-
-\ new-class
-
-struct
-  cell% 2 * field MalTypeType-struct
-  cell% field MalTypeType-methods
-end-struct MalTypeType%
-
-struct
-  cell% field mal-type
-  \ cell% field ref-count \ Ha, right.
-end-struct MalType%
-
-: new ( MalTypeType -- obj )
-  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
-  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
-  ;
-
-: deftype* ( struct-align struct-len -- MalTypeType )
-  MalTypeType% %allot                ( s-a s-l MalTypeType )
-  dup 2swap rot                      ( MalTypeType s-a s-l MalTypeType )
-  MalTypeType-struct 2!              ( MalTypeType ) \ store struct info
-  dup MalTypeType-methods nil swap ! ( MalTypeType ) \ init methods to nil
-  ;
-
-\ Example:
-
-MalType%
-  cell% field obj-list/car
-  cell% field obj-list/cdr
-deftype* constant ObjList
-
-ObjList new
-ObjList new
-= 0 test=
-
-ObjList new dup obj-list/car 5 swap ! obj-list/car @   5 test=
-
-\ search a sorted array for key, returning the index of where it was
-\ found. If key is not in the array, return the index where it would
-\ be if added.
-: aarray-find { aa-length aa-addr key -- index }
-  0 aa-length ( start end )
-  begin
-    \ cr 2dup . .
-    2dup + 2 / dup ( start end middle middle )
-    cells aa-addr + @ ( start end middle mid-val )
-    dup key < if
-      drop rot ( end middle start )
-      2dup = if
-        2drop dup ( end end )
-      else
-        drop swap ( middle end )
-      endif
-    else
-      key > if ( start end middle )
-        swap drop ( start middle )
-      else
-        -rot 2drop dup ( middle middle )
-      endif
-    endif
-  2dup = until
-  drop
-  ;
-
-create zaa 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
-
-7 zaa 2 aarray-find   0 test=
-7 zaa 6 aarray-find   1 test=
-7 zaa 10 aarray-find  3 test=
-7 zaa 81 aarray-find  6 test=
-7 zaa 12 aarray-find  4 test=
-7 zaa 8  aarray-find  3 test=
-7 zaa 100 aarray-find 7 test=
-7 zaa 1 aarray-find   0 test=
-
-\ manual protocol method
-
-0 value method-count
-
-: pr-str ( ?? obj -- ?? )
-  dup mal-type @ MalTypeType-methods @ ( obj methods )
-  [ method-count ] literal aarray-find ( obj xt )
-  execute ;
-
-
-(
-  method-count 1+ to method-count
-
-protocol IPrintable
-  method% pr-str
-end-protocol
-)
-
-(
-ObjList IPrintable extend
-
-  ' pr-str :noname drop s" <unprintable>" ; extend-method*
-
-  extend-method pr-str
-    drop s" <unprintable>" ;
-end-extend
-)
-
-\ new-obj
-
-\ new-instance
-
-
-\ maybe useful for debugging?
-: p dup . ;
-: @p dup @ dup . ;
-
-(
-
-create buff 128 allot
-
-." user> "
-
-buff 128 stdin read-line throw
-
-buff c@ .
-buff 5 + c@ .
-
-S" Hello" dup . type
-
-
-bye
-
-)
-
-cr ." Done loading" cr
diff --git a/forth/types.fs b/forth/types.fs
new file mode 100644
index 0000000..3d76329
--- /dev/null
+++ b/forth/types.fs
@@ -0,0 +1,351 @@
+\ === tiny framework for inline tests === /
+: test=
+  2dup = if
+    2drop
+  else
+    cr ." assert failed on line " sourceline# .
+    swap cr ." | got " . cr ." | expected " . cr
+  endif ;
+
+\ === classic lisp list === /
+: cons { addr val -- new-list-address }
+  2 cells allocate throw
+  dup addr val rot 2! ;
+
+: cdr ( addr -- next-addr )
+  cell+ @ ;
+
+: int-pr ( num -- )
+  s>d <# #s #> type ;
+
+: prn ( list-address -- )
+  ." (" 2@ int-pr
+  begin
+    space 2@ int-pr
+    dup 0=
+  until
+  .\" )\n" ;
+
+0 1 cons 2 cons 3 cons 4 cons
+prn
+
+
+\ === mutable vector === /
+\ Singly-linked list, with an "object" pair that points to both ends.
+\ This allows fast append and fast iteration from beginning to end,
+\ like a vector.  ...but buys simplicity with mutability
+: new-mutvec ( -- mutvec-addr )
+  2 cells allocate throw
+  dup 0 0 rot 2! ;
+
+: mutvec-append { mutvec-addr value -- }
+  2 cells allocate throw    \ new pair
+  dup nil value rot 2!      \ put value in new pair
+  dup mutvec-addr @
+    ?dup 0= if mutvec-addr endif
+    cell+ !                 \ update old tail
+  mutvec-addr !             \ update object
+  ;
+
+new-mutvec
+dup 5 mutvec-append
+dup 4 mutvec-append
+dup 3 mutvec-append
+dup 2 mutvec-append
+cdr prn
+
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size.  When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+  str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+  2
+  begin
+    1 lshift 2dup <
+  until
+  swap drop ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+  buf-str-len str-len +
+  { new-len }
+  new-len str-base-size > if
+    buf-str-len new-len xor buf-str-len > if
+      buf-addr new-len round-up resize throw
+      to buf-addr
+    endif
+  endif
+  str-addr buf-addr buf-str-len + str-len cmove
+  buf-addr new-len ;
+
+
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+new-str
+s" hello there" str-append a-space
+s" is this getting ...." str-append a-space
+s\" interesting yet?\n" str-append
+type
+
+\ A rewrite of the list-printer above, but now using string buffer:
+: int-pr-str2 ( num -- str-addr str-len )
+  s>d <# #s #> ;
+
+: pr-str2 ( strbuf str-len list-address -- )
+  -rot s" (" str-append rot
+  2@ 2swap rot int-pr-str2 str-append
+  begin
+    a-space
+    rot 2@ 2swap rot int-pr-str2 str-append
+    2 pick 0=
+  until
+  s" )" str-append rot drop ;
+
+new-str
+0 1 cons 2 cons 3 cons 4 cons
+pr-str2 type
+cr
+
+\ === deftype* -- protocol-enabled structs === /
+\ Each type has MalTypeType% struct allocated on the stack, with
+\ mutable fields pointing to all class-shared resources, specifically
+\ the data needed to allocate new instances, and the table of protocol
+\ methods that have been extended to the type.
+\ Use 'deftype*' to define a new type, and 'new' to create new
+\ instances of that type.
+
+struct
+  cell% field mal-type
+  \ cell% field ref-count \ Ha, right.
+end-struct MalType%
+
+struct
+  cell% 2 * field MalTypeType-struct
+  cell% field MalTypeType-methods
+  cell% field MalTypeType-method-keys
+  cell% field MalTypeType-method-vals
+end-struct MalTypeType%
+
+: new ( MalTypeType -- obj )
+  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
+  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
+  ;
+
+: deftype* ( struct-align struct-len -- MalTypeType )
+  MalTypeType% %allot                      ( s-a s-l MalTypeType )
+  dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
+  MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
+  dup MalTypeType-methods     0   swap !   ( MalTypeType )
+  dup MalTypeType-method-keys nil swap !   ( MalTypeType )
+  dup MalTypeType-method-vals nil swap !   ( MalTypeType )
+  ;
+
+MalType% deftype* constant MalDefault
+
+\ Example and tests
+
+MalType%
+  cell% field obj-list/car
+  cell% field obj-list/cdr
+deftype* constant ObjList
+
+ObjList new
+ObjList new
+= 0 test=
+
+ObjList new dup obj-list/car 5 swap ! obj-list/car @   5 test=
+
+\ === sorted-array === /
+\ Here are a few utility functions useful for creating and maintaining
+\ the deftype* method tables. The keys array is kept in sorted order,
+\ and the methods array is maintained in parallel so that an index into
+\ one corresponds to an index in the other.
+
+\ Search a sorted array for key, returning the index of where it was
+\ found. If key is not in the array, return the index where it would
+\ be if added.
+: array-find { a-length a-addr key -- index found? }
+  0 a-length           ( start end )
+  begin
+    \ cr 2dup . .
+    2dup + 2 / dup     ( start end middle middle )
+    cells a-addr + @   ( start end middle mid-val )
+    dup key < if
+      drop rot         ( end middle start )
+      2dup = if
+        2drop dup      ( end end )
+      else
+        drop swap      ( middle end )
+      endif
+    else
+      key > if         ( start end middle )
+        swap drop      ( start middle )
+      else
+        -rot 2drop dup ( middle middle )
+      endif
+    endif
+  2dup = until
+  cells a-addr + @ key =
+  ;
+
+\ Create a new array, one cell in length, initialized the provided value
+: new-array { value -- array }
+  cell allocate throw value over ! ;
+
+\ Resize a heap-allocated array to be one cell longer, inserting value
+\ at idx, and shifting the tail of the array as necessary. Returns the
+\ (possibly new) array address
+: array-insert { old-array-length old-array idx value -- array }
+  old-array old-array-length 1+ cells resize throw
+  { a }
+  a idx cells +   dup cell+   old-array-length idx - cells   cmove>
+  value a idx cells + !
+  a
+  ;
+
+\ array function tests
+create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
+
+7 za 2 array-find   -1 test= 0 test=
+7 za 6 array-find   -1 test= 1 test=
+7 za 10 array-find  -1 test= 3 test=
+7 za 81 array-find  -1 test= 6 test=
+7 za 12 array-find   0 test= 4 test=
+7 za 8  array-find   0 test= 3 test=
+7 za 100 array-find  0 test= 7 test=
+7 za 1 array-find    0 test= 0 test=
+
+10 new-array
+1 swap 0  5 array-insert
+2 swap 1  7 array-insert
+3 swap 3 12 array-insert
+4 swap 4 15 array-insert
+5 swap 5 20 array-insert
+
+dup 0 cells + @   5 test=
+dup 1 cells + @   7 test=
+dup 2 cells + @  10 test=
+dup 3 cells + @  12 test=
+dup 4 cells + @  15 test=
+dup 5 cells + @  20 test=
+
+
+\ === protocol methods === /
+
+\ Used by protocol methods to find the appropriate implementation of
+\ themselves for the given object, and then execute that implementation.
+: execute-method { obj pxt -- }
+  obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
+  dup 0= if \ No protocols extended to this type; check for a default
+    2drop drop MalDefault MalTypeType-methods 2@ swap
+  endif
+  dup 0= if ." No protocols extended to this type or MalDefault" 1 throw endif
+
+  pxt array-find ( type idx found? )
+  dup 0= if \ No implementation found for this method; check for a default
+    2drop MalDefault MalTypeType-methods 2@ swap
+    dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
+    pxt array-find ( type idx found? )
+  endif
+  0= if ." No implementation found" 1 throw endif
+
+  cells swap MalTypeType-method-vals @ + @ ( xt )
+  obj swap execute
+  ;
+
+\ Extend a type with a protocol method. This mutates the MalTypeType
+\ object that represents the MalType being extended.
+: extend-method* { type pxt ixt -- type }
+  type MalTypeType-methods 2@ swap ( methods method-keys )
+  dup 0= if \ no protocols extended to this type
+    2drop
+    1 type MalTypeType-methods !
+    pxt new-array type MalTypeType-method-keys !
+    ixt new-array type MalTypeType-method-vals !
+  else
+    pxt array-find { idx found? }
+    found? if \ overwrite
+      ." Warning: overwriting protocol method implementation"
+      type MalTypeType-method-vals @ idx cells + ixt !
+    else \ resize
+      type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
+      1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
+        type MalTypeType-method-keys ! ( old-count )
+      \ cr ." before: " ObjList MalTypeType-method-vals @ @ . cr
+      type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
+        type MalTypeType-method-vals !
+      \ cr ." after: " ObjList MalTypeType-method-vals @ @ . cr
+    endif
+  endif
+  type
+  ;
+
+\ Examples of making new protocol methods (without a protocol to group them yet!)
+: pr-str [ latestxt ] literal execute-method ;
+: conj   [ latestxt ] literal execute-method ;
+
+\ Examples of extending existing protocol methods to existing type
+MalDefault ' pr-str :noname s" #<MalObject>" ; extend-method*
+ObjList ' pr-str :noname drop s" #<ObjList>" ; extend-method*
+ObjList ' conj :noname ." not yet done" ; extend-method*
+
+\ Run some protocol methods!
+ObjList new pr-str type
+ObjList new conj
+
+(
+  method-count 1+ to method-count
+
+protocol IPrintable
+  method% pr-str
+end-protocol
+)
+
+(
+ObjList IPrintable extend
+
+  ' pr-str :noname drop s" <unprintable>" ; extend-method*
+
+  extend-method pr-str
+    drop s" <unprintable>" ;
+end-extend
+)
+
+\ new-obj
+
+\ new-instance
+
+
+\ maybe useful for debugging?
+: p dup . ;
+: @p dup @ dup . ;
+
+(
+
+create buff 128 allot
+
+." user> "
+
+buff 128 stdin read-line throw
+
+buff c@ .
+buff 5 + c@ .
+
+S" Hello" dup . type
+
+
+)
+
+
+cr
+bye
+." Done loading" cr
-- 
cgit v1.2.3


From 14b846ffeb0a785c4918e4a3850ee229fcf1879d Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 4 Feb 2015 21:44:37 -0500
Subject: forth: protocols and some pr-str working

---
 forth/types.fs | 213 +++++++++++++++++++++++++++------------------------------
 1 file changed, 99 insertions(+), 114 deletions(-)

(limited to 'forth')

diff --git a/forth/types.fs b/forth/types.fs
index 3d76329..2f97fa5 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -7,52 +7,12 @@
     swap cr ." | got " . cr ." | expected " . cr
   endif ;
 
-\ === classic lisp list === /
-: cons { addr val -- new-list-address }
-  2 cells allocate throw
-  dup addr val rot 2! ;
-
-: cdr ( addr -- next-addr )
-  cell+ @ ;
-
-: int-pr ( num -- )
-  s>d <# #s #> type ;
-
-: prn ( list-address -- )
-  ." (" 2@ int-pr
-  begin
-    space 2@ int-pr
-    dup 0=
-  until
-  .\" )\n" ;
-
-0 1 cons 2 cons 3 cons 4 cons
-prn
-
-
-\ === mutable vector === /
-\ Singly-linked list, with an "object" pair that points to both ends.
-\ This allows fast append and fast iteration from beginning to end,
-\ like a vector.  ...but buys simplicity with mutability
-: new-mutvec ( -- mutvec-addr )
-  2 cells allocate throw
-  dup 0 0 rot 2! ;
-
-: mutvec-append { mutvec-addr value -- }
-  2 cells allocate throw    \ new pair
-  dup nil value rot 2!      \ put value in new pair
-  dup mutvec-addr @
-    ?dup 0= if mutvec-addr endif
-    cell+ !                 \ update old tail
-  mutvec-addr !             \ update object
-  ;
-
-new-mutvec
-dup 5 mutvec-append
-dup 4 mutvec-append
-dup 3 mutvec-append
-dup 2 mutvec-append
-cdr prn
+: safe-type ( str-addr str-len -- )
+    dup 256 > if
+        drop 256 type ." ...<lots more>" type
+    else
+        type
+    endif ;
 
 
 \ === mutable string buffer === /
@@ -85,35 +45,14 @@ cdr prn
   str-addr buf-addr buf-str-len + str-len cmove
   buf-addr new-len ;
 
-
+\ define a function to append a space
 bl c,
 here constant space-str
 : a-space space-str 1 str-append ;
 
-new-str
-s" hello there" str-append a-space
-s" is this getting ...." str-append a-space
-s\" interesting yet?\n" str-append
-type
-
-\ A rewrite of the list-printer above, but now using string buffer:
-: int-pr-str2 ( num -- str-addr str-len )
+: int>str ( num -- str-addr str-len )
   s>d <# #s #> ;
 
-: pr-str2 ( strbuf str-len list-address -- )
-  -rot s" (" str-append rot
-  2@ 2swap rot int-pr-str2 str-append
-  begin
-    a-space
-    rot 2@ 2swap rot int-pr-str2 str-append
-    2 pick 0=
-  until
-  s" )" str-append rot drop ;
-
-new-str
-0 1 cons 2 cons 3 cons 4 cons
-pr-str2 type
-cr
 
 \ === deftype* -- protocol-enabled structs === /
 \ Each type has MalTypeType% struct allocated on the stack, with
@@ -151,18 +90,29 @@ end-struct MalTypeType%
 
 MalType% deftype* constant MalDefault
 
+\ nil type and instance to support extending protocols to it
+MalType% deftype* constant MalNil
+MalNil new constant mal-nil
+
 \ Example and tests
 
 MalType%
-  cell% field obj-list/car
-  cell% field obj-list/cdr
-deftype* constant ObjList
-
-ObjList new
-ObjList new
+  cell% field MalList/car
+  cell% field MalList/cdr
+deftype* constant MalList
+
+: MalList/conj { val coll -- list }
+    MalList new ( list )
+    val over MalList/car ! ( list )
+    coll over MalList/cdr ! ( list )
+    ;
+
+MalList new
+MalList new
 = 0 test=
 
-ObjList new dup obj-list/car 5 swap ! obj-list/car @   5 test=
+MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
+
 
 \ === sorted-array === /
 \ Here are a few utility functions useful for creating and maintaining
@@ -252,7 +202,7 @@ dup 5 cells + @  20 test=
 
   pxt array-find ( type idx found? )
   dup 0= if \ No implementation found for this method; check for a default
-    2drop MalDefault MalTypeType-methods 2@ swap
+    2drop drop MalDefault dup MalTypeType-methods 2@ swap
     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
@@ -280,72 +230,107 @@ dup 5 cells + @  20 test=
       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
         type MalTypeType-method-keys ! ( old-count )
-      \ cr ." before: " ObjList MalTypeType-method-vals @ @ . cr
+      \ cr ." before: " MalList MalTypeType-method-vals @ @ . cr
       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
         type MalTypeType-method-vals !
-      \ cr ." after: " ObjList MalTypeType-method-vals @ @ . cr
+      \ cr ." after: " MalList MalTypeType-method-vals @ @ . cr
     endif
   endif
   type
   ;
 
-\ Examples of making new protocol methods (without a protocol to group them yet!)
-: pr-str [ latestxt ] literal execute-method ;
-: conj   [ latestxt ] literal execute-method ;
 
-\ Examples of extending existing protocol methods to existing type
-MalDefault ' pr-str :noname s" #<MalObject>" ; extend-method*
-ObjList ' pr-str :noname drop s" #<ObjList>" ; extend-method*
-ObjList ' conj :noname ." not yet done" ; extend-method*
+\ def-protocol-method pr-str   ...can be written:
+\ : pr-str ( obj -- str ) [ latestxt ] literal execute-method ;
+: def-protocol-method ( "name" -- )
+    create latestxt ,
+  does> ( ??? obj xt-ref -- ??? )
+    @ execute-method ;
 
-\ Run some protocol methods!
-ObjList new pr-str type
-ObjList new conj
+: extend ( type -- type pxt <noname...>)
+    parse-name find-name name>int ( type pxt )
+    :noname
+    ;
 
-(
-  method-count 1+ to method-count
+: ;; ( type pxt <noname...> -- type )
+    [compile] ; ( type pxt ixt )
+    extend-method*
+    ; immediate
 
+(
+\ These whole-protocol names are only needed for 'satisfies?':
 protocol IPrintable
-  method% pr-str
+  def-protocol-method pr-str
 end-protocol
-)
-
-(
-ObjList IPrintable extend
 
+MalList IPrintable extend
   ' pr-str :noname drop s" <unprintable>" ; extend-method*
 
   extend-method pr-str
-    drop s" <unprintable>" ;
+    drop s" <unprintable>" ;;
 end-extend
 )
 
-\ new-obj
-
-\ new-instance
-
+\ Examples of making new protocol methods (without a protocol to group them yet!)
+def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
+def-protocol-method conj ( obj this -- this )
 
-\ maybe useful for debugging?
-: p dup . ;
-: @p dup @ dup . ;
+: pr-str { obj }
+    new-str obj pr-buf ;
 
-(
+\ Examples of extending existing protocol methods to existing type
+MalDefault
+  extend pr-buf
+    { this }
+    s" #<MalObject" str-append a-space
+    this int>str str-append
+    s" >" str-append ;;
+  extend conj   ( obj this -- this )
+    swap drop ;;
+drop
+
+MalNil
+  extend pr-buf
+    drop s" nil" str-append ;;
+  ' conj ' MalList/conj extend-method*
+drop
+
+MalList
+  extend pr-buf
+    -rot s" (" str-append ( list str-addr str-len )
+    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    begin ( list str-addr str-len )
+      2 pick mal-nil <>
+    while
+      a-space
+      rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    repeat
+    s" )" str-append rot drop ;;
+  ' conj ' MalList/conj extend-method*
+drop
 
-create buff 128 allot
 
-." user> "
+MalType%
+  cell% field MalInt/int
+deftype* constant MalInt
 
-buff 128 stdin read-line throw
+MalInt
+  extend pr-buf
+    MalInt/int @ int>str str-append ;;
+drop
 
-buff c@ .
-buff 5 + c@ .
+: MalInt. { int -- mal-int }
+    MalInt new dup MalInt/int int swap ! ;
 
-S" Hello" dup . type
 
+\ Run some protocol methods!
 
-)
+mal-nil
+42 MalInt. mal-nil conj
+10 MalInt. mal-nil conj conj
+20 MalInt. swap conj
+23 MalInt. mal-nil conj conj conj
 
+pr-str safe-type cr
 
-cr
 bye
-." Done loading" cr
-- 
cgit v1.2.3


From ccc7d9d199c56473997b40f49c6bfc79d9799fd2 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 5 Feb 2015 18:47:32 -0500
Subject: forth: Add step 0

---
 forth/step0_repl.fs | 23 +++++++++++++++++++++++
 forth/types.fs      |  5 +----
 2 files changed, 24 insertions(+), 4 deletions(-)
 create mode 100644 forth/step0_repl.fs

(limited to 'forth')

diff --git a/forth/step0_repl.fs b/forth/step0_repl.fs
new file mode 100644
index 0000000..42c33f5
--- /dev/null
+++ b/forth/step0_repl.fs
@@ -0,0 +1,23 @@
+s" types.fs" included
+
+: read ;
+: eval ;
+: print ;
+
+: rep
+    read
+    eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      rep type cr
+    repeat ;
+
+read-lines
\ No newline at end of file
diff --git a/forth/types.fs b/forth/types.fs
index 2f97fa5..460c3aa 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -330,7 +330,4 @@ mal-nil
 10 MalInt. mal-nil conj conj
 20 MalInt. swap conj
 23 MalInt. mal-nil conj conj conj
-
-pr-str safe-type cr
-
-bye
+pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
-- 
cgit v1.2.3


From 59038a10f0e3ad65675cafdb149eb61405e334d3 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 6 Feb 2015 00:38:34 -0500
Subject: forth: Added lists, ints, symbols for step 1

---
 forth/misc-tests.fs       |  53 ++++++++++
 forth/printer.fs          |  96 +++++++++++++++++++
 forth/reader.fs           |  92 ++++++++++++++++++
 forth/step0_repl.fs       |   2 +-
 forth/step1_read_print.fs |  32 +++++++
 forth/types.fs            | 240 ++++++++++++----------------------------------
 6 files changed, 337 insertions(+), 178 deletions(-)
 create mode 100644 forth/misc-tests.fs
 create mode 100644 forth/printer.fs
 create mode 100644 forth/reader.fs
 create mode 100644 forth/step1_read_print.fs

(limited to 'forth')

diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
new file mode 100644
index 0000000..5aaf2f2
--- /dev/null
+++ b/forth/misc-tests.fs
@@ -0,0 +1,53 @@
+require printer.fs
+
+\ === basic testing util === /
+: test=
+  2dup = if
+    2drop
+  else
+    cr ." assert failed on line " sourceline# .
+    swap cr ." | got " . cr ." | expected " . cr
+  endif ;
+
+\ array function tests
+create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
+
+7 za 2 array-find   -1 test= 0 test=
+7 za 6 array-find   -1 test= 1 test=
+7 za 10 array-find  -1 test= 3 test=
+7 za 81 array-find  -1 test= 6 test=
+7 za 12 array-find   0 test= 4 test=
+7 za 8  array-find   0 test= 3 test=
+7 za 100 array-find  0 test= 7 test=
+7 za 1 array-find    0 test= 0 test=
+
+10 new-array
+1 swap 0  5 array-insert
+2 swap 1  7 array-insert
+3 swap 3 12 array-insert
+4 swap 4 15 array-insert
+5 swap 5 20 array-insert
+
+dup 0 cells + @   5 test=
+dup 1 cells + @   7 test=
+dup 2 cells + @  10 test=
+dup 3 cells + @  12 test=
+dup 4 cells + @  15 test=
+dup 5 cells + @  20 test=
+
+
+\ MalType tests
+
+MalList new   MalList new   = 0 test=
+
+MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
+
+
+\ Protocol tests
+
+mal-nil
+42 MalInt. mal-nil conj
+10 MalInt. mal-nil conj conj
+20 MalInt. swap conj
+23 MalInt. mal-nil conj conj conj
+pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
diff --git a/forth/printer.fs b/forth/printer.fs
new file mode 100644
index 0000000..5ff28e5
--- /dev/null
+++ b/forth/printer.fs
@@ -0,0 +1,96 @@
+require types.fs
+
+: safe-type ( str-addr str-len -- )
+    dup 256 > if
+        drop 256 type ." ...<lots more>" type
+    else
+        type
+    endif ;
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size.  When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+  str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+  2
+  begin
+    1 lshift 2dup <
+  until
+  swap drop ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+  buf-str-len str-len +
+  { new-len }
+  new-len str-base-size > if
+    buf-str-len new-len xor buf-str-len > if
+      buf-addr new-len round-up resize throw
+      to buf-addr
+    endif
+  endif
+  str-addr buf-addr buf-str-len + str-len cmove
+  buf-addr new-len ;
+
+\ define a-space, to append a space char to a string
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
+    pad ! pad 1 str-append ; \ refactoring str-append could perhaps make this faster
+
+: int>str ( num -- str-addr str-len )
+  s>d <# #s #> ;
+
+
+\ === printer protocol and implementations === /
+
+def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
+
+: pr-str { obj }
+    new-str obj pr-buf ;
+
+\ Examples of extending existing protocol methods to existing type
+MalDefault
+  extend pr-buf
+    { this }
+    s" #<MalObject" str-append a-space
+    this int>str str-append
+    s" >" str-append ;;
+drop
+
+MalNil
+  extend pr-buf
+    drop s" nil" str-append ;;
+drop
+
+MalList
+  extend pr-buf
+    -rot s" (" str-append ( list str-addr str-len )
+    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    begin ( list str-addr str-len )
+      2 pick mal-nil <>
+    while
+      a-space
+      rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    repeat
+    s" )" str-append rot drop ;;
+drop
+
+MalInt
+  extend pr-buf
+    MalInt/int @ int>str str-append ;;
+drop
+
+MalSymbol
+  extend pr-buf
+    dup MalSymbol/sym-addr @
+    swap MalSymbol/sym-len @
+    str-append ;;
+drop
diff --git a/forth/reader.fs b/forth/reader.fs
new file mode 100644
index 0000000..6ed9fb5
--- /dev/null
+++ b/forth/reader.fs
@@ -0,0 +1,92 @@
+require types.fs
+require printer.fs
+
+\ Drop a char off the front of string by advancing the addr and
+\ decrementing the length, and fetch next char
+: adv-str ( str-addr str-len -- str-addr str-len char )
+    swap 1+ swap 1-
+    dup 0= if 0 ( eof )
+    else over c@ endif ;
+
+: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
+    begin
+        dup bl =
+    while ( str-addr str-len space-char )
+        drop adv-str
+    repeat ;
+
+: mal-digit? ( char -- flag )
+    dup [char] 9 <= if
+        [char] 0 >=
+    else
+        drop 0
+    endif ;
+
+: char-in-str? ( char str-addr str-len )
+    rot { needle }
+    begin ( str-addr str-len )
+        adv-str needle = if
+            2drop -1 -1 \ success! drop and exit
+        else
+            dup 0= if
+                2drop 0 -1 \ str consumed, char not found.
+            else
+                0 \ continue
+            endif
+        endif
+    until ;
+
+s\" []{}()'\"`,; " constant non-sym-chars-len constant non-sym-chars
+: sym-char? ( char -- flag )
+    non-sym-chars non-sym-chars-len char-in-str? 0= ;
+
+defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
+
+: read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int )
+    0 { int }
+    begin ( str-addr str-len digit-char )
+        [char] 0 - int 10 * + to int ( str-addr str-len )
+        adv-str dup mal-digit? 0= ( str-addr str-len digit-char )
+    until
+    int MalInt. ;
+
+: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len sym-addr sym-len )
+    new-str { sym-addr sym-len }
+    begin ( str-addr srt-len sym-char )
+        sym-addr sym-len rot str-append-char to sym-len to sym-addr
+        adv-str dup sym-char? 0=
+    until
+    sym-addr sym-len ;
+
+: read-list ( str-addr str-len open-paren-char -- str-addr str-len non-paren-char mal-list )
+    \ push objects onto "dictionary" -- maybe not the best stack for this?
+    0 { len }
+    drop adv-str
+    begin ( str-addr str-len char )
+        skip-spaces ( str-addr str-len non-space-char )
+        dup [char] ) <>
+    while ( str-addr str-len non-space-non-paren-char )
+        read-form , len 1+ to len
+    repeat
+    drop adv-str
+
+    \ pop objects out of "dictionary" into MalList
+    mal-nil
+    len 0 ?do
+        0 cell - allot
+        here @ swap conj
+    loop
+    ;
+
+: read-form2 ( str-addr str-len char -- str-addr str-len mal-obj )
+    skip-spaces
+    dup mal-digit? if read-int else
+        dup [char] ( = if read-list else
+            read-symbol-str MalSymbol.
+        endif
+    endif
+    ;
+' read-form2 is read-form
+
+: read-str ( str-addr str-len - mal-obj )
+    over c@ read-form -rot 2drop ;
diff --git a/forth/step0_repl.fs b/forth/step0_repl.fs
index 42c33f5..2483c12 100644
--- a/forth/step0_repl.fs
+++ b/forth/step0_repl.fs
@@ -1,4 +1,4 @@
-s" types.fs" included
+require types.fs
 
 : read ;
 : eval ;
diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs
new file mode 100644
index 0000000..9fe1470
--- /dev/null
+++ b/forth/step1_read_print.fs
@@ -0,0 +1,32 @@
+require reader.fs
+require printer.fs
+
+: read read-str ;
+: eval ;
+: print pr-str ;
+
+: rep
+    read
+    eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      rep safe-type cr
+    repeat ;
+
+\ s" 1   (42 1 (2 12 8)) 35" swap 1+ swap .s read-str .s
+\ s" 7" .s read-str .s
+\ cr
+\ pr-str safe-type cr
+\ new-str s" hello" str-append char ! str-append-char safe-type
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 460c3aa..2b74576 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -1,119 +1,3 @@
-\ === tiny framework for inline tests === /
-: test=
-  2dup = if
-    2drop
-  else
-    cr ." assert failed on line " sourceline# .
-    swap cr ." | got " . cr ." | expected " . cr
-  endif ;
-
-: safe-type ( str-addr str-len -- )
-    dup 256 > if
-        drop 256 type ." ...<lots more>" type
-    else
-        type
-    endif ;
-
-
-\ === mutable string buffer === /
-\ string buffer that maintains an allocation larger than the current
-\ string size.  When appending would cause the string size exceed the
-\ current allocation, resize is used to double the allocation. The
-\ current allocation is not stored anywhere, but computed based on
-\ current string size or str-base-size, whichever is larger.
-64 constant str-base-size
-
-: new-str ( -- addr length )
-  str-base-size allocate throw 0 ;
-
-: round-up ( n -- n )
-  2
-  begin
-    1 lshift 2dup <
-  until
-  swap drop ;
-
-: str-append { buf-addr buf-str-len str-addr str-len }
-  buf-str-len str-len +
-  { new-len }
-  new-len str-base-size > if
-    buf-str-len new-len xor buf-str-len > if
-      buf-addr new-len round-up resize throw
-      to buf-addr
-    endif
-  endif
-  str-addr buf-addr buf-str-len + str-len cmove
-  buf-addr new-len ;
-
-\ define a function to append a space
-bl c,
-here constant space-str
-: a-space space-str 1 str-append ;
-
-: int>str ( num -- str-addr str-len )
-  s>d <# #s #> ;
-
-
-\ === deftype* -- protocol-enabled structs === /
-\ Each type has MalTypeType% struct allocated on the stack, with
-\ mutable fields pointing to all class-shared resources, specifically
-\ the data needed to allocate new instances, and the table of protocol
-\ methods that have been extended to the type.
-\ Use 'deftype*' to define a new type, and 'new' to create new
-\ instances of that type.
-
-struct
-  cell% field mal-type
-  \ cell% field ref-count \ Ha, right.
-end-struct MalType%
-
-struct
-  cell% 2 * field MalTypeType-struct
-  cell% field MalTypeType-methods
-  cell% field MalTypeType-method-keys
-  cell% field MalTypeType-method-vals
-end-struct MalTypeType%
-
-: new ( MalTypeType -- obj )
-  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
-  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
-  ;
-
-: deftype* ( struct-align struct-len -- MalTypeType )
-  MalTypeType% %allot                      ( s-a s-l MalTypeType )
-  dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
-  MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
-  dup MalTypeType-methods     0   swap !   ( MalTypeType )
-  dup MalTypeType-method-keys nil swap !   ( MalTypeType )
-  dup MalTypeType-method-vals nil swap !   ( MalTypeType )
-  ;
-
-MalType% deftype* constant MalDefault
-
-\ nil type and instance to support extending protocols to it
-MalType% deftype* constant MalNil
-MalNil new constant mal-nil
-
-\ Example and tests
-
-MalType%
-  cell% field MalList/car
-  cell% field MalList/cdr
-deftype* constant MalList
-
-: MalList/conj { val coll -- list }
-    MalList new ( list )
-    val over MalList/car ! ( list )
-    coll over MalList/cdr ! ( list )
-    ;
-
-MalList new
-MalList new
-= 0 test=
-
-MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
-
-
 \ === sorted-array === /
 \ Here are a few utility functions useful for creating and maintaining
 \ the deftype* method tables. The keys array is kept in sorted order,
@@ -162,32 +46,46 @@ MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
   a
   ;
 
-\ array function tests
-create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
-
-7 za 2 array-find   -1 test= 0 test=
-7 za 6 array-find   -1 test= 1 test=
-7 za 10 array-find  -1 test= 3 test=
-7 za 81 array-find  -1 test= 6 test=
-7 za 12 array-find   0 test= 4 test=
-7 za 8  array-find   0 test= 3 test=
-7 za 100 array-find  0 test= 7 test=
-7 za 1 array-find    0 test= 0 test=
-
-10 new-array
-1 swap 0  5 array-insert
-2 swap 1  7 array-insert
-3 swap 3 12 array-insert
-4 swap 4 15 array-insert
-5 swap 5 20 array-insert
-
-dup 0 cells + @   5 test=
-dup 1 cells + @   7 test=
-dup 2 cells + @  10 test=
-dup 3 cells + @  12 test=
-dup 4 cells + @  15 test=
-dup 5 cells + @  20 test=
 
+\ === deftype* -- protocol-enabled structs === /
+\ Each type has MalTypeType% struct allocated on the stack, with
+\ mutable fields pointing to all class-shared resources, specifically
+\ the data needed to allocate new instances, and the table of protocol
+\ methods that have been extended to the type.
+\ Use 'deftype*' to define a new type, and 'new' to create new
+\ instances of that type.
+
+struct
+  cell% field mal-type
+  \ cell% field ref-count \ Ha, right.
+end-struct MalType%
+
+struct
+  cell% 2 * field MalTypeType-struct
+  cell% field MalTypeType-methods
+  cell% field MalTypeType-method-keys
+  cell% field MalTypeType-method-vals
+end-struct MalTypeType%
+
+: new ( MalTypeType -- obj )
+  dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
+  dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
+  ;
+
+: deftype* ( struct-align struct-len -- MalTypeType )
+  MalTypeType% %allot                      ( s-a s-l MalTypeType )
+  dup 2swap rot                            ( MalTypeType s-a s-l MalTypeType )
+  MalTypeType-struct 2!                    ( MalTypeType ) \ store struct info
+  dup MalTypeType-methods     0   swap !   ( MalTypeType )
+  dup MalTypeType-method-keys nil swap !   ( MalTypeType )
+  dup MalTypeType-method-vals nil swap !   ( MalTypeType )
+  ;
+
+MalType% deftype* constant MalDefault
+
+\ nil type and instance to support extending protocols to it
+MalType% deftype* constant MalNil
+MalNil new constant mal-nil
 
 \ === protocol methods === /
 
@@ -271,41 +169,32 @@ MalList IPrintable extend
 end-extend
 )
 
-\ Examples of making new protocol methods (without a protocol to group them yet!)
-def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
-def-protocol-method conj ( obj this -- this )
+\ === Mal types and protocols === /
 
-: pr-str { obj }
-    new-str obj pr-buf ;
+MalType%
+  cell% field MalList/car
+  cell% field MalList/cdr
+deftype* constant MalList
+
+: MalList/conj { val coll -- list }
+    MalList new ( list )
+    val over MalList/car ! ( list )
+    coll over MalList/cdr ! ( list )
+    ;
+
+def-protocol-method conj ( obj this -- this )
 
 \ Examples of extending existing protocol methods to existing type
 MalDefault
-  extend pr-buf
-    { this }
-    s" #<MalObject" str-append a-space
-    this int>str str-append
-    s" >" str-append ;;
   extend conj   ( obj this -- this )
     swap drop ;;
 drop
 
 MalNil
-  extend pr-buf
-    drop s" nil" str-append ;;
   ' conj ' MalList/conj extend-method*
 drop
 
 MalList
-  extend pr-buf
-    -rot s" (" str-append ( list str-addr str-len )
-    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
-    begin ( list str-addr str-len )
-      2 pick mal-nil <>
-    while
-      a-space
-      rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
-    repeat
-    s" )" str-append rot drop ;;
   ' conj ' MalList/conj extend-method*
 drop
 
@@ -314,20 +203,17 @@ MalType%
   cell% field MalInt/int
 deftype* constant MalInt
 
-MalInt
-  extend pr-buf
-    MalInt/int @ int>str str-append ;;
-drop
-
 : MalInt. { int -- mal-int }
     MalInt new dup MalInt/int int swap ! ;
 
-
-\ Run some protocol methods!
-
-mal-nil
-42 MalInt. mal-nil conj
-10 MalInt. mal-nil conj conj
-20 MalInt. swap conj
-23 MalInt. mal-nil conj conj conj
-pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
+MalType%
+  cell% field MalSymbol/sym-addr
+  cell% field MalSymbol/sym-len
+  cell% field MalSymbol/meta
+deftype* constant MalSymbol
+
+: MalSymbol. { str-addr str-len -- mal-sym }
+    MalSymbol new { sym }
+    str-addr sym MalSymbol/sym-addr !
+    str-len  sym MalSymbol/sym-len  !
+    sym ;
-- 
cgit v1.2.3


From 50e417ffe32c238189e61c9701696602d40bb7f3 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 6 Feb 2015 02:38:58 -0500
Subject: forth: Add string printing

---
 forth/printer.fs          | 38 ++++++++++++++++++++++++++++++++++++--
 forth/step1_read_print.fs |  1 +
 forth/types.fs            | 15 +++++++++++++--
 3 files changed, 50 insertions(+), 4 deletions(-)

(limited to 'forth')

diff --git a/forth/printer.fs b/forth/printer.fs
index 5ff28e5..8882e13 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -23,7 +23,7 @@ require types.fs
   begin
     1 lshift 2dup <
   until
-  swap drop ;
+  nip ;
 
 : str-append { buf-addr buf-str-len str-addr str-len }
   buf-str-len str-len +
@@ -43,7 +43,7 @@ here constant space-str
 : a-space space-str 1 str-append ;
 
 : str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
-    pad ! pad 1 str-append ; \ refactoring str-append could perhaps make this faster
+    pad ! pad 1 str-append ;
 
 : int>str ( num -- str-addr str-len )
   s>d <# #s #> ;
@@ -94,3 +94,37 @@ MalSymbol
     swap MalSymbol/sym-len @
     str-append ;;
 drop
+
+: insert-\ ( str-addr str-len insert-idx -- str-addr str-len )
+    -rot 0 str-append-char { addr len }
+    dup   dup addr +   dup 1+  ( i i from to )
+    rot len swap - cmove> ( i ) \ shift " etc to the right
+    addr + [char] \ swap c! \ escape it!
+    addr len
+    ;
+
+MalString
+  extend pr-buf
+    dup MalString/str-addr @
+    swap MalString/str-len @
+    { addr len }
+
+    s\" \"" str-append
+    0 ( i )
+    begin
+        dup addr + c@ ( i char )
+        dup [char] " = over [char] \ = or if ( i char )
+            drop dup addr len rot insert-\ to len to addr
+            1+
+        else
+            10 = if ( i ) \ newline?
+                dup addr len rot insert-\ to len to addr
+                dup addr + 1+ [char] n swap c!
+                1+
+            endif
+        endif
+        1+
+    dup len = until
+    drop addr len str-append
+    s\" \"" str-append ;;
+drop
diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs
index 9fe1470..33885d4 100644
--- a/forth/step1_read_print.fs
+++ b/forth/step1_read_print.fs
@@ -26,6 +26,7 @@ create buff 128 allot
 \ cr
 \ pr-str safe-type cr
 \ new-str s" hello" str-append char ! str-append-char safe-type
+\ s\" he\nllo" MalString. pr-str safe-type cr
 
 read-lines
 cr
diff --git a/forth/types.fs b/forth/types.fs
index 2b74576..75996f8 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -22,7 +22,7 @@
       endif
     else
       key > if         ( start end middle )
-        swap drop      ( start middle )
+        nip            ( start middle )
       else
         -rot 2drop dup ( middle middle )
       endif
@@ -187,7 +187,7 @@ def-protocol-method conj ( obj this -- this )
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
-    swap drop ;;
+    nip ;;
 drop
 
 MalNil
@@ -217,3 +217,14 @@ deftype* constant MalSymbol
     str-addr sym MalSymbol/sym-addr !
     str-len  sym MalSymbol/sym-len  !
     sym ;
+
+MalType%
+  cell% field MalString/str-addr
+  cell% field MalString/str-len
+deftype* constant MalString
+
+: MalString. { str-addr str-len -- mal-str }
+    MalString new { str }
+    str-addr str MalString/str-addr !
+    str-len  str MalString/str-len  !
+    str ;
-- 
cgit v1.2.3


From 168fb5dc56fee6653816ee8236259940e575c7ec Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 6 Feb 2015 23:58:41 -0500
Subject: forth: Add step 1, but not maps

---
 forth/printer.fs          | 35 ++++++++++++++++----
 forth/reader.fs           | 81 +++++++++++++++++++++++++++++++++++++++--------
 forth/step1_read_print.fs |  5 ++-
 forth/types.fs            |  4 +++
 4 files changed, 104 insertions(+), 21 deletions(-)

(limited to 'forth')

diff --git a/forth/printer.fs b/forth/printer.fs
index 8882e13..243780a 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -70,9 +70,7 @@ MalNil
     drop s" nil" str-append ;;
 drop
 
-MalList
-  extend pr-buf
-    -rot s" (" str-append ( list str-addr str-len )
+: pr-buf-list ( list str-addr str-len -- str-addr str-len)
     rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
     begin ( list str-addr str-len )
       2 pick mal-nil <>
@@ -80,7 +78,22 @@ MalList
       a-space
       rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
     repeat
-    s" )" str-append rot drop ;;
+    rot drop ;
+
+
+MalList
+  extend pr-buf
+    -rot s" (" str-append ( list str-addr str-len )
+    pr-buf-list
+    s" )" str-append ;;
+drop
+
+MalVector
+  extend pr-buf
+    MalVector/list @
+    -rot s" [" str-append ( list str-addr str-len )
+    pr-buf-list
+    s" ]" str-append ;;
 drop
 
 MalInt
@@ -112,19 +125,27 @@ MalString
     s\" \"" str-append
     0 ( i )
     begin
+        dup len <
+    while
         dup addr + c@ ( i char )
         dup [char] " = over [char] \ = or if ( i char )
             drop dup addr len rot insert-\ to len to addr
             1+
         else
-            10 = if ( i ) \ newline?
-                dup addr len rot insert-\ to len to addr
+            dup 10 = if ( i ) \ newline?
+                drop dup addr len rot insert-\ to len to addr
                 dup addr + 1+ [char] n swap c!
                 1+
+            else
+                13 = if ( i ) \ return?
+                    dup addr len rot insert-\ to len to addr
+                    dup addr + 1+ [char] r swap c!
+                    1+
+                endif
             endif
         endif
         1+
-    dup len = until
+    repeat
     drop addr len str-append
     s\" \"" str-append ;;
 drop
diff --git a/forth/reader.fs b/forth/reader.fs
index 6ed9fb5..57f3e8d 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -1,6 +1,8 @@
 require types.fs
 require printer.fs
 
+-2 constant skip-elem
+
 \ Drop a char off the front of string by advancing the addr and
 \ decrementing the length, and fetch next char
 : adv-str ( str-addr str-len -- str-addr str-len char )
@@ -10,7 +12,11 @@ require printer.fs
 
 : skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
     begin
-        dup bl =
+        dup bl = if
+            -1
+        else
+            dup [char] , =
+        endif
     while ( str-addr str-len space-char )
         drop adv-str
     repeat ;
@@ -50,21 +56,52 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     until
     int MalInt. ;
 
-: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len sym-addr sym-len )
+: read-comment ( str-addr str-len sym-char -- str-addr str-len char skim-elem )
+    drop
+    begin
+        adv-str = 10
+    until
+    adv-str skip-elem ;
+
+: read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len )
     new-str { sym-addr sym-len }
-    begin ( str-addr srt-len sym-char )
+    begin ( str-addr str-len sym-char )
         sym-addr sym-len rot str-append-char to sym-len to sym-addr
         adv-str dup sym-char? 0=
     until
     sym-addr sym-len ;
 
+: read-string-literal ( in-addr in-len quote-char -- in-addr in-len mal-string )
+    new-str { out-addr out-len }
+    drop \ drop leading quote
+    begin ( in-addr in-len )
+        adv-str over 0= if
+            2drop s\" expected '\"', got EOF\n" safe-type 1 throw
+        endif
+        dup [char] " <>
+    while
+        dup [char] \ = if
+            drop adv-str
+            dup [char] n = if drop 10 endif
+            dup [char] r = if drop 13 endif
+        endif
+        out-addr out-len rot str-append-char to out-len to out-addr
+    repeat
+    drop adv-str \ skip trailing quote
+    out-addr out-len MalString. ;
+
 : read-list ( str-addr str-len open-paren-char -- str-addr str-len non-paren-char mal-list )
     \ push objects onto "dictionary" -- maybe not the best stack for this?
-    0 { len }
+    0 { close-char len }
     drop adv-str
     begin ( str-addr str-len char )
         skip-spaces ( str-addr str-len non-space-char )
-        dup [char] ) <>
+        over 0= if
+            drop 2drop
+            s\" expected '" close-char str-append-char
+            s\" ', got EOF" str-append safe-type 1 throw
+        endif
+        dup close-char <>
     while ( str-addr str-len non-space-non-paren-char )
         read-form , len 1+ to len
     repeat
@@ -78,15 +115,33 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     loop
     ;
 
-: read-form2 ( str-addr str-len char -- str-addr str-len mal-obj )
-    skip-spaces
-    dup mal-digit? if read-int else
-        dup [char] ( = if read-list else
+: read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
+    MalSymbol. { sym } ( buf-addr buf-len char )
+    read-form mal-nil conj ( buf-addr buf-len char mal-list )
+    sym swap conj ;
+
+: read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
+    begin
+        skip-spaces
+        dup mal-digit? if read-int else
+        dup [char] ( = if [char] ) read-list else
+        dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+        dup [char] " = if read-string-literal else
+        dup [char] ; = if read-comment else
+        dup [char] @ = if drop adv-str s" deref" read-wrapped else
+        dup [char] ' = if drop adv-str s" quote" read-wrapped else
+        dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
+        dup [char] ~ = if
+            drop adv-str
+            dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
+            else s" unquote" read-wrapped
+            endif
+        else
             read-symbol-str MalSymbol.
-        endif
-    endif
-    ;
+        endif endif endif endif endif endif endif endif endif
+        dup skip-elem =
+    while drop repeat ;
 ' read-form2 is read-form
 
 : read-str ( str-addr str-len - mal-obj )
-    over c@ read-form -rot 2drop ;
+    over c@ read-form { obj } drop 2drop obj ;
diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs
index 33885d4..02783bf 100644
--- a/forth/step1_read_print.fs
+++ b/forth/step1_read_print.fs
@@ -18,7 +18,10 @@ create buff 128 allot
       buff 128 stdin read-line throw
     while
       buff swap
-      rep safe-type cr
+      ['] rep
+      \ execute safe-type
+      catch 0= if safe-type endif
+      cr
     repeat ;
 
 \ s" 1   (42 1 (2 12 8)) 35" swap 1+ swap .s read-str .s
diff --git a/forth/types.fs b/forth/types.fs
index 75996f8..7f6b6ea 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -184,6 +184,10 @@ deftype* constant MalList
 
 def-protocol-method conj ( obj this -- this )
 
+MalType%
+  cell% field MalVector/list
+deftype* constant MalVector
+
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
-- 
cgit v1.2.3


From 2e78e94eb894e511e583db03286a3c13b9ecc780 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 7 Feb 2015 10:01:31 -0500
Subject: forth: Finished step 1

---
 forth/printer.fs | 24 ++++++++++++++++++++----
 forth/reader.fs  | 10 +++++++++-
 forth/types.fs   |  4 ++++
 3 files changed, 33 insertions(+), 5 deletions(-)

(limited to 'forth')

diff --git a/forth/printer.fs b/forth/printer.fs
index 243780a..1244c08 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -70,17 +70,18 @@ MalNil
     drop s" nil" str-append ;;
 drop
 
+: pr-buf-list-item ( list str-addr str-len -- list str-addr str-len)
+    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf ;
+
 : pr-buf-list ( list str-addr str-len -- str-addr str-len)
-    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+    pr-buf-list-item
     begin ( list str-addr str-len )
       2 pick mal-nil <>
     while
-      a-space
-      rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf
+      a-space pr-buf-list-item
     repeat
     rot drop ;
 
-
 MalList
   extend pr-buf
     -rot s" (" str-append ( list str-addr str-len )
@@ -96,6 +97,21 @@ MalVector
     s" ]" str-append ;;
 drop
 
+MalMap
+  extend pr-buf
+    MalMap/list @
+    -rot s" {" str-append ( list str-addr str-len )
+    pr-buf-list-item a-space pr-buf-list-item
+    begin ( list str-addr str-len )
+      2 pick mal-nil <>
+    while
+      s" , " str-append
+      pr-buf-list-item a-space pr-buf-list-item
+    repeat
+    rot drop
+    s" }" str-append ;;
+drop
+
 MalInt
   extend pr-buf
     MalInt/int @ int>str str-append ;;
diff --git a/forth/reader.fs b/forth/reader.fs
index 57f3e8d..7ff46fd 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -126,6 +126,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
         dup mal-digit? if read-int else
         dup [char] ( = if [char] ) read-list else
         dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+        dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
         dup [char] " = if read-string-literal else
         dup [char] ; = if read-comment else
         dup [char] @ = if drop adv-str s" deref" read-wrapped else
@@ -136,9 +137,16 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
             else s" unquote" read-wrapped
             endif
+        else
+        dup [char] ^ = if
+            drop adv-str
+            read-form { meta } read-form { obj }
+            meta mal-nil conj
+            obj swap conj
+            s" with-meta" MalSymbol. swap conj
         else
             read-symbol-str MalSymbol.
-        endif endif endif endif endif endif endif endif endif
+        endif endif endif endif endif endif endif endif endif endif endif
         dup skip-elem =
     while drop repeat ;
 ' read-form2 is read-form
diff --git a/forth/types.fs b/forth/types.fs
index 7f6b6ea..2933448 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -188,6 +188,10 @@ MalType%
   cell% field MalVector/list
 deftype* constant MalVector
 
+MalType%
+  cell% field MalMap/list
+deftype* constant MalMap
+
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
-- 
cgit v1.2.3


From 9da223a35a176d94fbb75cbcc1000871ff5aff0b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 12 Feb 2015 19:27:00 -0500
Subject: forth: Add step 2

---
 forth/misc-tests.fs |  28 ++++++++
 forth/printer.fs    |  72 +++++++++++++++------
 forth/reader.fs     |  30 +++++++--
 forth/step2_eval.fs | 106 ++++++++++++++++++++++++++++++
 forth/types.fs      | 183 +++++++++++++++++++++++++++++++++++++++++++++++++---
 5 files changed, 387 insertions(+), 32 deletions(-)
 create mode 100644 forth/step2_eval.fs

(limited to 'forth')

diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
index 5aaf2f2..c428a12 100644
--- a/forth/misc-tests.fs
+++ b/forth/misc-tests.fs
@@ -51,3 +51,31 @@ mal-nil
 20 MalInt. swap conj
 23 MalInt. mal-nil conj conj conj
 pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
+
+\ map tests
+
+s" one" MalString. s" one" MalString. mal= -1 test=
+s" one" MalString. s" x" MalString. mal= 0 test=
+
+MalMap/Empty
+s" one" MalString. s" first" MalString. rot assoc
+s" two" MalString. s" second" MalString. rot assoc
+s" three" MalString. s" third" MalString. rot assoc
+
+dup 99 s" two" MalString. rot get s" second" MalString. mal= -1 test=
+dup 99 s" none" MalString. rot get 99 test=
+drop
+
+\ eval tests
+
+require step2_eval.fs
+
+mal-nil
+    1 MalInt. swap conj
+    2 MalInt. swap conj
+    3 MalInt. swap conj
+~~
+mal-eval
+~~
+
+bye
diff --git a/forth/printer.fs b/forth/printer.fs
index 1244c08..d85e38b 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -2,7 +2,7 @@ require types.fs
 
 : safe-type ( str-addr str-len -- )
     dup 256 > if
-        drop 256 type ." ...<lots more>" type
+        drop 256 type ." ...<lots more>"
     else
         type
     endif ;
@@ -52,6 +52,8 @@ here constant space-str
 \ === printer protocol and implementations === /
 
 def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-seq-buf ( str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-pairs-buf ( str-addr str-len this -- str-addr str-len )
 
 : pr-str { obj }
     new-str obj pr-buf ;
@@ -73,27 +75,59 @@ drop
 : pr-buf-list-item ( list str-addr str-len -- list str-addr str-len)
     rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf ;
 
-: pr-buf-list ( list str-addr str-len -- str-addr str-len)
-    pr-buf-list-item
+MalList
+  extend pr-buf
+    -rot s" (" str-append ( list str-addr str-len )
+    rot pr-seq-buf
+    s" )" str-append ;;
+  extend pr-seq-buf
+    \ currently assumes list chain through to the end
+    -rot pr-buf-list-item
     begin ( list str-addr str-len )
       2 pick mal-nil <>
     while
       a-space pr-buf-list-item
     repeat
-    rot drop ;
+    rot drop ;;
+  extend pr-pairs-buf
+    -rot pr-buf-list-item a-space pr-buf-list-item
+    begin ( list str-addr str-len )
+      2 pick mal-nil <>
+    while
+      s" , " str-append
+      pr-buf-list-item a-space pr-buf-list-item
+    repeat
+    rot drop ;;
+drop
 
-MalList
+MalArray
   extend pr-buf
     -rot s" (" str-append ( list str-addr str-len )
-    pr-buf-list
+    rot pr-seq-buf
     s" )" str-append ;;
+  extend pr-seq-buf { ary }
+    ary MalArray/start @ { start }
+    start @ pr-buf
+    ary MalArray/count @ 1 ?do
+        a-space
+        start i cells + @ pr-buf
+    loop ;;
+  extend pr-pairs-buf { ary }
+    ary MalArray/start @ { start }
+    start @ pr-buf a-space start cell+ @ pr-buf
+    ary MalArray/count @ 2 / 1 ?do
+        s" , " str-append
+        a-space
+        start i 2 * cells + @ pr-buf a-space
+        start i 2 * 1+ cells + @ pr-buf
+    loop ;;
 drop
 
 MalVector
   extend pr-buf
     MalVector/list @
     -rot s" [" str-append ( list str-addr str-len )
-    pr-buf-list
+    rot pr-seq-buf
     s" ]" str-append ;;
 drop
 
@@ -101,14 +135,7 @@ MalMap
   extend pr-buf
     MalMap/list @
     -rot s" {" str-append ( list str-addr str-len )
-    pr-buf-list-item a-space pr-buf-list-item
-    begin ( list str-addr str-len )
-      2 pick mal-nil <>
-    while
-      s" , " str-append
-      pr-buf-list-item a-space pr-buf-list-item
-    repeat
-    rot drop
+    rot pr-pairs-buf
     s" }" str-append ;;
 drop
 
@@ -117,11 +144,20 @@ MalInt
     MalInt/int @ int>str str-append ;;
 drop
 
+MalFn
+  extend pr-buf
+    drop s" #<fn>" str-append ;;
+drop
+
 MalSymbol
   extend pr-buf
-    dup MalSymbol/sym-addr @
-    swap MalSymbol/sym-len @
-    str-append ;;
+    unpack-sym str-append ;;
+drop
+
+MalKeyword
+  extend pr-buf { kw }
+    s" :" str-append
+    kw unpack-keyword str-append ;;
 drop
 
 : insert-\ ( str-addr str-len insert-idx -- str-addr str-len )
diff --git a/forth/reader.fs b/forth/reader.fs
index 7ff46fd..edd99fc 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -90,7 +90,8 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     drop adv-str \ skip trailing quote
     out-addr out-len MalString. ;
 
-: read-list ( str-addr str-len open-paren-char -- str-addr str-len non-paren-char mal-list )
+: read-list ( str-addr str-len open-paren-char close-paren-char
+              -- str-addr str-len non-paren-char mal-list )
     \ push objects onto "dictionary" -- maybe not the best stack for this?
     0 { close-char len }
     drop adv-str
@@ -112,7 +113,25 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     len 0 ?do
         0 cell - allot
         here @ swap conj
-    loop
+    loop ;
+
+: read-array ( str-addr str-len open-paren-char close-paren-char
+                 -- str-addr str-len non-paren-char mal-array )
+    here { close-char old-here }
+    drop adv-str
+    begin ( str-addr str-len char )
+        skip-spaces ( str-addr str-len non-space-char )
+        over 0= if
+            drop 2drop
+            s\" expected '" close-char str-append-char
+            s\" ', got EOF" str-append safe-type 1 throw
+        endif
+        dup close-char <>
+    while ( str-addr str-len non-space-non-paren-char )
+            read-form ,
+    repeat
+    drop adv-str
+    old-here here>MalArray
     ;
 
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
@@ -124,11 +143,12 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     begin
         skip-spaces
         dup mal-digit? if read-int else
-        dup [char] ( = if [char] ) read-list else
-        dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+        dup [char] ( = if [char] ) read-array else
+        dup [char] [ = if [char] ] read-array MalVector new tuck MalVector/list ! else
         dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
         dup [char] " = if read-string-literal else
         dup [char] ; = if read-comment else
+        dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
         dup [char] @ = if drop adv-str s" deref" read-wrapped else
         dup [char] ' = if drop adv-str s" quote" read-wrapped else
         dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
@@ -146,7 +166,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             s" with-meta" MalSymbol. swap conj
         else
             read-symbol-str MalSymbol.
-        endif endif endif endif endif endif endif endif endif endif endif
+        endif endif endif endif endif endif endif endif endif endif endif endif
         dup skip-elem =
     while drop repeat ;
 ' read-form2 is read-form
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
new file mode 100644
index 0000000..51d1f6f
--- /dev/null
+++ b/forth/step2_eval.fs
@@ -0,0 +1,106 @@
+require reader.fs
+require printer.fs
+
+: args-as-native { argv argc -- entry*argc... }
+    argc 0 ?do
+        argv i cells + @ as-native
+    loop ;
+
+MalMap/Empty
+    s" +" MalSymbol. :noname args-as-native + MalInt. ; MalFn. rot assoc
+    s" -" MalSymbol. :noname args-as-native - MalInt. ; MalFn. rot assoc
+    s" *" MalSymbol. :noname args-as-native * MalInt. ; MalFn. rot assoc
+    s" /" MalSymbol. :noname args-as-native / MalInt. ; MalFn. rot assoc
+value repl-env
+
+def-protocol-method mal-eval ( env ast -- val )
+def-protocol-method mal-eval-ast ( env ast -- val )
+
+MalDefault extend mal-eval nip ;; drop
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+MalArray
+  extend mal-eval { env ary -- val }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalArray instead
+    here { val-start }
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalFn )
+    invoke
+    val-start here - allot ;;
+  extend mal-eval-ast { env ary -- ary }
+    here
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    here>MalArray ;;
+drop
+
+MalList
+  extend mal-eval-ast { env list -- ary }
+    here
+    list
+    begin ( list )
+        dup mal-nil <>
+    while
+        env over MalList/car @ mal-eval ,
+        MalList/cdr @
+    repeat
+    drop here>MalArray ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ mal-eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ mal-eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+: rep ( str -- val )
+    read
+    repl-env swap eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      \ execute safe-type
+      catch 0= if safe-type else ." Caught error" endif
+      cr
+    repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 2933448..2c4d178 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -65,6 +65,8 @@ struct
   cell% field MalTypeType-methods
   cell% field MalTypeType-method-keys
   cell% field MalTypeType-method-vals
+  cell% field MalTypeType-name-addr
+  cell% field MalTypeType-name-len
 end-struct MalTypeType%
 
 : new ( MalTypeType -- obj )
@@ -79,12 +81,31 @@ end-struct MalTypeType%
   dup MalTypeType-methods     0   swap !   ( MalTypeType )
   dup MalTypeType-method-keys nil swap !   ( MalTypeType )
   dup MalTypeType-method-vals nil swap !   ( MalTypeType )
+  dup MalTypeType-name-len    0   swap !   ( MalTypeType )
   ;
 
-MalType% deftype* constant MalDefault
+: deftype ( struct-align struct-len R:type-name -- )
+    parse-name { orig-name-addr name-len }
+    \ parse-name uses temporary space, so copy into dictionary stack:
+    here { name-addr } name-len allot
+    orig-name-addr name-addr name-len cmove
+
+    \ allot and initialize type structure
+    deftype* { mt }
+    name-addr mt MalTypeType-name-addr !
+    name-len  mt MalTypeType-name-len  !
+    \ ." Defining " mt MalTypeType-name-addr @ mt MalTypeType-name-len @ type cr
+    mt name-addr name-len nextname 1 0 const-does> ;
+
+: type-name ( mal-type )
+    dup  MalTypeType-name-addr @ ( mal-type name-addr )
+    swap MalTypeType-name-len @ ( name-addr name-len )
+    ;
+
+MalType% deftype MalDefault
 
 \ nil type and instance to support extending protocols to it
-MalType% deftype* constant MalNil
+MalType% deftype MalNil
 MalNil new constant mal-nil
 
 \ === protocol methods === /
@@ -104,7 +125,15 @@ MalNil new constant mal-nil
     dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
-  0= if ." No implementation found" 1 throw endif
+  0= if ( type idx )
+      2drop
+      ." No protocol fn '"
+      pxt >name name>string type
+      ." ' extended to type '"
+      obj mal-type @ type-name type
+      ." '"
+      1 throw
+  endif
 
   cells swap MalTypeType-method-vals @ + @ ( xt )
   obj swap execute
@@ -174,7 +203,7 @@ end-extend
 MalType%
   cell% field MalList/car
   cell% field MalList/cdr
-deftype* constant MalList
+deftype MalList
 
 : MalList/conj { val coll -- list }
     MalList new ( list )
@@ -182,24 +211,77 @@ deftype* constant MalList
     coll over MalList/cdr ! ( list )
     ;
 
+MalType%
+  cell% field MalArray/count
+  cell% field MalArray/start
+deftype MalArray
+
+: here>MalArray ( old-here -- mal-array )
+    here over - { bytes } ( old-here )
+    MalArray new bytes ( old-here mal-array bytes )
+    allocate throw dup { target } over MalArray/start ! ( old-here mal-array )
+    bytes cell / over MalArray/count ! ( old-here mal-array )
+    swap target bytes cmove ( mal-array )
+    0 bytes - allot \ pop array contents from dictionary stack
+    ;
+
 def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj --  )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 MalType%
   cell% field MalVector/list
-deftype* constant MalVector
+deftype MalVector
 
 MalType%
   cell% field MalMap/list
-deftype* constant MalMap
+deftype MalMap
+
+MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
+
+MalMap
+  extend conj ( kv map -- map )
+    MalMap/list @ \ get list
+    over MalList/cdr @ MalList/car @ conj \ add value
+    swap MalList/car @ conj \ add key
+    MalMap new MalMap/list ! \ put back in map
+    ;;
+  extend assoc ( k v map -- map )
+    MalMap/list @ \ get list
+    conj conj
+    MalMap new dup -rot MalMap/list ! \ put back in map
+    ;;
+  extend get ( not-found k map -- value )
+    -rot { not-found k }
+    MalMap/list @ \ get list
+    begin
+        dup MalList/cdr @
+        swap MalList/car @ k mal= if
+            MalList/car @ -1 \ found it
+        else
+            MalList/cdr @
+            dup mal-nil = if
+                not-found -1
+            else
+                0
+            endif
+        endif
+    until ;;
+drop
 
 \ Examples of extending existing protocol methods to existing type
 MalDefault
   extend conj   ( obj this -- this )
     nip ;;
+  extend as-native ;; ( obj -- obj )
 drop
 
 MalNil
   ' conj ' MalList/conj extend-method*
+  extend as-native drop 0 ;;
 drop
 
 MalList
@@ -209,30 +291,113 @@ drop
 
 MalType%
   cell% field MalInt/int
-deftype* constant MalInt
+deftype MalInt
 
 : MalInt. { int -- mal-int }
     MalInt new dup MalInt/int int swap ! ;
 
+MalInt
+  extend as-native ( mal-int -- int )
+    MalInt/int @ ;;
+drop
+
 MalType%
   cell% field MalSymbol/sym-addr
   cell% field MalSymbol/sym-len
   cell% field MalSymbol/meta
-deftype* constant MalSymbol
+deftype MalSymbol
 
 : MalSymbol. { str-addr str-len -- mal-sym }
     MalSymbol new { sym }
     str-addr sym MalSymbol/sym-addr !
     str-len  sym MalSymbol/sym-len  !
+    MalMap/Empty sym MalSymbol/meta  !
     sym ;
 
+: unpack-sym ( mal-string -- addr len )
+    dup MalSymbol/sym-addr @
+    swap MalSymbol/sym-len @ ;
+
+MalSymbol
+  extend mal= ( other this -- bool )
+    over mal-type @ MalSymbol = if
+        unpack-sym rot unpack-sym str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-sym extend-method*
+drop
+
+MalType%
+  cell% field MalKeyword/str-addr
+  cell% field MalKeyword/str-len
+deftype MalKeyword
+
+: unpack-keyword ( mal-keyword -- addr len )
+    dup MalKeyword/str-addr @
+    swap MalKeyword/str-len @ ;
+
+MalKeyword
+  extend mal= ( other this -- bool )
+    over mal-type @ MalKeyword = if
+        unpack-keyword rot unpack-keyword str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-keyword extend-method*
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+: MalKeyword. { str-addr str-len -- mal-keyword }
+    MalKeyword new { kw }
+    str-addr kw MalKeyword/str-addr !
+    str-len  kw MalKeyword/str-len  !
+    kw ;
+
 MalType%
   cell% field MalString/str-addr
   cell% field MalString/str-len
-deftype* constant MalString
+deftype MalString
 
 : MalString. { str-addr str-len -- mal-str }
     MalString new { str }
     str-addr str MalString/str-addr !
     str-len  str MalString/str-len  !
     str ;
+
+: unpack-str ( mal-string -- addr len )
+    dup MalString/str-addr @
+    swap MalString/str-len @ ;
+
+MalString
+  extend mal= ( other this -- bool )
+    over mal-type @ MalString = if
+        unpack-str rot unpack-str str=
+    else
+        2drop 0
+    endif ;;
+  ' as-native ' unpack-str extend-method*
+drop
+
+
+MalType%
+  cell% field MalFn/xt
+  cell% field MalFn/meta
+deftype MalFn
+
+: MalFn. { xt -- mal-fn }
+    MalFn new { mal-fn }
+    xt mal-fn MalFn/xt !
+    MalMap/Empty mal-fn MalFn/meta  !
+    mal-fn ;
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+  extend as-native
+    MalFn/xt @ ;;
+drop
-- 
cgit v1.2.3


From 69972a8399efe4abb8567526e90262e131f90d26 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 13:40:07 -0500
Subject: forth: Add step 3

---
 forth/env.fs        |  45 +++++++++++++++
 forth/misc-tests.fs |  28 +++++++--
 forth/printer.fs    |   5 ++
 forth/reader.fs     |   9 +--
 forth/step2_eval.fs |  14 +++++
 forth/step3_env.fs  | 160 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs      |  93 +++++++++++++++++++++---------
 7 files changed, 316 insertions(+), 38 deletions(-)
 create mode 100644 forth/env.fs
 create mode 100644 forth/step3_env.fs

(limited to 'forth')

diff --git a/forth/env.fs b/forth/env.fs
new file mode 100644
index 0000000..c1dc278
--- /dev/null
+++ b/forth/env.fs
@@ -0,0 +1,45 @@
+require types.fs
+
+MalType%
+   cell% field MalEnv/outer
+   cell% field MalEnv/data
+deftype MalEnv
+
+: MalEnv. { outer -- env }
+    MalEnv new { env }
+    outer env MalEnv/outer !
+    MalMap/Empty env MalEnv/data !
+    env ;
+
+: env/set { key val env -- }
+    key val env MalEnv/data @ assoc
+    env MalEnv/data ! ;
+
+: env/find { key env -- env-or-0 }
+    env
+    begin ( env )
+        dup 0 key rot MalEnv/data @ get ( env val-or-0 )
+        0= if ( env )
+            MalEnv/outer @ dup 0= ( env-or-0 done-looping? )
+        else
+            -1 \ found it! ( env -1 )
+        endif
+    until ;
+
+MalEnv
+  extend get { not-found key env -- }
+    key env env/find ( env-or-0 )
+    ?dup 0= if
+        not-found
+    else ( env )
+        not-found key rot MalEnv/data @ get
+    endif ;;
+  extend pr-buf { env }
+    env MalEnv/data @ pr-buf
+    a-space s" outer: " str-append
+    env MalEnv/outer @ ?dup 0= if
+        s" <none>" str-append
+    else
+        pr-buf
+    endif ;;
+drop
\ No newline at end of file
diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
index c428a12..ede5119 100644
--- a/forth/misc-tests.fs
+++ b/forth/misc-tests.fs
@@ -2,7 +2,7 @@ require printer.fs
 
 \ === basic testing util === /
 : test=
-  2dup = if
+  2dup m= if
     2drop
   else
     cr ." assert failed on line " sourceline# .
@@ -52,20 +52,38 @@ mal-nil
 23 MalInt. mal-nil conj conj conj
 pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
 
+\ MalArray tests
+
+here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalArray
+4 MalInt. swap conj
+5 MalInt. swap conj
+pr-str s" (5 4 1 2 3)" str= -1 test=
+
 \ map tests
 
-s" one" MalString. s" one" MalString. mal= -1 test=
-s" one" MalString. s" x" MalString. mal= 0 test=
+s" one" MalString. s" one" MalString. test=
+s" one" MalString. s" x" MalString. m= 0 test=
+
+MalMap/Empty
+1000 MalInt. 1100 rot assoc
+2000 MalInt. 2100 rot assoc
+3000 MalInt. 3100 rot assoc
+
+dup 99 2000 MalInt. rot get 2100 test=
+dup 99 4000 MalInt. rot get 99 test=
+drop
 
 MalMap/Empty
 s" one" MalString. s" first" MalString. rot assoc
 s" two" MalString. s" second" MalString. rot assoc
 s" three" MalString. s" third" MalString. rot assoc
 
-dup 99 s" two" MalString. rot get s" second" MalString. mal= -1 test=
+dup 99 s" two" MalString. rot get s" second" MalString. test=
 dup 99 s" none" MalString. rot get 99 test=
 drop
 
+99 MalInt. 10 MalInt. MalMap/Empty get 99 MalInt. test=
+
 \ eval tests
 
 require step2_eval.fs
@@ -74,8 +92,6 @@ mal-nil
     1 MalInt. swap conj
     2 MalInt. swap conj
     3 MalInt. swap conj
-~~
 mal-eval
-~~
 
 bye
diff --git a/forth/printer.fs b/forth/printer.fs
index d85e38b..cc376e6 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -149,6 +149,11 @@ MalFn
     drop s" #<fn>" str-append ;;
 drop
 
+SpecialOp
+  extend pr-buf
+    drop s" #<op>" str-append ;;
+drop
+
 MalSymbol
   extend pr-buf
     unpack-sym str-append ;;
diff --git a/forth/reader.fs b/forth/reader.fs
index edd99fc..8f7e3e3 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -135,9 +135,10 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     ;
 
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
-    MalSymbol. { sym } ( buf-addr buf-len char )
-    read-form mal-nil conj ( buf-addr buf-len char mal-list )
-    sym swap conj ;
+    here { old-here }
+    MalSymbol. , ( buf-addr buf-len char )
+    read-form , ( buf-addr buf-len char )
+    old-here here>MalArray ;
 
 : read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
     begin
@@ -145,7 +146,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
         dup mal-digit? if read-int else
         dup [char] ( = if [char] ) read-array else
         dup [char] [ = if [char] ] read-array MalVector new tuck MalVector/list ! else
-        dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
+        dup [char] { = if [char] } read-array MalMap new tuck MalMap/list ! else
         dup [char] " = if read-string-literal else
         dup [char] ; = if read-comment else
         dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
index 51d1f6f..33ceb4e 100644
--- a/forth/step2_eval.fs
+++ b/forth/step2_eval.fs
@@ -15,9 +15,23 @@ value repl-env
 
 def-protocol-method mal-eval ( env ast -- val )
 def-protocol-method mal-eval-ast ( env ast -- val )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 MalDefault extend mal-eval nip ;; drop
 
+MalKeyword
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+drop
+
 MalSymbol
   extend mal-eval { env sym -- val }
     0 sym env get
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
new file mode 100644
index 0000000..4b76c4d
--- /dev/null
+++ b/forth/step3_env.fs
@@ -0,0 +1,160 @@
+require reader.fs
+require printer.fs
+require env.fs
+
+: args-as-native { argv argc -- entry*argc... }
+    argc 0 ?do
+        argv i cells + @ as-native
+    loop ;
+
+0 MalEnv. constant repl-env
+s" +" MalSymbol.  :noname args-as-native + MalInt. ; MalFn.  repl-env env/set
+s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalFn.  repl-env env/set
+s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalFn.  repl-env env/set
+s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalFn.  repl-env env/set
+
+def-protocol-method mal-eval ( env ast -- val )
+def-protocol-method mal-eval-ast ( env ast -- val )
+def-protocol-method invoke+ ( env arty -- ... )
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+MalDefault extend mal-eval nip ;; drop
+
+MalKeyword
+  extend invoke { argv argc kw -- val }
+    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
+    kw \ key
+    argv @ \ map
+    get ;;
+drop
+
+MalFn
+  extend invoke ( ... mal-fn -- ... )
+    MalFn/xt @ execute ;;
+
+  extend invoke+ { env ary this -- ary }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalArray instead
+    \ Normal list, evaluate and invoke
+    here { val-start }
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 1 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    val-start  here val-start - cell /  this  ( argv argc MalFn )
+    invoke
+    val-start here - allot ;;
+drop
+
+SpecialOp
+  extend invoke+ ( env ary this -- ary )
+    SpecialOp/xt @ execute ;;
+drop
+
+s" quote" MalSymbol. :noname ( env ary -- form )
+    nip MalArray/start @ cell+ @
+; SpecialOp. repl-env env/set
+
+s" def!" MalSymbol. :noname { env ary -- }
+    ary MalArray/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ mal-eval dup { val } ( key val )
+    env env/set
+    val
+; SpecialOp. repl-env env/set
+
+s" let*" MalSymbol. :noname { old-env ary -- }
+    old-env MalEnv. { env }
+    ary MalArray/start @ cell+ dup { arg0 }
+    @ to-array
+    dup MalArray/start @ { bindings-start } ( ary )
+    MalArray/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap mal-eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ mal-eval
+    \ TODO: dec refcount of env
+; SpecialOp. repl-env env/set
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+MalArray
+  extend mal-eval { env ary -- val }
+    env ary MalArray/start @ @ mal-eval
+    env ary rot invoke+ ;;
+
+  extend mal-eval-ast { env ary -- ary }
+    here
+    ary MalArray/start @ { expr-start }
+    ary MalArray/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    here>MalArray ;;
+drop
+
+MalList
+  extend mal-eval-ast { env list -- ary }
+    here
+    list
+    begin ( list )
+        dup mal-nil <>
+    while
+        env over MalList/car @ mal-eval ,
+        MalList/cdr @
+    repeat
+    drop here>MalArray ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ mal-eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ mal-eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+: rep ( str -- val )
+    read
+    repl-env swap eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      42042042042
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute safe-type
+      \ catch 0= if safe-type else ." Caught error" endif
+      cr
+      42042042042 <> if ." --stack leak--" cr endif
+    repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 2c4d178..a8268a3 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -200,6 +200,20 @@ end-extend
 
 \ === Mal types and protocols === /
 
+def-protocol-method conj ( obj this -- this )
+def-protocol-method assoc ( k v this -- this )
+def-protocol-method get ( not-found k this -- value )
+def-protocol-method mal= ( a b -- bool )
+def-protocol-method as-native ( obj --  )
+def-protocol-method to-array ( obj -- mal-array )
+
+: m= ( a b -- bool )
+    2dup = if
+        2drop -1
+    else
+        mal=
+    endif ;
+
 MalType%
   cell% field MalList/car
   cell% field MalList/cdr
@@ -225,48 +239,63 @@ deftype MalArray
     0 bytes - allot \ pop array contents from dictionary stack
     ;
 
-def-protocol-method conj ( obj this -- this )
-def-protocol-method assoc ( k v this -- this )
-def-protocol-method get ( not-found k this -- value )
-def-protocol-method mal= ( a b -- bool )
-def-protocol-method as-native ( obj --  )
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+MalArray
+  extend to-array ;;
+  extend conj { elem old-ary -- ary }
+    old-ary MalArray/count @ 1+ { new-count }
+    new-count cells allocate throw { new-start }
+    elem new-start !
+    new-count 1 > if
+      old-ary MalArray/start @   new-start cell+   new-count 1- cells  cmove
+    endif
+
+    MalArray new
+    new-count over MalArray/count !
+    new-start over MalArray/start ! ;;
+drop
+
+MalArray new 0 over MalArray/count ! constant MalArray/Empty
 
 MalType%
   cell% field MalVector/list
 deftype MalVector
 
+MalVector
+  extend to-array
+    MalVector/list @ to-array ;;
+drop
+
 MalType%
   cell% field MalMap/list
 deftype MalMap
 
-MalMap new mal-nil over MalMap/list ! constant MalMap/Empty
+MalMap new MalArray/Empty over MalMap/list ! constant MalMap/Empty
 
 MalMap
   extend conj ( kv map -- map )
     MalMap/list @ \ get list
-    over MalList/cdr @ MalList/car @ conj \ add value
-    swap MalList/car @ conj \ add key
-    MalMap new MalMap/list ! \ put back in map
+    over MalArray/start @ cell+ @ swap conj \ add value
+    swap MalArray/start @ @ swap conj \ add key
+    MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend assoc ( k v map -- map )
     MalMap/list @ \ get list
-    conj conj
+    conj conj 
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
-  extend get ( not-found k map -- value )
-    -rot { not-found k }
-    MalMap/list @ \ get list
+  extend get { not-found k map -- value }
+    map MalMap/list @
+    dup MalArray/start @ { start }
+    MalArray/count @ { count }
+    0
     begin
-        dup MalList/cdr @
-        swap MalList/car @ k mal= if
-            MalList/car @ -1 \ found it
+        dup count >= if
+            drop not-found -1
         else
-            MalList/cdr @
-            dup mal-nil = if
-                not-found -1
+            start over cells + @ k m= if
+                start swap cells + cell+ @ -1 \ found it ( value -1 )
             else
-                0
+                2 + 0
             endif
         endif
     until ;;
@@ -297,6 +326,13 @@ deftype MalInt
     MalInt new dup MalInt/int int swap ! ;
 
 MalInt
+  extend mal= ( other this -- bool )
+    over mal-type @ MalInt = if
+        MalInt/int @ swap MalInt/int @ =
+    else
+        2drop 0
+    endif ;;
+
   extend as-native ( mal-int -- int )
     MalInt/int @ ;;
 drop
@@ -345,11 +381,6 @@ MalKeyword
         2drop 0
     endif ;;
   ' as-native ' unpack-keyword extend-method*
-  extend invoke { argv argc kw -- val }
-    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
-    kw \ key
-    argv @ \ map
-    get ;;
 drop
 
 : MalKeyword. { str-addr str-len -- mal-keyword }
@@ -396,8 +427,14 @@ deftype MalFn
     mal-fn ;
 
 MalFn
-  extend invoke ( ... mal-fn -- ... )
-    MalFn/xt @ execute ;;
   extend as-native
     MalFn/xt @ ;;
 drop
+
+
+MalType%
+  cell% field SpecialOp/xt
+deftype SpecialOp
+
+: SpecialOp.
+    SpecialOp new swap over SpecialOp/xt ! ;
-- 
cgit v1.2.3


From c05d35e8dd1ebbc371d7c9239d788ddf844eae31 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 15:18:18 -0500
Subject: forth: Get rid of car/cdr style lists

Rename MalArray to MalList
---
 forth/env.fs        |  2 +-
 forth/misc-tests.fs | 13 +++-----
 forth/printer.fs    | 40 ++++--------------------
 forth/reader.fs     | 37 ++++-------------------
 forth/step2_eval.fs | 31 ++++++-------------
 forth/step3_env.fs  | 57 ++++++++++++++---------------------
 forth/types.fs      | 87 +++++++++++++++++++++++++----------------------------
 7 files changed, 89 insertions(+), 178 deletions(-)

(limited to 'forth')

diff --git a/forth/env.fs b/forth/env.fs
index c1dc278..1b5a362 100644
--- a/forth/env.fs
+++ b/forth/env.fs
@@ -42,4 +42,4 @@ MalEnv
     else
         pr-buf
     endif ;;
-drop
\ No newline at end of file
+drop
diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
index ede5119..2526067 100644
--- a/forth/misc-tests.fs
+++ b/forth/misc-tests.fs
@@ -36,13 +36,6 @@ dup 4 cells + @  15 test=
 dup 5 cells + @  20 test=
 
 
-\ MalType tests
-
-MalList new   MalList new   = 0 test=
-
-MalList new dup MalList/car 5 swap ! MalList/car @   5 test=
-
-
 \ Protocol tests
 
 mal-nil
@@ -52,9 +45,11 @@ mal-nil
 23 MalInt. mal-nil conj conj conj
 pr-str s" (nil (20 (42) 10) 23)" str= -1 test=
 
-\ MalArray tests
+1500 MalInt. 1500 MalInt. test=
+
+\ MalList tests
 
-here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalArray
+here 1 MalInt. , 2 MalInt. , 3 MalInt. , here>MalList
 4 MalInt. swap conj
 5 MalInt. swap conj
 pr-str s" (5 4 1 2 3)" str= -1 test=
diff --git a/forth/printer.fs b/forth/printer.fs
index cc376e6..78ac197 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -72,50 +72,22 @@ MalNil
     drop s" nil" str-append ;;
 drop
 
-: pr-buf-list-item ( list str-addr str-len -- list str-addr str-len)
-    rot dup MalList/cdr @ swap MalList/car @ 2swap rot pr-buf ;
-
 MalList
   extend pr-buf
     -rot s" (" str-append ( list str-addr str-len )
     rot pr-seq-buf
     s" )" str-append ;;
-  extend pr-seq-buf
-    \ currently assumes list chain through to the end
-    -rot pr-buf-list-item
-    begin ( list str-addr str-len )
-      2 pick mal-nil <>
-    while
-      a-space pr-buf-list-item
-    repeat
-    rot drop ;;
-  extend pr-pairs-buf
-    -rot pr-buf-list-item a-space pr-buf-list-item
-    begin ( list str-addr str-len )
-      2 pick mal-nil <>
-    while
-      s" , " str-append
-      pr-buf-list-item a-space pr-buf-list-item
-    repeat
-    rot drop ;;
-drop
-
-MalArray
-  extend pr-buf
-    -rot s" (" str-append ( list str-addr str-len )
-    rot pr-seq-buf
-    s" )" str-append ;;
-  extend pr-seq-buf { ary }
-    ary MalArray/start @ { start }
+  extend pr-seq-buf { list }
+    list MalList/start @ { start }
     start @ pr-buf
-    ary MalArray/count @ 1 ?do
+    list MalList/count @ 1 ?do
         a-space
         start i cells + @ pr-buf
     loop ;;
-  extend pr-pairs-buf { ary }
-    ary MalArray/start @ { start }
+  extend pr-pairs-buf { list }
+    list MalList/start @ { start }
     start @ pr-buf a-space start cell+ @ pr-buf
-    ary MalArray/count @ 2 / 1 ?do
+    list MalList/count @ 2 / 1 ?do
         s" , " str-append
         a-space
         start i 2 * cells + @ pr-buf a-space
diff --git a/forth/reader.fs b/forth/reader.fs
index 8f7e3e3..f65db2c 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -91,32 +91,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     out-addr out-len MalString. ;
 
 : read-list ( str-addr str-len open-paren-char close-paren-char
-              -- str-addr str-len non-paren-char mal-list )
-    \ push objects onto "dictionary" -- maybe not the best stack for this?
-    0 { close-char len }
-    drop adv-str
-    begin ( str-addr str-len char )
-        skip-spaces ( str-addr str-len non-space-char )
-        over 0= if
-            drop 2drop
-            s\" expected '" close-char str-append-char
-            s\" ', got EOF" str-append safe-type 1 throw
-        endif
-        dup close-char <>
-    while ( str-addr str-len non-space-non-paren-char )
-        read-form , len 1+ to len
-    repeat
-    drop adv-str
-
-    \ pop objects out of "dictionary" into MalList
-    mal-nil
-    len 0 ?do
-        0 cell - allot
-        here @ swap conj
-    loop ;
-
-: read-array ( str-addr str-len open-paren-char close-paren-char
-                 -- str-addr str-len non-paren-char mal-array )
+                  -- str-addr str-len non-paren-char mal-list )
     here { close-char old-here }
     drop adv-str
     begin ( str-addr str-len char )
@@ -131,22 +106,22 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             read-form ,
     repeat
     drop adv-str
-    old-here here>MalArray
+    old-here here>MalList
     ;
 
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
     here { old-here }
     MalSymbol. , ( buf-addr buf-len char )
     read-form , ( buf-addr buf-len char )
-    old-here here>MalArray ;
+    old-here here>MalList ;
 
 : read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
     begin
         skip-spaces
         dup mal-digit? if read-int else
-        dup [char] ( = if [char] ) read-array else
-        dup [char] [ = if [char] ] read-array MalVector new tuck MalVector/list ! else
-        dup [char] { = if [char] } read-array MalMap new tuck MalMap/list ! else
+        dup [char] ( = if [char] ) read-list else
+        dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+        dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
         dup [char] " = if read-string-literal else
         dup [char] ; = if read-comment else
         dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
index 33ceb4e..6a9af72 100644
--- a/forth/step2_eval.fs
+++ b/forth/step2_eval.fs
@@ -44,38 +44,25 @@ MalSymbol
     endif ;;
 drop
 
-MalArray
-  extend mal-eval { env ary -- val }
+MalList
+  extend mal-eval { env list -- val }
     \ Pass args on dictionary stack (!)
-    \ TODO: consider allocate and free of a real MalArray instead
+    \ TODO: consider allocate and free of a real MalList instead
     here { val-start }
-    ary MalArray/start @ { expr-start }
-    ary MalArray/count @ 0 ?do
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
     val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalFn )
     invoke
     val-start here - allot ;;
-  extend mal-eval-ast { env ary -- ary }
+  extend mal-eval-ast { env list -- list }
     here
-    ary MalArray/start @ { expr-start }
-    ary MalArray/count @ 0 ?do
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    here>MalArray ;;
-drop
-
-MalList
-  extend mal-eval-ast { env list -- ary }
-    here
-    list
-    begin ( list )
-        dup mal-nil <>
-    while
-        env over MalList/car @ mal-eval ,
-        MalList/cdr @
-    repeat
-    drop here>MalArray ;;
+    here>MalList ;;
 drop
 
 MalVector
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index 4b76c4d..269964d 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -32,13 +32,13 @@ MalFn
   extend invoke ( ... mal-fn -- ... )
     MalFn/xt @ execute ;;
 
-  extend invoke+ { env ary this -- ary }
+  extend invoke+ { env list this -- list }
     \ Pass args on dictionary stack (!)
-    \ TODO: consider allocate and free of a real MalArray instead
+    \ TODO: consider allocate and free of a real MalList instead
     \ Normal list, evaluate and invoke
     here { val-start }
-    ary MalArray/start @ { expr-start }
-    ary MalArray/count @ 1 ?do
+    list MalList/start @ { expr-start }
+    list MalList/count @ 1 ?do
         env expr-start i cells + @ mal-eval ,
     loop
     val-start  here val-start - cell /  this  ( argv argc MalFn )
@@ -47,28 +47,28 @@ MalFn
 drop
 
 SpecialOp
-  extend invoke+ ( env ary this -- ary )
+  extend invoke+ ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
-s" quote" MalSymbol. :noname ( env ary -- form )
-    nip MalArray/start @ cell+ @
+s" quote" MalSymbol. :noname ( env list -- form )
+    nip MalList/start @ cell+ @
 ; SpecialOp. repl-env env/set
 
-s" def!" MalSymbol. :noname { env ary -- }
-    ary MalArray/start @ cell+ { arg0 }
+s" def!" MalSymbol. :noname { env list -- }
+    list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
     env arg0 cell+ @ mal-eval dup { val } ( key val )
     env env/set
     val
 ; SpecialOp. repl-env env/set
 
-s" let*" MalSymbol. :noname { old-env ary -- }
+s" let*" MalSymbol. :noname { old-env list -- }
     old-env MalEnv. { env }
-    ary MalArray/start @ cell+ dup { arg0 }
-    @ to-array
-    dup MalArray/start @ { bindings-start } ( ary )
-    MalArray/count @ 0 +do
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
         env swap mal-eval
         env env/set
@@ -89,31 +89,18 @@ MalSymbol
     endif ;;
 drop
 
-MalArray
-  extend mal-eval { env ary -- val }
-    env ary MalArray/start @ @ mal-eval
-    env ary rot invoke+ ;;
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ mal-eval
+    env list rot invoke+ ;;
 
-  extend mal-eval-ast { env ary -- ary }
+  extend mal-eval-ast { env list -- list }
     here
-    ary MalArray/start @ { expr-start }
-    ary MalArray/count @ 0 ?do
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    here>MalArray ;;
-drop
-
-MalList
-  extend mal-eval-ast { env list -- ary }
-    here
-    list
-    begin ( list )
-        dup mal-nil <>
-    while
-        env over MalList/car @ mal-eval ,
-        MalList/cdr @
-    repeat
-    drop here>MalArray ;;
+    here>MalList ;;
 drop
 
 MalVector
diff --git a/forth/types.fs b/forth/types.fs
index a8268a3..305ff31 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -108,21 +108,32 @@ MalType% deftype MalDefault
 MalType% deftype MalNil
 MalNil new constant mal-nil
 
+: not-object? ( obj -- bool )
+    dup 7 and 0 <> if
+        drop -1
+    else
+        1000000 <
+    endif ;
+
 \ === protocol methods === /
 
 \ Used by protocol methods to find the appropriate implementation of
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
+  obj not-object? if
+      ." Refusing to invoke protocol fn '"
+      pxt >name name>string type
+      ." ' on non-object: " obj .
+      1 throw
+  endif
   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
   dup 0= if \ No protocols extended to this type; check for a default
     2drop drop MalDefault MalTypeType-methods 2@ swap
   endif
-  dup 0= if ." No protocols extended to this type or MalDefault" 1 throw endif
 
   pxt array-find ( type idx found? )
   dup 0= if \ No implementation found for this method; check for a default
     2drop drop MalDefault dup MalTypeType-methods 2@ swap
-    dup 0= if ." No implementation found for this method, and no protocols extended to MalDefault" 1 throw endif
     pxt array-find ( type idx found? )
   endif
   0= if ( type idx )
@@ -157,10 +168,8 @@ MalNil new constant mal-nil
       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
       1- dup type MalTypeType-method-keys @ idx pxt array-insert ( old-count new-array )
         type MalTypeType-method-keys ! ( old-count )
-      \ cr ." before: " MalList MalTypeType-method-vals @ @ . cr
       type MalTypeType-method-vals @ idx ixt array-insert ( new-array )
         type MalTypeType-method-vals !
-      \ cr ." after: " MalList MalTypeType-method-vals @ @ . cr
     endif
   endif
   type
@@ -205,7 +214,7 @@ def-protocol-method assoc ( k v this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
-def-protocol-method to-array ( obj -- mal-array )
+def-protocol-method to-list ( obj -- mal-list )
 
 : m= ( a b -- bool )
     2dup = if
@@ -215,78 +224,67 @@ def-protocol-method to-array ( obj -- mal-array )
     endif ;
 
 MalType%
-  cell% field MalList/car
-  cell% field MalList/cdr
+  cell% field MalList/count
+  cell% field MalList/start
 deftype MalList
 
-: MalList/conj { val coll -- list }
-    MalList new ( list )
-    val over MalList/car ! ( list )
-    coll over MalList/cdr ! ( list )
-    ;
-
-MalType%
-  cell% field MalArray/count
-  cell% field MalArray/start
-deftype MalArray
-
-: here>MalArray ( old-here -- mal-array )
+: here>MalList ( old-here -- mal-list )
     here over - { bytes } ( old-here )
-    MalArray new bytes ( old-here mal-array bytes )
-    allocate throw dup { target } over MalArray/start ! ( old-here mal-array )
-    bytes cell / over MalArray/count ! ( old-here mal-array )
-    swap target bytes cmove ( mal-array )
-    0 bytes - allot \ pop array contents from dictionary stack
+    MalList new bytes ( old-here mal-list bytes )
+    allocate throw dup { target } over MalList/start ! ( old-here mal-list )
+    bytes cell / over MalList/count ! ( old-here mal-list )
+    swap target bytes cmove ( mal-list )
+    0 bytes - allot \ pop list contents from dictionary stack
     ;
 
-MalArray
-  extend to-array ;;
-  extend conj { elem old-ary -- ary }
-    old-ary MalArray/count @ 1+ { new-count }
+MalList
+  extend to-list ;;
+  extend conj { elem old-list -- list }
+    old-list MalList/count @ 1+ { new-count }
     new-count cells allocate throw { new-start }
     elem new-start !
     new-count 1 > if
-      old-ary MalArray/start @   new-start cell+   new-count 1- cells  cmove
+      old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
     endif
 
-    MalArray new
-    new-count over MalArray/count !
-    new-start over MalArray/start ! ;;
+    MalList new
+    new-count over MalList/count !
+    new-start over MalList/start ! ;;
 drop
 
-MalArray new 0 over MalArray/count ! constant MalArray/Empty
+MalList new 0 over MalList/count ! constant MalList/Empty
 
 MalType%
   cell% field MalVector/list
 deftype MalVector
 
 MalVector
-  extend to-array
-    MalVector/list @ to-array ;;
+  extend to-list
+    MalVector/list @ to-list ;;
 drop
 
 MalType%
   cell% field MalMap/list
 deftype MalMap
 
-MalMap new MalArray/Empty over MalMap/list ! constant MalMap/Empty
+MalMap new MalList/Empty over MalMap/list ! constant MalMap/Empty
 
 MalMap
   extend conj ( kv map -- map )
     MalMap/list @ \ get list
-    over MalArray/start @ cell+ @ swap conj \ add value
-    swap MalArray/start @ @ swap conj \ add key
+    over MalList/start @ cell+ @ swap conj \ add value
+    swap MalList/start @ @ swap conj \ add key
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend assoc ( k v map -- map )
     MalMap/list @ \ get list
-    conj conj 
+    conj conj
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
   extend get { not-found k map -- value }
     map MalMap/list @
-    dup MalArray/start @ { start }
-    MalArray/count @ { count }
+    dup MalList/start @ { start }
+    MalList/count @ { count }
     0
     begin
         dup count >= if
@@ -309,14 +307,11 @@ MalDefault
 drop
 
 MalNil
-  ' conj ' MalList/conj extend-method*
+  extend conj ( item nil -- mal-list )
+    drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
 drop
 
-MalList
-  ' conj ' MalList/conj extend-method*
-drop
-
 
 MalType%
   cell% field MalInt/int
-- 
cgit v1.2.3


From e6106d4543fd4917a18ca501ee62a995a152d263 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 15:44:22 -0500
Subject: forth: Get rid of invoke+

Fold 'invoke+' into 'invoke'. Allows (:k m nf) to evaluate nf lazily!
---
 forth/step3_env.fs | 43 +++++++++++++++++++++++--------------------
 1 file changed, 23 insertions(+), 20 deletions(-)

(limited to 'forth')

diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index 269964d..f609858 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -13,26 +13,29 @@ s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalFn.  repl-env env/set
 s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalFn.  repl-env env/set
 s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalFn.  repl-env env/set
 
+\ Fully evalutate any Mal object:
 def-protocol-method mal-eval ( env ast -- val )
-def-protocol-method mal-eval-ast ( env ast -- val )
-def-protocol-method invoke+ ( env arty -- ... )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
 def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 MalDefault extend mal-eval nip ;; drop
 
 MalKeyword
-  extend invoke { argv argc kw -- val }
-    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
-    kw \ key
-    argv @ \ map
-    get ;;
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ mal-eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  mal-eval
+        else
+            mal-nil
+        endif
+    endif ;;
 drop
 
 MalFn
-  extend invoke ( ... mal-fn -- ... )
-    MalFn/xt @ execute ;;
-
-  extend invoke+ { env list this -- list }
+  extend invoke { env list this -- list }
     \ Pass args on dictionary stack (!)
     \ TODO: consider allocate and free of a real MalList instead
     \ Normal list, evaluate and invoke
@@ -42,12 +45,12 @@ MalFn
         env expr-start i cells + @ mal-eval ,
     loop
     val-start  here val-start - cell /  this  ( argv argc MalFn )
-    invoke
+    MalFn/xt @ execute
     val-start here - allot ;;
 drop
 
 SpecialOp
-  extend invoke+ ( env list this -- list )
+  extend invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -89,18 +92,18 @@ MalSymbol
     endif ;;
 drop
 
-MalList
-  extend mal-eval { env list -- val }
-    env list MalList/start @ @ mal-eval
-    env list rot invoke+ ;;
-
-  extend mal-eval-ast { env list -- list }
+: mal-eval-ast { env list -- list }
     here
     list MalList/start @ { expr-start }
     list MalList/count @ 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    here>MalList ;;
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ mal-eval
+    env list rot invoke ;;
 drop
 
 MalVector
-- 
cgit v1.2.3


From 79feb89f9c75d30e79b9ef13fa40d2f8e22f4b9b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sat, 14 Feb 2015 16:08:17 -0500
Subject: forth: Add defspecial for Mal special ops

---
 forth/step3_env.fs | 23 +++++++++++++++--------
 forth/types.fs     | 19 ++++++++++++-------
 2 files changed, 27 insertions(+), 15 deletions(-)

(limited to 'forth')

diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index f609858..c15f52b 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -54,19 +54,26 @@ SpecialOp
     SpecialOp/xt @ execute ;;
 drop
 
-s" quote" MalSymbol. :noname ( env list -- form )
-    nip MalList/start @ cell+ @
-; SpecialOp. repl-env env/set
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
 
-s" def!" MalSymbol. :noname { env list -- }
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
     env arg0 cell+ @ mal-eval dup { val } ( key val )
     env env/set
-    val
-; SpecialOp. repl-env env/set
+    val ;;
 
-s" let*" MalSymbol. :noname { old-env list -- }
+defspecial let* { old-env list -- }
     old-env MalEnv. { env }
     list MalList/start @ cell+ dup { arg0 }
     @ to-list
@@ -78,7 +85,7 @@ s" let*" MalSymbol. :noname { old-env list -- }
     2 +loop
     env arg0 cell+ @ mal-eval
     \ TODO: dec refcount of env
-; SpecialOp. repl-env env/set
+    ;;
 
 MalSymbol
   extend mal-eval { env sym -- val }
diff --git a/forth/types.fs b/forth/types.fs
index 305ff31..a8dd2da 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -84,11 +84,15 @@ end-struct MalTypeType%
   dup MalTypeType-name-len    0   swap !   ( MalTypeType )
   ;
 
+\ parse-name uses temporary space, so copy into dictionary stack:
+: parse-allot-name { -- new-str-addr str-len }
+    parse-name { str-addr str-len }
+    here { new-str-addr } str-len allot
+    str-addr new-str-addr str-len cmove
+    new-str-addr str-len ;
+
 : deftype ( struct-align struct-len R:type-name -- )
-    parse-name { orig-name-addr name-len }
-    \ parse-name uses temporary space, so copy into dictionary stack:
-    here { name-addr } name-len allot
-    orig-name-addr name-addr name-len cmove
+    parse-allot-name { name-addr name-len }
 
     \ allot and initialize type structure
     deftype* { mt }
@@ -183,14 +187,15 @@ MalNil new constant mal-nil
   does> ( ??? obj xt-ref -- ??? )
     @ execute-method ;
 
-: extend ( type -- type pxt <noname...>)
+: extend ( type -- type pxt install-xt <noname...>)
     parse-name find-name name>int ( type pxt )
+    ['] extend-method*
     :noname
     ;
 
 : ;; ( type pxt <noname...> -- type )
-    [compile] ; ( type pxt ixt )
-    extend-method*
+    [compile] ; ( type pxt install-xt ixt )
+    swap execute
     ; immediate
 
 (
-- 
cgit v1.2.3


From 60801ed68d5b2c6630c83883de150ccce98767f9 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 13:33:44 -0500
Subject: forth: Add step 4, but not varargs

---
 forth/core.fs           |  36 +++++++++
 forth/printer.fs        |  21 ++---
 forth/reader.fs         |   9 ++-
 forth/step4_if_fn_do.fs | 204 ++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs          |  91 +++++++++++++++------
 5 files changed, 327 insertions(+), 34 deletions(-)
 create mode 100644 forth/core.fs
 create mode 100644 forth/step4_if_fn_do.fs

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
new file mode 100644
index 0000000..6e8ccfb
--- /dev/null
+++ b/forth/core.fs
@@ -0,0 +1,36 @@
+require env.fs
+
+0 MalEnv. constant core
+
+: args-as-native drop { argv argc -- entry*argc... }
+    argc 0 ?do
+        argv i cells + @ as-native
+    loop ;
+
+: defcore ( xt )
+    parse-allot-name MalSymbol. ( xt sym )
+    swap MalFn. core env/set ;
+
+:noname args-as-native + MalInt. ; defcore +
+:noname args-as-native - MalInt. ; defcore -
+:noname args-as-native * MalInt. ; defcore *
+:noname args-as-native / MalInt. ; defcore /
+:noname args-as-native < mal-bool ; defcore <
+:noname args-as-native > mal-bool ; defcore >
+:noname args-as-native <= mal-bool ; defcore <=
+:noname args-as-native >= mal-bool ; defcore >=
+
+:noname drop { argv argc }
+    MalList new { list }
+    argc cells allocate throw { start }
+    argv  start  argc cells  cmove
+    argc  list MalList/count !
+    start list MalList/start !
+    list
+; defcore list
+
+:noname 2drop @ mal-type @ MalList = mal-bool ; defcore list?
+:noname 2drop @ empty? ; defcore empty?
+:noname 2drop @ mal-count ; defcore count
+
+:noname 2drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
diff --git a/forth/printer.fs b/forth/printer.fs
index 78ac197..39ddb8e 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -67,10 +67,9 @@ MalDefault
     s" >" str-append ;;
 drop
 
-MalNil
-  extend pr-buf
-    drop s" nil" str-append ;;
-drop
+MalNil   extend pr-buf drop s" nil"   str-append ;; drop
+MalTrue  extend pr-buf drop s" true"  str-append ;; drop
+MalFalse extend pr-buf drop s" false" str-append ;; drop
 
 MalList
   extend pr-buf
@@ -78,12 +77,14 @@ MalList
     rot pr-seq-buf
     s" )" str-append ;;
   extend pr-seq-buf { list }
-    list MalList/start @ { start }
-    start @ pr-buf
-    list MalList/count @ 1 ?do
-        a-space
-        start i cells + @ pr-buf
-    loop ;;
+    list MalList/count @ 0 > if
+        list MalList/start @ { start }
+        start @ pr-buf
+        list MalList/count @ 1 ?do
+            a-space
+            start i cells + @ pr-buf
+        loop
+    endif ;;
   extend pr-pairs-buf { list }
     list MalList/start @ { start }
     start @ pr-buf a-space start cell+ @ pr-buf
diff --git a/forth/reader.fs b/forth/reader.fs
index f65db2c..2ed3446 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -141,8 +141,13 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             obj swap conj
             s" with-meta" MalSymbol. swap conj
         else
-            read-symbol-str MalSymbol.
-        endif endif endif endif endif endif endif endif endif endif endif endif
+            read-symbol-str
+            2dup s" true" str= if 2drop mal-true
+            else 2dup s" false" str= if 2drop mal-false
+            else 2dup s" nil" str= if 2drop mal-nil
+            else
+              MalSymbol.
+        endif endif endif endif endif endif endif endif endif endif endif endif endif endif endif
         dup skip-elem =
     while drop repeat ;
 ' read-form2 is read-form
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
new file mode 100644
index 0000000..0350d13
--- /dev/null
+++ b/forth/step4_if_fn_do.fs
@@ -0,0 +1,204 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+MalDefault extend mal-eval nip ;; drop
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ mal-eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  mal-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+MalFn
+  extend invoke { env list this -- list }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalList instead
+    \ Normal list, evaluate and invoke
+    here { val-start }
+    list MalList/start @ { expr-start }
+    list MalList/count @ 1 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    val-start  here val-start - cell /  this  ( argv argc MalFn )
+    dup MalFn/xt @ execute
+    val-start here - allot ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ mal-eval dup { val } ( key val )
+    env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap mal-eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ mal-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @
+    0
+    list MalList/count @ 1 ?do
+        drop
+        dup i cells + @ env swap mal-eval
+    loop
+    nip ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ mal-eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ mal-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ mal-eval
+    endif ;;
+
+: user-fn { argv argc mal-fn -- return-val }
+    mal-fn MalFn/formal-args @ dup { f-args-list }
+    MalList/count @ argc 2dup = if
+        2drop
+    else
+        ." Argument mismatch on user fn. Got " . ." but expected " . cr
+        1 throw
+    endif
+
+    mal-fn MalFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    argc 0 ?do
+        f-args i cells + @
+        argv i cells + @
+        env env/set
+    loop
+
+    env   mal-fn MalFn/body @   mal-eval ;
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    ['] user-fn MalFn.
+    env over MalFn/env !
+    arg0 @ to-list over MalFn/formal-args !
+    arg0 cell+ @ over MalFn/body ! ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+: mal-eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ mal-eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ mal-eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ mal-eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ mal-eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+: rep ( str -- val )
+    read
+    repl-env swap eval
+    print ;
+
+create buff 128 allot
+
+: read-lines
+    begin
+      ." user> "
+      77777777777
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute safe-type
+      \ catch 0= if safe-type else ." Caught error" endif
+      cr
+      77777777777 <> if ." --stack leak--" cr endif
+    repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index a8dd2da..5eb546f 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -109,8 +109,12 @@ end-struct MalTypeType%
 MalType% deftype MalDefault
 
 \ nil type and instance to support extending protocols to it
-MalType% deftype MalNil
-MalNil new constant mal-nil
+MalType% deftype MalNil   MalNil   new constant mal-nil
+MalType% deftype MalTrue  MalTrue  new constant mal-true
+MalType% deftype MalFalse MalFalse new constant mal-false
+
+: mal-bool
+    0= if mal-false else mal-true endif ;
 
 : not-object? ( obj -- bool )
     dup 7 and 0 <> if
@@ -219,7 +223,10 @@ def-protocol-method assoc ( k v this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
+
 def-protocol-method to-list ( obj -- mal-list )
+def-protocol-method empty? ( obj -- mal-bool )
+def-protocol-method mal-count ( obj -- mal-int )
 
 : m= ( a b -- bool )
     2dup = if
@@ -228,6 +235,27 @@ def-protocol-method to-list ( obj -- mal-list )
         mal=
     endif ;
 
+
+MalType%
+  cell% field MalInt/int
+deftype MalInt
+
+: MalInt. { int -- mal-int }
+    MalInt new dup MalInt/int int swap ! ;
+
+MalInt
+  extend mal= ( other this -- bool )
+    over mal-type @ MalInt = if
+        MalInt/int @ swap MalInt/int @ =
+    else
+        2drop 0
+    endif ;;
+
+  extend as-native ( mal-int -- int )
+    MalInt/int @ ;;
+drop
+
+
 MalType%
   cell% field MalList/count
   cell% field MalList/start
@@ -255,6 +283,26 @@ MalList
     MalList new
     new-count over MalList/count !
     new-start over MalList/start ! ;;
+  extend empty? MalList/count @ 0= mal-bool ;;
+  extend mal-count MalList/count @ MalInt. ;;
+  extend mal=
+    swap to-list dup 0= if
+        nip
+    else
+        2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
+            -rot MalList/start @ swap MalList/start @ { start-b start-a }
+            -1 swap ( return-val count )
+            0 ?do
+                start-a i cells + @
+                start-b i cells + @
+                m= if else
+                    drop 0 leave
+                endif
+            loop
+        else
+            drop 2drop 0
+        endif
+    endif ;;
 drop
 
 MalList new 0 over MalList/count ! constant MalList/Empty
@@ -266,6 +314,12 @@ deftype MalVector
 MalVector
   extend to-list
     MalVector/list @ to-list ;;
+  extend empty?
+    MalVector/list @
+    MalList/count @ 0= mal-bool ;;
+  extend mal-count
+    MalVector/list @
+    MalList/count @ MalInt. ;;
 drop
 
 MalType%
@@ -302,6 +356,12 @@ MalMap
             endif
         endif
     until ;;
+  extend empty?
+    MalMap/list @
+    MalList/count @ 0= mal-bool ;;
+  extend mal-count
+    MalMap/list @
+    MalList/count @ 2 / MalInt. ;;
 drop
 
 \ Examples of extending existing protocol methods to existing type
@@ -309,32 +369,16 @@ MalDefault
   extend conj   ( obj this -- this )
     nip ;;
   extend as-native ;; ( obj -- obj )
+  extend to-list drop 0 ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
-drop
-
-
-MalType%
-  cell% field MalInt/int
-deftype MalInt
-
-: MalInt. { int -- mal-int }
-    MalInt new dup MalInt/int int swap ! ;
-
-MalInt
-  extend mal= ( other this -- bool )
-    over mal-type @ MalInt = if
-        MalInt/int @ swap MalInt/int @ =
-    else
-        2drop 0
-    endif ;;
-
-  extend as-native ( mal-int -- int )
-    MalInt/int @ ;;
+  extend empty? drop mal-true ;;
+  extend mal-count drop 0 MalInt. ;;
+  extend mal= drop mal-nil = ;;
 drop
 
 MalType%
@@ -418,6 +462,9 @@ drop
 MalType%
   cell% field MalFn/xt
   cell% field MalFn/meta
+  cell% field MalFn/env
+  cell% field MalFn/formal-args
+  cell% field MalFn/body
 deftype MalFn
 
 : MalFn. { xt -- mal-fn }
-- 
cgit v1.2.3


From 136ce7c9afb5e103133fe6e423e6dad3d23db38d Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 14:10:47 -0500
Subject: forth: Split types for user fns vs native fns

---
 forth/core.fs           | 14 +++++++-------
 forth/printer.fs        | 14 +++-----------
 forth/step2_eval.fs     | 14 +++++++-------
 forth/step3_env.fs      | 14 +++++++-------
 forth/step4_if_fn_do.fs | 44 +++++++++++++++++++++++++++++---------------
 forth/types.fs          | 32 +++++++++++++++++++-------------
 6 files changed, 72 insertions(+), 60 deletions(-)

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 6e8ccfb..16105ad 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -2,14 +2,14 @@ require env.fs
 
 0 MalEnv. constant core
 
-: args-as-native drop { argv argc -- entry*argc... }
+: args-as-native { argv argc -- entry*argc... }
     argc 0 ?do
         argv i cells + @ as-native
     loop ;
 
 : defcore ( xt )
     parse-allot-name MalSymbol. ( xt sym )
-    swap MalFn. core env/set ;
+    swap MalNativeFn. core env/set ;
 
 :noname args-as-native + MalInt. ; defcore +
 :noname args-as-native - MalInt. ; defcore -
@@ -20,7 +20,7 @@ require env.fs
 :noname args-as-native <= mal-bool ; defcore <=
 :noname args-as-native >= mal-bool ; defcore >=
 
-:noname drop { argv argc }
+:noname { argv argc }
     MalList new { list }
     argc cells allocate throw { start }
     argv  start  argc cells  cmove
@@ -29,8 +29,8 @@ require env.fs
     list
 ; defcore list
 
-:noname 2drop @ mal-type @ MalList = mal-bool ; defcore list?
-:noname 2drop @ empty? ; defcore empty?
-:noname 2drop @ mal-count ; defcore count
+:noname drop @ mal-type @ MalList = mal-bool ; defcore list?
+:noname drop @ empty? ; defcore empty?
+:noname drop @ mal-count ; defcore count
 
-:noname 2drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
+:noname drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
diff --git a/forth/printer.fs b/forth/printer.fs
index 39ddb8e..0474944 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -62,7 +62,9 @@ def-protocol-method pr-pairs-buf ( str-addr str-len this -- str-addr str-len )
 MalDefault
   extend pr-buf
     { this }
-    s" #<MalObject" str-append a-space
+    s" #<" str-append
+    this mal-type @ type-name str-append
+    a-space
     this int>str str-append
     s" >" str-append ;;
 drop
@@ -117,16 +119,6 @@ MalInt
     MalInt/int @ int>str str-append ;;
 drop
 
-MalFn
-  extend pr-buf
-    drop s" #<fn>" str-append ;;
-drop
-
-SpecialOp
-  extend pr-buf
-    drop s" #<op>" str-append ;;
-drop
-
 MalSymbol
   extend pr-buf
     unpack-sym str-append ;;
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
index 6a9af72..4963111 100644
--- a/forth/step2_eval.fs
+++ b/forth/step2_eval.fs
@@ -7,10 +7,10 @@ require printer.fs
     loop ;
 
 MalMap/Empty
-    s" +" MalSymbol. :noname args-as-native + MalInt. ; MalFn. rot assoc
-    s" -" MalSymbol. :noname args-as-native - MalInt. ; MalFn. rot assoc
-    s" *" MalSymbol. :noname args-as-native * MalInt. ; MalFn. rot assoc
-    s" /" MalSymbol. :noname args-as-native / MalInt. ; MalFn. rot assoc
+    s" +" MalSymbol. :noname args-as-native + MalInt. ; MalNativeFn. rot assoc
+    s" -" MalSymbol. :noname args-as-native - MalInt. ; MalNativeFn. rot assoc
+    s" *" MalSymbol. :noname args-as-native * MalInt. ; MalNativeFn. rot assoc
+    s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. rot assoc
 value repl-env
 
 def-protocol-method mal-eval ( env ast -- val )
@@ -27,9 +27,9 @@ MalKeyword
     get ;;
 drop
 
-MalFn
+MalNativeFn
   extend invoke ( ... mal-fn -- ... )
-    MalFn/xt @ execute ;;
+    MalNativeFn/xt @ execute ;;
 drop
 
 MalSymbol
@@ -53,7 +53,7 @@ MalList
     list MalList/count @ 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalFn )
+    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalNativeFn )
     invoke
     val-start here - allot ;;
   extend mal-eval-ast { env list -- list }
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index c15f52b..7dc9d7e 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -8,10 +8,10 @@ require env.fs
     loop ;
 
 0 MalEnv. constant repl-env
-s" +" MalSymbol.  :noname args-as-native + MalInt. ; MalFn.  repl-env env/set
-s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalFn.  repl-env env/set
-s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalFn.  repl-env env/set
-s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalFn.  repl-env env/set
+s" +" MalSymbol.  :noname args-as-native + MalInt. ; MalNativeFn.  repl-env env/set
+s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalNativeFn.  repl-env env/set
+s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalNativeFn.  repl-env env/set
+s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalNativeFn.  repl-env env/set
 
 \ Fully evalutate any Mal object:
 def-protocol-method mal-eval ( env ast -- val )
@@ -34,7 +34,7 @@ MalKeyword
     endif ;;
 drop
 
-MalFn
+MalNativeFn
   extend invoke { env list this -- list }
     \ Pass args on dictionary stack (!)
     \ TODO: consider allocate and free of a real MalList instead
@@ -44,8 +44,8 @@ MalFn
     list MalList/count @ 1 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    val-start  here val-start - cell /  this  ( argv argc MalFn )
-    MalFn/xt @ execute
+    val-start  here val-start - cell /  this  ( argv argc MalNativeFn )
+    MalNativeFn/xt @ execute
     val-start here - allot ;;
 drop
 
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
index 0350d13..b41fe29 100644
--- a/forth/step4_if_fn_do.fs
+++ b/forth/step4_if_fn_do.fs
@@ -25,19 +25,28 @@ MalKeyword
     endif ;;
 drop
 
-MalFn
-  extend invoke { env list this -- list }
+\ eval all but the first item of list, storing in temporary memory
+\ that should be freed with free-eval-rest when done.
+: eval-rest { env list -- mem-token argv argc }
     \ Pass args on dictionary stack (!)
     \ TODO: consider allocate and free of a real MalList instead
     \ Normal list, evaluate and invoke
     here { val-start }
-    list MalList/start @ { expr-start }
-    list MalList/count @ 1 ?do
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- dup { argc } 0 ?do
         env expr-start i cells + @ mal-eval ,
     loop
-    val-start  here val-start - cell /  this  ( argv argc MalFn )
-    dup MalFn/xt @ execute
-    val-start here - allot ;;
+    val-start  val-start  argc ;
+
+: free-eval-rest ( mem-token/val-start -- )
+    here - allot ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( mem-token argv argc )
+    xt execute ( mem-token return-val )
+    swap free-eval-rest ;;
 drop
 
 SpecialOp
@@ -107,8 +116,11 @@ defspecial if { env list -- val }
         env arg0 cell+ @ mal-eval
     endif ;;
 
-: user-fn { argv argc mal-fn -- return-val }
-    mal-fn MalFn/formal-args @ dup { f-args-list }
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { mem-token argv argc }
+
+    mal-fn MalUserFn/formal-args @ dup { f-args-list }
     MalList/count @ argc 2dup = if
         2drop
     else
@@ -116,7 +128,7 @@ defspecial if { env list -- val }
         1 throw
     endif
 
-    mal-fn MalFn/env @ MalEnv. { env }
+    mal-fn MalUserFn/env @ MalEnv. { env }
 
     f-args-list MalList/start @ { f-args }
     argc 0 ?do
@@ -125,14 +137,16 @@ defspecial if { env list -- val }
         env env/set
     loop
 
-    env   mal-fn MalFn/body @   mal-eval ;
+    env   mal-fn MalUserFn/body @   mal-eval
+
+    mem-token free-eval-rest ;;
 
 defspecial fn* { env list -- val }
     list MalList/start @ cell+ { arg0 }
-    ['] user-fn MalFn.
-    env over MalFn/env !
-    arg0 @ to-list over MalFn/formal-args !
-    arg0 cell+ @ over MalFn/body ! ;;
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
 
 MalSymbol
   extend mal-eval { env sym -- val }
diff --git a/forth/types.fs b/forth/types.fs
index 5eb546f..7675a5e 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -460,25 +460,31 @@ drop
 
 
 MalType%
-  cell% field MalFn/xt
-  cell% field MalFn/meta
-  cell% field MalFn/env
-  cell% field MalFn/formal-args
-  cell% field MalFn/body
-deftype MalFn
-
-: MalFn. { xt -- mal-fn }
-    MalFn new { mal-fn }
-    xt mal-fn MalFn/xt !
-    MalMap/Empty mal-fn MalFn/meta  !
+  cell% field MalNativeFn/xt
+  cell% field MalNativeFn/meta
+deftype MalNativeFn
+
+: MalNativeFn. { xt -- mal-fn }
+    MalNativeFn new { mal-fn }
+    xt mal-fn MalNativeFn/xt !
+    MalMap/Empty mal-fn MalNativeFn/meta  !
     mal-fn ;
 
-MalFn
+MalNativeFn
   extend as-native
-    MalFn/xt @ ;;
+    MalNativeFn/xt @ ;;
 drop
 
 
+MalType%
+  cell% field MalUserFn/meta
+  cell% field MalUserFn/env
+  cell% field MalUserFn/formal-args
+  cell% field MalUserFn/var-arg
+  cell% field MalUserFn/body
+deftype MalUserFn
+
+
 MalType%
   cell% field SpecialOp/xt
 deftype SpecialOp
-- 
cgit v1.2.3


From c4403c179e732a50e2b21a01469f0a38ea2d0187 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 16:46:34 -0500
Subject: forth: Add support for & var-args

---
 forth/core.fs           | 71 +++++++++++++++++++++++++++++++++++--------------
 forth/step4_if_fn_do.fs | 31 ++++++++++++++++-----
 forth/types.fs          | 10 ++++---
 3 files changed, 82 insertions(+), 30 deletions(-)

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 16105ad..6dd4ec4 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -7,30 +7,61 @@ require env.fs
         argv i cells + @ as-native
     loop ;
 
-: defcore ( xt )
-    parse-allot-name MalSymbol. ( xt sym )
-    swap MalNativeFn. core env/set ;
-
-:noname args-as-native + MalInt. ; defcore +
-:noname args-as-native - MalInt. ; defcore -
-:noname args-as-native * MalInt. ; defcore *
-:noname args-as-native / MalInt. ; defcore /
-:noname args-as-native < mal-bool ; defcore <
-:noname args-as-native > mal-bool ; defcore >
-:noname args-as-native <= mal-bool ; defcore <=
-:noname args-as-native >= mal-bool ; defcore >=
-
-:noname { argv argc }
+: defcore* ( sym xt )
+    MalNativeFn. core env/set ;
+
+: defcore
+    parse-allot-name MalSymbol. ( xt )
+    ['] defcore* :noname ;
+
+defcore +  args-as-native +  MalInt. ;;
+defcore -  args-as-native -  MalInt. ;;
+defcore *  args-as-native *  MalInt. ;;
+defcore /  args-as-native /  MalInt. ;;
+defcore <  args-as-native <  mal-bool ;;
+defcore >  args-as-native >  mal-bool ;;
+defcore <= args-as-native <= mal-bool ;;
+defcore >= args-as-native >= mal-bool ;;
+
+defcore list { argv argc }
     MalList new { list }
     argc cells allocate throw { start }
     argv  start  argc cells  cmove
     argc  list MalList/count !
     start list MalList/start !
-    list
-; defcore list
+    list ;;
+
+defcore list? drop @ mal-type @ MalList = mal-bool ;;
+defcore empty? drop @ empty? ;;
+defcore count drop @ mal-count ;;
+
+defcore = drop dup @ swap cell+ @ swap m= mal-bool ;;
+defcore not
+    drop @
+    dup mal-nil = if
+        drop mal-true
+    else
+        mal-false = if
+            mal-true
+        else
+            mal-false
+        endif
+    endif ;;
+
+: pr-str-multi ( argv argc )
+    ?dup 0= if drop s" "
+    else
+        { argv argc }
+        new-str
+        argv @ pr-buf
+        argc 1 ?do
+            a-space
+            argv i cells + @ pr-buf
+        loop
+    endif ;
 
-:noname drop @ mal-type @ MalList = mal-bool ; defcore list?
-:noname drop @ empty? ; defcore empty?
-:noname drop @ mal-count ; defcore count
+defcore prn pr-str-multi type cr mal-nil ;;
+defcore pr-str pr-str-multi MalString. ;;
 
-:noname drop dup @ swap cell+ @ swap m= mal-bool ; defcore =
+defcore str drop @ pr-str MalString. ;;
+defcore println pr-str-multi 10 str-append-char MalString. ;;
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
index b41fe29..46163bc 100644
--- a/forth/step4_if_fn_do.fs
+++ b/forth/step4_if_fn_do.fs
@@ -116,23 +116,40 @@ defspecial if { env list -- val }
         env arg0 cell+ @ mal-eval
     endif ;;
 
+s" &" MalSymbol. constant &-sym
+
 MalUserFn
   extend invoke { call-env list mal-fn -- list }
     call-env list eval-rest { mem-token argv argc }
 
-    mal-fn MalUserFn/formal-args @ dup { f-args-list }
-    MalList/count @ argc 2dup = if
-        2drop
-    else
-        ." Argument mismatch on user fn. Got " . ." but expected " . cr
-        1 throw
-    endif
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    \ \ This isn't correct for fns with & in their f-args-list:
+    \ f-args-list MalList/count @ argc 2dup = if
+    \     2drop
+    \ else
+    \     ." Argument mismatch on user fn. Got " . ." but expected " . cr
+    \     1 throw
+    \ endif
 
     mal-fn MalUserFn/env @ MalEnv. { env }
 
     f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
     argc 0 ?do
         f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
         argv i cells + @
         env env/set
     loop
diff --git a/forth/types.fs b/forth/types.fs
index 7675a5e..51f04ed 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -125,6 +125,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 
 \ === protocol methods === /
 
+0 constant trace
+
 \ Used by protocol methods to find the appropriate implementation of
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
@@ -153,10 +155,10 @@ MalType% deftype MalFalse MalFalse new constant mal-false
       ." '"
       1 throw
   endif
+  trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
 
   cells swap MalTypeType-method-vals @ + @ ( xt )
-  obj swap execute
-  ;
+  obj swap execute ;
 
 \ Extend a type with a protocol method. This mutates the MalTypeType
 \ object that represents the MalType being extended.
@@ -313,13 +315,15 @@ deftype MalVector
 
 MalVector
   extend to-list
-    MalVector/list @ to-list ;;
+    MalVector/list @ ;;
   extend empty?
     MalVector/list @
     MalList/count @ 0= mal-bool ;;
   extend mal-count
     MalVector/list @
     MalList/count @ MalInt. ;;
+  extend mal=
+    MalVector/list @ swap m= ;;
 drop
 
 MalType%
-- 
cgit v1.2.3


From 785786c6033c97a70e78fb6b684d58aea18df4ae Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 17:44:52 -0500
Subject: forth: Finish step 4

---
 forth/core.fs    | 23 ++++++++++++++++-------
 forth/printer.fs | 27 ++++++++++++++++-----------
 forth/types.fs   | 16 ++++++++--------
 3 files changed, 40 insertions(+), 26 deletions(-)

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 6dd4ec4..4982a0e 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -48,8 +48,8 @@ defcore not
         endif
     endif ;;
 
-: pr-str-multi ( argv argc )
-    ?dup 0= if drop s" "
+: pr-str-multi ( readably? argv argc )
+    ?dup 0= if drop 0 0
     else
         { argv argc }
         new-str
@@ -60,8 +60,17 @@ defcore not
         loop
     endif ;
 
-defcore prn pr-str-multi type cr mal-nil ;;
-defcore pr-str pr-str-multi MalString. ;;
-
-defcore str drop @ pr-str MalString. ;;
-defcore println pr-str-multi 10 str-append-char MalString. ;;
+defcore prn true -rot pr-str-multi type cr drop mal-nil ;;
+defcore pr-str true -rot pr-str-multi MalString. nip ;;
+defcore println false -rot pr-str-multi type cr drop mal-nil ;;
+defcore str ( argv argc )
+    dup 0= if
+        MalString.
+    else
+        { argv argc }
+        false new-str
+        argc 0 ?do
+            argv i cells + @ pr-buf
+        loop
+        MalString. nip
+    endif ;;
diff --git a/forth/printer.fs b/forth/printer.fs
index 0474944..6152993 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -51,12 +51,12 @@ here constant space-str
 
 \ === printer protocol and implementations === /
 
-def-protocol-method pr-buf ( str-addr str-len this -- str-addr str-len )
-def-protocol-method pr-seq-buf ( str-addr str-len this -- str-addr str-len )
-def-protocol-method pr-pairs-buf ( str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-seq-buf ( readably? str-addr str-len this -- str-addr str-len )
+def-protocol-method pr-pairs-buf ( readably? str-addr str-len this -- str-addr str-len )
 
 : pr-str { obj }
-    new-str obj pr-buf ;
+    true new-str obj pr-buf rot drop ;
 
 \ Examples of extending existing protocol methods to existing type
 MalDefault
@@ -138,12 +138,7 @@ drop
     addr len
     ;
 
-MalString
-  extend pr-buf
-    dup MalString/str-addr @
-    swap MalString/str-len @
-    { addr len }
-
+: escape-str { addr len }
     s\" \"" str-append
     0 ( i )
     begin
@@ -169,5 +164,15 @@ MalString
         1+
     repeat
     drop addr len str-append
-    s\" \"" str-append ;;
+    s\" \"" str-append ;
+
+MalString
+  extend pr-buf
+    dup MalString/str-addr @
+    swap MalString/str-len @
+    4 pick if
+        escape-str
+    else
+        str-append
+    endif ;;
 drop
diff --git a/forth/types.fs b/forth/types.fs
index 51f04ed..1a132be 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -118,7 +118,7 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 
 : not-object? ( obj -- bool )
     dup 7 and 0 <> if
-        drop -1
+        drop true
     else
         1000000 <
     endif ;
@@ -232,7 +232,7 @@ def-protocol-method mal-count ( obj -- mal-int )
 
 : m= ( a b -- bool )
     2dup = if
-        2drop -1
+        2drop true
     else
         mal=
     endif ;
@@ -293,16 +293,16 @@ MalList
     else
         2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
             -rot MalList/start @ swap MalList/start @ { start-b start-a }
-            -1 swap ( return-val count )
+            true swap ( return-val count )
             0 ?do
                 start-a i cells + @
                 start-b i cells + @
                 m= if else
-                    drop 0 leave
+                    drop false leave
                 endif
             loop
         else
-            drop 2drop 0
+            drop 2drop false
         endif
     endif ;;
 drop
@@ -351,12 +351,12 @@ MalMap
     0
     begin
         dup count >= if
-            drop not-found -1
+            drop not-found true
         else
             start over cells + @ k m= if
-                start swap cells + cell+ @ -1 \ found it ( value -1 )
+                start swap cells + cell+ @ true \ found it ( value true )
             else
-                2 + 0
+                2 + false
             endif
         endif
     until ;;
-- 
cgit v1.2.3


From d44f31c2218a923d2a5b766ae3d6577aba294d42 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Sun, 15 Feb 2015 22:02:48 -0500
Subject: forth: Add step 5

---
 forth/step5_tco.fs | 238 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs     |   2 +-
 2 files changed, 239 insertions(+), 1 deletion(-)
 create mode 100644 forth/step5_tco.fs

(limited to 'forth')

diff --git a/forth/step5_tco.fs b/forth/step5_tco.fs
new file mode 100644
index 0000000..a420719
--- /dev/null
+++ b/forth/step5_tco.fs
@@ -0,0 +1,238 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list, storing in temporary memory
+\ that should be freed with free-eval-rest when done.
+: eval-rest { env list -- mem-token argv argc }
+    \ Pass args on dictionary stack (!)
+    \ TODO: consider allocate and free of a real MalList instead
+    \ Normal list, evaluate and invoke
+    here { val-start }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- dup { argc } 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    val-start  val-start  argc ;
+
+: free-eval-rest ( mem-token/val-start -- )
+    here - allot ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( mem-token argv argc )
+    xt execute ( mem-token return-val )
+    swap free-eval-rest ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { mem-token argv argc }
+
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    mal-fn MalUserFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
+    argc 0 ?do
+        f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
+        argv i cells + @
+        env env/set
+    loop
+
+    env   mal-fn MalUserFn/body @   TCO-eval
+
+    mem-token free-eval-rest ;;
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+: rep ( str -- val )
+    read
+    repl-env swap eval
+    print ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: read-lines
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      \ execute safe-type
+      catch ?dup 0= if safe-type else ." Caught error " . endif
+      cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
+    repeat ;
+
+read-lines
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 1a132be..bf159ad 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -152,7 +152,7 @@ MalType% deftype MalFalse MalFalse new constant mal-false
       pxt >name name>string type
       ." ' extended to type '"
       obj mal-type @ type-name type
-      ." '"
+      ." '" cr
       1 throw
   endif
   trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
-- 
cgit v1.2.3


From cd21ff0d3ccfbec62fe6af95e6656fe9c38f8254 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Mon, 16 Feb 2015 02:01:56 -0500
Subject: forth: Fix critical string-resizing bug

---
 forth/printer.fs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'forth')

diff --git a/forth/printer.fs b/forth/printer.fs
index 6152993..d035e94 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -28,7 +28,7 @@ require types.fs
 : str-append { buf-addr buf-str-len str-addr str-len }
   buf-str-len str-len +
   { new-len }
-  new-len str-base-size > if
+  new-len str-base-size >= if
     buf-str-len new-len xor buf-str-len > if
       buf-addr new-len round-up resize throw
       to buf-addr
-- 
cgit v1.2.3


From bf6a574e00a221dfe564ba11148deaa73ba8a229 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Mon, 16 Feb 2015 20:12:44 -0500
Subject: forth: Add step 6, clean up comment parsing

---
 forth/core.fs       |   3 +
 forth/printer.fs    |  41 ++-------
 forth/reader.fs     | 119 +++++++++++-------------
 forth/step6_file.fs | 259 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs      |   6 ++
 5 files changed, 329 insertions(+), 99 deletions(-)
 create mode 100644 forth/step6_file.fs

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 4982a0e..71f43ca 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -74,3 +74,6 @@ defcore str ( argv argc )
         loop
         MalString. nip
     endif ;;
+
+defcore read-string drop @ unpack-str read-str ;;
+defcore slurp drop @ unpack-str slurp-file MalString. ;;
diff --git a/forth/printer.fs b/forth/printer.fs
index d035e94..5309745 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -130,40 +130,17 @@ MalKeyword
     kw unpack-keyword str-append ;;
 drop
 
-: insert-\ ( str-addr str-len insert-idx -- str-addr str-len )
-    -rot 0 str-append-char { addr len }
-    dup   dup addr +   dup 1+  ( i i from to )
-    rot len swap - cmove> ( i ) \ shift " etc to the right
-    addr + [char] \ swap c! \ escape it!
-    addr len
-    ;
-
 : escape-str { addr len }
     s\" \"" str-append
-    0 ( i )
-    begin
-        dup len <
-    while
-        dup addr + c@ ( i char )
-        dup [char] " = over [char] \ = or if ( i char )
-            drop dup addr len rot insert-\ to len to addr
-            1+
-        else
-            dup 10 = if ( i ) \ newline?
-                drop dup addr len rot insert-\ to len to addr
-                dup addr + 1+ [char] n swap c!
-                1+
-            else
-                13 = if ( i ) \ return?
-                    dup addr len rot insert-\ to len to addr
-                    dup addr + 1+ [char] r swap c!
-                    1+
-                endif
-            endif
-        endif
-        1+
-    repeat
-    drop addr len str-append
+    addr len +  addr  ?do
+        i c@ case
+            [char] " of s\" \\\"" str-append endof
+            [char] \ of s\" \\\\" str-append endof
+            10 of s\" \\n" str-append endof
+            13 of s\" \\r" str-append endof
+            -rot i 1 str-append rot
+        endcase
+    loop
     s\" \"" str-append ;
 
 MalString
diff --git a/forth/reader.fs b/forth/reader.fs
index 2ed3446..6547a79 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -1,8 +1,6 @@
 require types.fs
 require printer.fs
 
--2 constant skip-elem
-
 \ Drop a char off the front of string by advancing the addr and
 \ decrementing the length, and fetch next char
 : adv-str ( str-addr str-len -- str-addr str-len char )
@@ -10,17 +8,6 @@ require printer.fs
     dup 0= if 0 ( eof )
     else over c@ endif ;
 
-: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
-    begin
-        dup bl = if
-            -1
-        else
-            dup [char] , =
-        endif
-    while ( str-addr str-len space-char )
-        drop adv-str
-    repeat ;
-
 : mal-digit? ( char -- flag )
     dup [char] 9 <= if
         [char] 0 >=
@@ -30,22 +17,32 @@ require printer.fs
 
 : char-in-str? ( char str-addr str-len )
     rot { needle }
-    begin ( str-addr str-len )
-        adv-str needle = if
-            2drop -1 -1 \ success! drop and exit
+    false -rot
+    over + swap ?do
+        i c@ needle = if drop true leave endif
+    loop ;
+
+: sym-char? ( char -- flag )
+    s\" \n\r\t\000[]{}()'\"`,; " char-in-str? 0= ;
+
+: skip-spaces ( str-addr str-len char -- str-addr str-len non-space-char )
+    begin
+        begin
+            dup s\" \n\r\t, " char-in-str?
+        while ( str-addr str-len space-char )
+            drop adv-str
+        repeat
+        dup [char] ; = if
+            drop
+            begin
+                adv-str s\" \n\r\000" char-in-str?
+            until
+            adv-str false
         else
-            dup 0= if
-                2drop 0 -1 \ str consumed, char not found.
-            else
-                0 \ continue
-            endif
+            true
         endif
     until ;
 
-s\" []{}()'\"`,; " constant non-sym-chars-len constant non-sym-chars
-: sym-char? ( char -- flag )
-    non-sym-chars non-sym-chars-len char-in-str? 0= ;
-
 defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
 
 : read-int ( str-addr str-len digit-char -- str-addr str-len non-digit-char mal-int )
@@ -56,13 +53,6 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     until
     int MalInt. ;
 
-: read-comment ( str-addr str-len sym-char -- str-addr str-len char skim-elem )
-    drop
-    begin
-        adv-str = 10
-    until
-    adv-str skip-elem ;
-
 : read-symbol-str ( str-addr str-len sym-char -- str-addr str-len char sym-addr sym-len )
     new-str { sym-addr sym-len }
     begin ( str-addr str-len sym-char )
@@ -106,8 +96,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
             read-form ,
     repeat
     drop adv-str
-    old-here here>MalList
-    ;
+    old-here here>MalList ;
 
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
     here { old-here }
@@ -116,40 +105,36 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     old-here here>MalList ;
 
 : read-form2 ( str-addr str-len char -- str-addr str-len char mal-obj )
-    begin
-        skip-spaces
-        dup mal-digit? if read-int else
-        dup [char] ( = if [char] ) read-list else
-        dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
-        dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
-        dup [char] " = if read-string-literal else
-        dup [char] ; = if read-comment else
-        dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
-        dup [char] @ = if drop adv-str s" deref" read-wrapped else
-        dup [char] ' = if drop adv-str s" quote" read-wrapped else
-        dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
-        dup [char] ~ = if
-            drop adv-str
-            dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
-            else s" unquote" read-wrapped
-            endif
-        else
-        dup [char] ^ = if
-            drop adv-str
-            read-form { meta } read-form { obj }
-            meta mal-nil conj
-            obj swap conj
-            s" with-meta" MalSymbol. swap conj
+    skip-spaces
+    dup mal-digit? if read-int else
+    dup [char] ( = if [char] ) read-list else
+    dup [char] [ = if [char] ] read-list MalVector new tuck MalVector/list ! else
+    dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
+    dup [char] " = if read-string-literal else
+    dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
+    dup [char] @ = if drop adv-str s" deref" read-wrapped else
+    dup [char] ' = if drop adv-str s" quote" read-wrapped else
+    dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
+    dup [char] ~ = if
+        drop adv-str
+        dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
+        else s" unquote" read-wrapped
+        endif
+    else
+    dup [char] ^ = if
+        drop adv-str
+        read-form { meta } read-form { obj }
+        meta mal-nil conj
+        obj swap conj
+        s" with-meta" MalSymbol. swap conj
+    else
+        read-symbol-str
+        2dup s" true" str= if 2drop mal-true
+        else 2dup s" false" str= if 2drop mal-false
+        else 2dup s" nil" str= if 2drop mal-nil
         else
-            read-symbol-str
-            2dup s" true" str= if 2drop mal-true
-            else 2dup s" false" str= if 2drop mal-false
-            else 2dup s" nil" str= if 2drop mal-nil
-            else
-              MalSymbol.
-        endif endif endif endif endif endif endif endif endif endif endif endif endif endif endif
-        dup skip-elem =
-    while drop repeat ;
+          MalSymbol.
+    endif endif endif endif endif endif endif endif endif endif endif endif endif endif ;
 ' read-form2 is read-form
 
 : read-str ( str-addr str-len - mal-obj )
diff --git a/forth/step6_file.fs b/forth/step6_file.fs
new file mode 100644
index 0000000..d675f6e
--- /dev/null
+++ b/forth/step6_file.fs
@@ -0,0 +1,259 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        \ ." eval-> " dup pr-str safe-type cr
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { argv argc }
+
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    mal-fn MalUserFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
+    argc 0 ?do
+        f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
+        argv i cells + @
+        env env/set
+    loop
+
+    env   mal-fn MalUserFn/body @   TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+  drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- val )
+    read
+    repl-env swap eval
+    print ;
+
+: mk-args-list ( -- )
+    here
+    begin
+        next-arg 2dup 0 0 d<> while
+            MalString. ,
+    repeat
+    2drop here>MalList ;
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: repl ( -- )
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute type
+      \ catch ?dup 0= if safe-type else ." Caught error " . endif
+      cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
+    repeat ;
+
+: main ( -- )
+    mk-args-list { args-list }
+    args-list MalList/count @ 0= if
+        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+        repl
+    else
+        args-list MalList/start @ @ { filename }
+        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+        repl-env
+        here s" load-file" MalSymbol. , filename , here>MalList
+        eval print
+    endif ;
+
+main
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index bf159ad..5b8a211 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -309,6 +309,12 @@ drop
 
 MalList new 0 over MalList/count ! constant MalList/Empty
 
+: MalList/rest { list -- list }
+    MalList new
+    list MalList/start @   cell+   over MalList/start !
+    list MalList/count @   1-      over MalList/count ! ;
+
+
 MalType%
   cell% field MalVector/list
 deftype MalVector
-- 
cgit v1.2.3


From 794bfca1361fc6900f0ea0186d64111c3a02b0f8 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Mon, 16 Feb 2015 21:28:05 -0500
Subject: forth: Add step 7

---
 forth/core.fs        |  19 ++++
 forth/reader.fs      |  18 ++-
 forth/step7_quote.fs | 301 +++++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs       |   1 +
 4 files changed, 333 insertions(+), 6 deletions(-)
 create mode 100644 forth/step7_quote.fs

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 71f43ca..e601e1d 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -77,3 +77,22 @@ defcore str ( argv argc )
 
 defcore read-string drop @ unpack-str read-str ;;
 defcore slurp drop @ unpack-str slurp-file MalString. ;;
+
+defcore cons ( argv[item,coll] argc )
+    drop dup @ swap cell+ @ ( item coll )
+    to-list conj ;;
+
+defcore concat { lists argc }
+    0   lists argc cells +  lists  +do ( count )
+        i @ to-list MalList/count @ +
+    cell +loop { count }
+    count cells allocate throw { start }
+    start   lists argc cells +  lists  +do ( target )
+        i @ to-list MalList/count @ cells  2dup  i @ to-list MalList/start @  -rot  ( target bytes src target bytes )
+        cmove ( target bytes )
+        + ( new-target )
+    cell +loop
+    drop
+    MalList new
+    start over MalList/start !
+    count over MalList/count ! ;;
diff --git a/forth/reader.fs b/forth/reader.fs
index 6547a79..1daa650 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -98,9 +98,15 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     drop adv-str
     old-here here>MalList ;
 
+s" deref"          MalSymbol. constant deref-sym
+s" quote"          MalSymbol. constant quote-sym
+s" quasiquote"     MalSymbol. constant quasiquote-sym
+s" splice-unquote" MalSymbol. constant splice-unquote-sym
+s" unquote"        MalSymbol. constant unquote-sym
+
 : read-wrapped ( buf-addr buf-len quote-char sym-addr sym-len -- buf-addr buf-len char mal-list )
     here { old-here }
-    MalSymbol. , ( buf-addr buf-len char )
+    , ( buf-addr buf-len char )
     read-form , ( buf-addr buf-len char )
     old-here here>MalList ;
 
@@ -112,13 +118,13 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     dup [char] { = if [char] } read-list MalMap new tuck MalMap/list ! else
     dup [char] " = if read-string-literal else
     dup [char] : = if drop adv-str read-symbol-str MalKeyword. else
-    dup [char] @ = if drop adv-str s" deref" read-wrapped else
-    dup [char] ' = if drop adv-str s" quote" read-wrapped else
-    dup [char] ` = if drop adv-str s" quasiquote" read-wrapped else
+    dup [char] @ = if drop adv-str deref-sym read-wrapped else
+    dup [char] ' = if drop adv-str quote-sym read-wrapped else
+    dup [char] ` = if drop adv-str quasiquote-sym read-wrapped else
     dup [char] ~ = if
         drop adv-str
-        dup [char] @ = if drop adv-str s" splice-unquote" read-wrapped
-        else s" unquote" read-wrapped
+        dup [char] @ = if drop adv-str splice-unquote-sym read-wrapped
+        else unquote-sym read-wrapped
         endif
     else
     dup [char] ^ = if
diff --git a/forth/step7_quote.fs b/forth/step7_quote.fs
new file mode 100644
index 0000000..46c2fb2
--- /dev/null
+++ b/forth/step7_quote.fs
@@ -0,0 +1,301 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        \ ." eval-> " dup pr-str safe-type cr
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+: is-pair? ( obj -- bool )
+    empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+    ast is-pair? 0= if
+        here quote-sym , ast , here>MalList
+    else
+        ast to-list MalList/start @ { ast-start }
+        ast-start @ { ast[0] }
+        ast[0] unquote-sym m= if
+            ast-start cell+ @
+        else
+            ast[0] is-pair? if
+                ast[0] to-list MalList/start @ { ast[0]-start }
+                ast[0]-start @ splice-unquote-sym m= if
+                    here
+                    concat-sym ,
+                    ast[0]-start cell+ @ ,
+                    ast to-list MalList/rest quasiquote ,
+                    here>MalList
+                    false
+                else true endif
+            else true endif
+            if
+                here
+                cons-sym ,
+                ast[0] quasiquote ,
+                ast to-list MalList/rest quasiquote ,
+                here>MalList
+            endif
+        endif
+    endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+    MalList/start @ cell+ @ ( ast )
+    quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { argv argc }
+
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    mal-fn MalUserFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
+    argc 0 ?do
+        f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
+        argv i cells + @
+        env env/set
+    loop
+
+    env   mal-fn MalUserFn/body @   TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+  drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- val )
+    read
+    repl-env swap eval
+    print ;
+
+: mk-args-list ( -- )
+    here
+    begin
+        next-arg 2dup 0 0 d<> while
+            MalString. ,
+    repeat
+    2drop here>MalList ;
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: repl ( -- )
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while
+      buff swap
+      ['] rep
+      execute type
+      \ catch ?dup 0= if safe-type else ." Caught error " . endif
+      cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
+    repeat ;
+
+: main ( -- )
+    mk-args-list { args-list }
+    args-list MalList/count @ 0= if
+        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+        repl
+    else
+        args-list MalList/start @ @ { filename }
+        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+        repl-env
+        here s" load-file" MalSymbol. , filename , here>MalList
+        eval print
+    endif ;
+
+main
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 5b8a211..79965e8 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -380,6 +380,7 @@ MalDefault
     nip ;;
   extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
+  extend empty? drop mal-true ;;
 drop
 
 MalNil
-- 
cgit v1.2.3


From e82947d00f700558500e85e22aaf187544769a2e Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Tue, 17 Feb 2015 09:40:03 -0500
Subject: forth: Add step 8

---
 forth/core.fs         |  18 +++
 forth/step8_macros.fs | 330 ++++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs        |   2 +-
 3 files changed, 349 insertions(+), 1 deletion(-)
 create mode 100644 forth/step8_macros.fs

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index e601e1d..43e6b75 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -96,3 +96,21 @@ defcore concat { lists argc }
     MalList new
     start over MalList/start !
     count over MalList/count ! ;;
+
+defcore nth ( argv[coll,i] argc )
+    over ( argv argc argv )
+    cell+ @ MalInt/int @ ( argv argc count )
+    swap over <= if ." nth out of bounds" cr 1 throw endif ( argv count )
+    cells swap ( c-offset argv )
+    @ to-list MalList/start @ + @ ;;
+
+defcore first ( argv[coll] argc )
+    drop @ to-list
+    dup MalList/count @ 0= if
+        drop mal-nil
+    else
+        MalList/start @ @
+    endif ;;
+
+defcore rest ( argv[coll] argc )
+    drop @ to-list MalList/rest ;;
diff --git a/forth/step8_macros.fs b/forth/step8_macros.fs
new file mode 100644
index 0000000..c0a66c8
--- /dev/null
+++ b/forth/step8_macros.fs
@@ -0,0 +1,330 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        \ ." eval-> " dup pr-str safe-type cr
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+: is-pair? ( obj -- bool )
+    empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+    ast is-pair? 0= if
+        here quote-sym , ast , here>MalList
+    else
+        ast to-list MalList/start @ { ast-start }
+        ast-start @ { ast[0] }
+        ast[0] unquote-sym m= if
+            ast-start cell+ @
+        else
+            ast[0] is-pair? if
+                ast[0] to-list MalList/start @ { ast[0]-start }
+                ast[0]-start @ splice-unquote-sym m= if
+                    here
+                    concat-sym ,
+                    ast[0]-start cell+ @ ,
+                    ast to-list MalList/rest quasiquote ,
+                    here>MalList
+                    false
+                else true endif
+            else true endif
+            if
+                here
+                cons-sym ,
+                ast[0] quasiquote ,
+                ast to-list MalList/rest quasiquote ,
+                here>MalList
+            endif
+        endif
+    endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+    MalList/start @ cell+ @ ( ast )
+    quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set val ;;
+
+defspecial defmacro! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval { val }
+    true val MalUserFn/is-macro? !
+    val env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+: new-user-fn-env { argv argc mal-fn -- env }
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    mal-fn MalUserFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
+    argc 0 ?do
+        f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
+        argv i cells + @
+        env env/set
+    loop
+    env ;
+
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    mal-fn MalUserFn/is-macro? @ if
+        list MalList/start @ cell+  list MalList/count @ 1-
+    else
+        call-env list eval-rest
+    endif
+    mal-fn new-user-fn-env { env }
+
+    mal-fn MalUserFn/is-macro? @ if
+        env   mal-fn MalUserFn/body @   eval
+        env swap TCO-eval
+    else
+        env   mal-fn MalUserFn/body @   TCO-eval
+    endif ;;
+drop
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+    MalList/start @ cell+ @ swap over ( form env form )
+    MalList/start @ @ ( form env macro-name-expr )
+    eval { macro-fn } ( form )
+    dup MalList/start @ cell+  swap MalList/count @ 1- macro-fn ( argv argc fn )
+    new-user-fn-env ( env )
+    macro-fn MalUserFn/body @   TCO-eval ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        ." Symbol '"
+        sym as-native safe-type
+        ." ' not found." cr
+        1 throw
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+  drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- val )
+    read
+    repl-env swap eval
+    print ;
+
+: mk-args-list ( -- )
+    here
+    begin
+        next-arg 2dup 0 0 d<> while
+            MalString. ,
+    repeat
+    2drop here>MalList ;
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: repl ( -- )
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
+      ['] rep
+      \ execute type
+      catch ?dup 0= if safe-type else ." Caught error " . endif
+      cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
+    repeat ;
+
+: main ( -- )
+    mk-args-list { args-list }
+    args-list MalList/count @ 0= if
+        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+        repl
+    else
+        args-list MalList/start @ @ { filename }
+        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+        repl-env
+        here s" load-file" MalSymbol. , filename , here>MalList
+        eval print
+    endif ;
+
+main
+cr
+bye
diff --git a/forth/types.fs b/forth/types.fs
index 79965e8..07eca02 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -488,7 +488,7 @@ drop
 
 
 MalType%
-  cell% field MalUserFn/meta
+  cell% field MalUserFn/is-macro?
   cell% field MalUserFn/env
   cell% field MalUserFn/formal-args
   cell% field MalUserFn/var-arg
-- 
cgit v1.2.3


From 580c4eef9d61f39264813b662fe5335c3c3c4ee5 Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Tue, 17 Feb 2015 18:47:23 -0500
Subject: forth: Add step 9, just try*/throw

- Moved some stuff out of printer into str,
  to support throwing strings in types.fs
- Fixed an apparently completely broken 'nth'
- Still failing 120 step9 tests
---
 forth/core.fs      |  15 ++-
 forth/printer.fs   |  50 +-------
 forth/reader.fs    |   8 +-
 forth/step9_try.fs | 360 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 forth/str.fs       |  73 +++++++++++
 forth/types.fs     |  19 ++-
 6 files changed, 456 insertions(+), 69 deletions(-)
 create mode 100644 forth/step9_try.fs
 create mode 100644 forth/str.fs

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 43e6b75..c333131 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -98,11 +98,16 @@ defcore concat { lists argc }
     count over MalList/count ! ;;
 
 defcore nth ( argv[coll,i] argc )
-    over ( argv argc argv )
-    cell+ @ MalInt/int @ ( argv argc count )
-    swap over <= if ." nth out of bounds" cr 1 throw endif ( argv count )
-    cells swap ( c-offset argv )
-    @ to-list MalList/start @ + @ ;;
+    drop dup @ to-list ( argv list )
+    swap cell+ @ MalInt/int @ ( list i )
+    over MalList/count @ ( list i count )
+    2dup >= if { i count }
+        0 0
+        new-str i int>str str-append s\" \040>= " count int>str
+        s" nth out of bounds: " ...throw-str
+    endif drop ( list i )
+    cells swap ( c-offset list )
+    MalList/start @ + @ ;;
 
 defcore first ( argv[coll] argc )
     drop @ to-list
diff --git a/forth/printer.fs b/forth/printer.fs
index 5309745..645e5da 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -1,54 +1,6 @@
+require str.fs
 require types.fs
 
-: safe-type ( str-addr str-len -- )
-    dup 256 > if
-        drop 256 type ." ...<lots more>"
-    else
-        type
-    endif ;
-
-\ === mutable string buffer === /
-\ string buffer that maintains an allocation larger than the current
-\ string size.  When appending would cause the string size exceed the
-\ current allocation, resize is used to double the allocation. The
-\ current allocation is not stored anywhere, but computed based on
-\ current string size or str-base-size, whichever is larger.
-64 constant str-base-size
-
-: new-str ( -- addr length )
-  str-base-size allocate throw 0 ;
-
-: round-up ( n -- n )
-  2
-  begin
-    1 lshift 2dup <
-  until
-  nip ;
-
-: str-append { buf-addr buf-str-len str-addr str-len }
-  buf-str-len str-len +
-  { new-len }
-  new-len str-base-size >= if
-    buf-str-len new-len xor buf-str-len > if
-      buf-addr new-len round-up resize throw
-      to buf-addr
-    endif
-  endif
-  str-addr buf-addr buf-str-len + str-len cmove
-  buf-addr new-len ;
-
-\ define a-space, to append a space char to a string
-bl c,
-here constant space-str
-: a-space space-str 1 str-append ;
-
-: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
-    pad ! pad 1 str-append ;
-
-: int>str ( num -- str-addr str-len )
-  s>d <# #s #> ;
-
-
 \ === printer protocol and implementations === /
 
 def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len )
diff --git a/forth/reader.fs b/forth/reader.fs
index 1daa650..134749b 100644
--- a/forth/reader.fs
+++ b/forth/reader.fs
@@ -66,7 +66,7 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     drop \ drop leading quote
     begin ( in-addr in-len )
         adv-str over 0= if
-            2drop s\" expected '\"', got EOF\n" safe-type 1 throw
+            2drop 0 0 s\" expected '\"', got EOF" ...throw-str
         endif
         dup [char] " <>
     while
@@ -87,9 +87,9 @@ defer read-form ( str-addr str-len -- str-addr str-len mal-obj )
     begin ( str-addr str-len char )
         skip-spaces ( str-addr str-len non-space-char )
         over 0= if
-            drop 2drop
-            s\" expected '" close-char str-append-char
-            s\" ', got EOF" str-append safe-type 1 throw
+            drop 2drop 0 0 s" ', got EOF"
+            close-char pad ! pad 1
+            s" expected '" ...throw-str
         endif
         dup close-char <>
     while ( str-addr str-len non-space-non-paren-char )
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
new file mode 100644
index 0000000..5f8b189
--- /dev/null
+++ b/forth/step9_try.fs
@@ -0,0 +1,360 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        \ ." eval-> " dup pr-str safe-type cr
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
+MalNativeFn
+  extend invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
+drop
+
+SpecialOp
+  extend invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+: is-pair? ( obj -- bool )
+    empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+    ast is-pair? 0= if
+        here quote-sym , ast , here>MalList
+    else
+        ast to-list MalList/start @ { ast-start }
+        ast-start @ { ast[0] }
+        ast[0] unquote-sym m= if
+            ast-start cell+ @
+        else
+            ast[0] is-pair? if
+                ast[0] to-list MalList/start @ { ast[0]-start }
+                ast[0]-start @ splice-unquote-sym m= if
+                    here
+                    concat-sym ,
+                    ast[0]-start cell+ @ ,
+                    ast to-list MalList/rest quasiquote ,
+                    here>MalList
+                    false
+                else true endif
+            else true endif
+            if
+                here
+                cons-sym ,
+                ast[0] quasiquote ,
+                ast to-list MalList/rest quasiquote ,
+                here>MalList
+            endif
+        endif
+    endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+    MalList/start @ cell+ @ ( ast )
+    quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set val ;;
+
+defspecial defmacro! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval { val }
+    true val MalUserFn/is-macro? !
+    val env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+: new-user-fn-env { argv argc mal-fn -- env }
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    mal-fn MalUserFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
+    argc 0 ?do
+        f-args i cells + @
+        dup &-sym m= if
+            drop
+            f-args i 1+ cells + @ ( more-args-symbol )
+            MalList new ( sym more-args )
+            argc i - dup { c } over MalList/count !
+            c cells allocate throw dup { start } over MalList/start !
+            argv i cells +  start  c cells  cmove
+            env env/set
+            leave
+        endif
+        argv i cells + @
+        env env/set
+    loop
+    env ;
+
+MalUserFn
+  extend invoke { call-env list mal-fn -- list }
+    mal-fn MalUserFn/is-macro? @ if
+        list MalList/start @ cell+  list MalList/count @ 1-
+    else
+        call-env list eval-rest
+    endif
+    mal-fn new-user-fn-env { env }
+
+    mal-fn MalUserFn/is-macro? @ if
+        env   mal-fn MalUserFn/body @   eval
+        env swap TCO-eval
+    else
+        env   mal-fn MalUserFn/body @   TCO-eval
+    endif ;;
+drop
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    MalUserFn new
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+    MalList/start @ cell+ @ swap over ( form env form )
+    MalList/start @ @ ( form env macro-name-expr )
+    eval { macro-fn } ( form )
+    dup MalList/start @ cell+  swap MalList/count @ 1- macro-fn ( argv argc fn )
+    new-user-fn-env ( env )
+    macro-fn MalUserFn/body @   TCO-eval ;;
+
+5555555555 constant pre-try
+
+defspecial try* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    pre-try
+    env arg0 @ ['] eval catch ?dup 0= if
+        nip
+    else { errno }
+        begin pre-try = until
+        errno 1 <> if
+            s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+            to exception-object
+        endif
+        arg0 cell+ @ ( list[catch*,sym,form] )
+        MalList/start @ cell+ { catch0 }
+        env MalEnv. { catch-env }
+        catch0 @ exception-object catch-env env/set
+        catch-env  catch0 cell+ @  TCO-eval
+    endif ;;
+
+defspecial throw ( env list -- )
+    MalList/start @ cell+ @ eval to exception-object
+    1 throw ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        0 0 s" ' not found" sym as-native s" '" ...throw-str
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+  drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- val )
+    read
+    repl-env swap eval
+    print ;
+
+: mk-args-list ( -- )
+    here
+    begin
+        next-arg 2dup 0 0 d<> while
+            MalString. ,
+    repeat
+    2drop here>MalList ;
+
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: repl ( -- )
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
+      ['] rep
+      \ execute type
+      catch ?dup 0= if
+          safe-type cr
+          stack-leak-detect <> if ." --stack leak--" cr endif
+      else { errno }
+          begin stack-leak-detect = until
+          errno 1 <> if
+              s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+              to exception-object
+          endif
+          ." Uncaught exception: "
+          exception-object pr-str safe-type cr
+      endif
+    repeat ;
+
+: main ( -- )
+    mk-args-list { args-list }
+    args-list MalList/count @ 0= if
+        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+        repl
+    else
+        args-list MalList/start @ @ { filename }
+        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+        repl-env
+        here s" load-file" MalSymbol. , filename , here>MalList
+        eval print
+    endif ;
+
+main
+cr
+bye
diff --git a/forth/str.fs b/forth/str.fs
new file mode 100644
index 0000000..20aef32
--- /dev/null
+++ b/forth/str.fs
@@ -0,0 +1,73 @@
+: safe-type ( str-addr str-len -- )
+    dup 256 > if
+        drop 256 type ." ...<lots more>"
+    else
+        type
+    endif ;
+
+\ === mutable string buffer === /
+\ string buffer that maintains an allocation larger than the current
+\ string size.  When appending would cause the string size exceed the
+\ current allocation, resize is used to double the allocation. The
+\ current allocation is not stored anywhere, but computed based on
+\ current string size or str-base-size, whichever is larger.
+64 constant str-base-size
+
+: new-str ( -- addr length )
+  str-base-size allocate throw 0 ;
+
+: round-up ( n -- n )
+  2
+  begin
+    1 lshift 2dup <
+  until
+  nip ;
+
+: str-append { buf-addr buf-str-len str-addr str-len }
+  buf-str-len str-len +
+  { new-len }
+  new-len str-base-size >= if
+    buf-str-len new-len xor buf-str-len > if
+      buf-addr new-len round-up resize throw
+      to buf-addr
+    endif
+  endif
+  str-addr buf-addr buf-str-len + str-len cmove
+  buf-addr new-len ;
+
+\ define a-space, to append a space char to a string
+bl c,
+here constant space-str
+: a-space space-str 1 str-append ;
+
+: str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
+    pad ! pad 1 str-append ;
+
+\ from gforth docs, there named 'my-.'
+: int>str ( num -- str-addr str-len )
+    \ handling negatives.. behaves like Standard .
+    s>d            \ convert to signed double
+    swap over dabs \ leave sign byte followed by unsigned double
+    <<#            \ start conversion
+    #s             \ convert all digits
+    rot sign       \ get at sign byte, append "-" if needed
+    #>             \ complete conversion
+    #>> ;          \ release hold area
+
+defer MalString.
+
+: ...str
+    new-str
+    begin
+        2swap
+        over 0 <>
+    while
+        str-append
+    repeat
+    2drop MalString. ;
+
+nil value exception-object
+
+: ...throw-str
+    ...str to exception-object
+    1 throw ;
diff --git a/forth/types.fs b/forth/types.fs
index 07eca02..d238001 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -1,3 +1,5 @@
+require str.fs
+
 \ === sorted-array === /
 \ Here are a few utility functions useful for creating and maintaining
 \ the deftype* method tables. The keys array is kept in sorted order,
@@ -131,10 +133,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
 \ themselves for the given object, and then execute that implementation.
 : execute-method { obj pxt -- }
   obj not-object? if
-      ." Refusing to invoke protocol fn '"
-      pxt >name name>string type
-      ." ' on non-object: " obj .
-      1 throw
+      0 0 obj int>str s" ' on non-object: " pxt >name name>string
+      s" Refusing to invoke protocol fn '" ...throw-str
   endif
   obj mal-type @ dup MalTypeType-methods 2@ swap ( type methods method-keys )
   dup 0= if \ No protocols extended to this type; check for a default
@@ -148,12 +148,8 @@ MalType% deftype MalFalse MalFalse new constant mal-false
   endif
   0= if ( type idx )
       2drop
-      ." No protocol fn '"
-      pxt >name name>string type
-      ." ' extended to type '"
-      obj mal-type @ type-name type
-      ." '" cr
-      1 throw
+      0 0 s" '" obj mal-type @ type-name s" ' extended to type '"
+      pxt >name name>string s" No protocol fn '" ...throw-str
   endif
   trace if ." Calling '" pxt >name name>string type ." ' on " obj mal-type @ type-name type cr endif
 
@@ -449,11 +445,12 @@ MalType%
   cell% field MalString/str-len
 deftype MalString
 
-: MalString. { str-addr str-len -- mal-str }
+: MalString.0 { str-addr str-len -- mal-str }
     MalString new { str }
     str-addr str MalString/str-addr !
     str-len  str MalString/str-len  !
     str ;
+' MalString.0 is MalString.
 
 : unpack-str ( mal-string -- addr len )
     dup MalString/str-addr @
-- 
cgit v1.2.3


From 224e09ed42325f000ee9a31a500bebe03a1ba97c Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Wed, 18 Feb 2015 19:57:39 -0500
Subject: forth: Finish step 9

---
 forth/core.fs      | 131 ++++++++++++++++++++++++++++++++++++++++++++++-------
 forth/printer.fs   |  29 +++++++-----
 forth/step9_try.fs |  76 +++++++++++++++++++++++--------
 forth/types.fs     |  79 +++++++++++++++++++++++++++++---
 4 files changed, 260 insertions(+), 55 deletions(-)

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index c333131..4216574 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -24,14 +24,16 @@ defcore <= args-as-native <= mal-bool ;;
 defcore >= args-as-native >= mal-bool ;;
 
 defcore list { argv argc }
-    MalList new { list }
     argc cells allocate throw { start }
     argv  start  argc cells  cmove
-    argc  list MalList/count !
-    start list MalList/start !
-    list ;;
+    start argc MalList. ;;
+
+defcore vector { argv argc }
+    argc cells allocate throw { start }
+    argv  start  argc cells  cmove
+    start argc MalList.
+    MalVector new swap over MalVector/list ! ;;
 
-defcore list? drop @ mal-type @ MalList = mal-bool ;;
 defcore empty? drop @ empty? ;;
 defcore count drop @ mal-count ;;
 
@@ -83,19 +85,66 @@ defcore cons ( argv[item,coll] argc )
     to-list conj ;;
 
 defcore concat { lists argc }
-    0   lists argc cells +  lists  +do ( count )
-        i @ to-list MalList/count @ +
-    cell +loop { count }
-    count cells allocate throw { start }
-    start   lists argc cells +  lists  +do ( target )
-        i @ to-list MalList/count @ cells  2dup  i @ to-list MalList/start @  -rot  ( target bytes src target bytes )
-        cmove ( target bytes )
-        + ( new-target )
-    cell +loop
-    drop
     MalList new
-    start over MalList/start !
-    count over MalList/count ! ;;
+    lists over MalList/start !
+    argc over MalList/count !
+    MalList/concat ;;
+
+defcore conj { argv argc }
+    argv @ ( coll )
+    argc 1 ?do
+        argv i cells + @ swap conj
+    loop ;;
+
+defcore assoc { argv argc }
+    argv @ ( coll )
+    argv argc cells +  argv cell+  +do
+        i @ \ key
+        i cell+ @ \ val
+        rot assoc
+    2 cells +loop ;;
+
+defcore keys ( argv argc )
+    drop @ MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    here
+    start count cells +  start  +do
+        i @ ,
+    2 cells +loop
+    here>MalList ;;
+
+defcore vals ( argv argc )
+    drop @ MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    here
+    start count cells +  start cell+  +do
+        i @ ,
+    2 cells +loop
+    here>MalList ;;
+
+defcore dissoc { argv argc }
+    argv @ \ coll
+    argv argc cells +  argv cell+  +do
+        i @ swap dissoc
+    cell +loop ;;
+
+defcore hash-map { argv argc }
+    MalMap/Empty
+    argc cells argv +  argv  +do
+        i @  i cell+ @  rot  assoc
+    2 cells +loop ;;
+
+defcore get { argv argc }
+    argc 3 < if mal-nil else argv cell+ cell+ @ endif
+    argv cell+ @ \ key
+    argv @ \ coll
+    get ;;
+
+defcore contains? { argv argc }
+    0
+    argv cell+ @ \ key
+    argv @ \ coll
+    get 0 <> mal-bool ;;
 
 defcore nth ( argv[coll,i] argc )
     drop dup @ to-list ( argv list )
@@ -119,3 +168,51 @@ defcore first ( argv[coll] argc )
 
 defcore rest ( argv[coll] argc )
     drop @ to-list MalList/rest ;;
+
+defcore meta ( argv[obj] argc )
+    drop @ mal-meta @
+    ?dup 0= if mal-nil endif ;;
+
+defcore with-meta ( argv[obj,meta] argc )
+    drop ( argv )
+    dup cell+ @  swap @  ( meta obj )
+    dup mal-type @ MalTypeType-struct @ ( meta obj obj-size )
+    dup allocate throw { new-obj } ( meta obj obj-size )
+    new-obj swap cmove ( meta )
+    new-obj mal-meta ! ( )
+    new-obj ;;
+
+defcore atom ( argv[val] argc )
+    drop @ Atom. ;;
+
+defcore deref ( argv[atom] argc )
+    drop @ Atom/val @ ;;
+
+defcore reset! ( argv[atom,val] argc )
+    drop dup cell+ @ ( argv val )
+    dup -rot swap @ Atom/val ! ;;
+
+defcore apply { argv argc -- val }
+    \ argv is (fn args... more-args)
+    argv argc 1- cells + @ to-list { more-args }
+    argc 2 - { list0len }
+    more-args MalList/count @ list0len + { final-argc }
+    final-argc cells allocate throw { final-argv }
+    argv cell+   final-argv   list0len cells   cmove
+    more-args MalList/start @   final-argv list0len cells +  final-argc list0len - cells  cmove
+    final-argv final-argc argv @  invoke ;;
+
+
+defcore map?     drop @ mal-type @ MalMap     = mal-bool ;;
+defcore list?    drop @ mal-type @ MalList    = mal-bool ;;
+defcore vector?  drop @ mal-type @ MalVector  = mal-bool ;;
+defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;;
+defcore symbol?  drop @ mal-type @ MalSymbol  = mal-bool ;;
+defcore true?    drop @ mal-true  = mal-bool ;;
+defcore false?   drop @ mal-false = mal-bool ;;
+defcore nil?     drop @ mal-nil   = mal-bool ;;
+
+defcore sequential? drop @ sequential? ;;
+
+defcore keyword  drop @ unpack-str MalKeyword. ;;
+defcore symbol   drop @ unpack-str MalSymbol. ;;
\ No newline at end of file
diff --git a/forth/printer.fs b/forth/printer.fs
index 645e5da..85f88a0 100644
--- a/forth/printer.fs
+++ b/forth/printer.fs
@@ -5,7 +5,6 @@ require types.fs
 
 def-protocol-method pr-buf ( readably? str-addr str-len this -- str-addr str-len )
 def-protocol-method pr-seq-buf ( readably? str-addr str-len this -- str-addr str-len )
-def-protocol-method pr-pairs-buf ( readably? str-addr str-len this -- str-addr str-len )
 
 : pr-str { obj }
     true new-str obj pr-buf rot drop ;
@@ -39,15 +38,6 @@ MalList
             start i cells + @ pr-buf
         loop
     endif ;;
-  extend pr-pairs-buf { list }
-    list MalList/start @ { start }
-    start @ pr-buf a-space start cell+ @ pr-buf
-    list MalList/count @ 2 / 1 ?do
-        s" , " str-append
-        a-space
-        start i 2 * cells + @ pr-buf a-space
-        start i 2 * 1+ cells + @ pr-buf
-    loop ;;
 drop
 
 MalVector
@@ -62,7 +52,17 @@ MalMap
   extend pr-buf
     MalMap/list @
     -rot s" {" str-append ( list str-addr str-len )
-    rot pr-pairs-buf
+    rot { list }
+    list MalList/count @ { count }
+    count 0 > if
+        list MalList/start @ { start }
+        start @ pr-buf a-space start cell+ @ pr-buf
+        count 2 / 1 ?do
+            s" , " str-append
+            start i 2 * cells + @ pr-buf a-space
+            start i 2 * 1+ cells + @ pr-buf
+        loop
+    endif
     s" }" str-append ;;
 drop
 
@@ -105,3 +105,10 @@ MalString
         str-append
     endif ;;
 drop
+
+Atom
+  extend pr-buf { this }
+    s" (atom " str-append
+    this Atom/val @ pr-buf
+    s" )" str-append ;;
+drop
\ No newline at end of file
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
index 5f8b189..356304a 100644
--- a/forth/step9_try.fs
+++ b/forth/step9_try.fs
@@ -5,10 +5,13 @@ require core.fs
 core MalEnv. constant repl-env
 
 \ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
+\ def-protocol-method mal-eval ( env ast -- val )
 
 \ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+\ def-protocol-method eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+\ def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 99999999 constant TCO-eval
 
@@ -28,7 +31,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
+  extend eval-invoke { env list kw -- val }
     0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
@@ -38,6 +41,15 @@ MalKeyword
             mal-nil
         endif
     endif ;;
+  extend invoke { argv argc kw -- val }
+    0   kw   argv @   get
+    ?dup 0= if
+        argc 1 > if
+            argv cell+ @
+        else
+            mal-nil
+        endif
+    endif ;;
 drop
 
 \ eval all but the first item of list
@@ -52,14 +64,15 @@ drop
     target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
-    MalNativeFn/xt @ { xt }
-    eval-rest ( argv argc )
-    xt execute ( return-val ) ;;
+  extend eval-invoke { env list this -- list }
+    env list eval-rest ( argv argc )
+    this invoke ;;
+  extend invoke ( argv argc this -- val )
+    MalNativeFn/xt @ execute ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -191,12 +204,11 @@ s" &" MalSymbol. constant &-sym
         f-args i cells + @
         dup &-sym m= if
             drop
-            f-args i 1+ cells + @ ( more-args-symbol )
-            MalList new ( sym more-args )
-            argc i - dup { c } over MalList/count !
-            c cells allocate throw dup { start } over MalList/start !
+            argc i - { c }
+            c cells allocate throw { start }
             argv i cells +  start  c cells  cmove
-            env env/set
+            f-args i 1+ cells + @ ( more-args-symbol )
+            start c MalList. env env/set
             leave
         endif
         argv i cells + @
@@ -205,13 +217,16 @@ s" &" MalSymbol. constant &-sym
     env ;
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
+  extend eval-invoke { call-env list mal-fn -- list }
     mal-fn MalUserFn/is-macro? @ if
         list MalList/start @ cell+  list MalList/count @ 1-
     else
         call-env list eval-rest
     endif
-    mal-fn new-user-fn-env { env }
+    mal-fn invoke ;;
+
+  extend invoke ( argv argc mal-fn )
+    dup { mal-fn } new-user-fn-env { env }
 
     mal-fn MalUserFn/is-macro? @ if
         env   mal-fn MalUserFn/body @   eval
@@ -224,6 +239,7 @@ drop
 defspecial fn* { env list -- val }
     list MalList/start @ cell+ { arg0 }
     MalUserFn new
+    false over MalUserFn/is-macro? !
     env over MalUserFn/env !
     arg0 @ to-list over MalUserFn/formal-args !
     arg0 cell+ @ over MalUserFn/body ! ;;
@@ -280,7 +296,7 @@ drop
 MalList
   extend mal-eval { env list -- val }
     env list MalList/start @ @ eval
-    env list rot invoke ;;
+    env list rot eval-invoke ;;
 drop
 
 MalVector
@@ -311,12 +327,30 @@ defcore eval ( argv argc )
     repeat
     2drop here>MalList ;
 
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: nop ;
+
+defcore map ( argv argc -- list )
+    drop dup @ swap cell+ @ to-list { fn list }
+    here
+    list MalList/start @   list MalList/count @  cells   over + swap   +do
+        i 1 fn invoke
+        dup TCO-eval = if drop eval endif
+        ,
+    cell +loop
+    here>MalList ;;
+
+defcore readline ( argv argc -- mal-string )
+    drop @ unpack-str type
+    buff 128 stdin read-line throw
+    if buff swap MalString. else mal-nil endif ;;
+
 s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
 s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
 s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
-
-create buff 128 allot
-77777777777 constant stack-leak-detect
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
 
 : repl ( -- )
     begin
@@ -326,7 +360,7 @@ create buff 128 allot
     while ( num-bytes-read )
       buff swap ( str-addr str-len )
       ['] rep
-      \ execute type
+      execute ['] nop \ uncomment to see stack traces
       catch ?dup 0= if
           safe-type cr
           stack-leak-detect <> if ." --stack leak--" cr endif
@@ -358,3 +392,5 @@ create buff 128 allot
 main
 cr
 bye
+
+4
\ No newline at end of file
diff --git a/forth/types.fs b/forth/types.fs
index d238001..1ce74d9 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -59,6 +59,7 @@ require str.fs
 
 struct
   cell% field mal-type
+  cell% field mal-meta
   \ cell% field ref-count \ Ha, right.
 end-struct MalType%
 
@@ -74,6 +75,7 @@ end-struct MalTypeType%
 : new ( MalTypeType -- obj )
   dup MalTypeType-struct 2@ %allocate throw ( MalTypeType obj ) \ create struct
   dup -rot mal-type !                       ( obj ) \ set struct's type pointer to this type
+  nil over mal-meta !
   ;
 
 : deftype* ( struct-align struct-len -- MalTypeType )
@@ -218,6 +220,7 @@ end-extend
 
 def-protocol-method conj ( obj this -- this )
 def-protocol-method assoc ( k v this -- this )
+def-protocol-method dissoc ( k this -- this )
 def-protocol-method get ( not-found k this -- value )
 def-protocol-method mal= ( a b -- bool )
 def-protocol-method as-native ( obj --  )
@@ -225,6 +228,20 @@ def-protocol-method as-native ( obj --  )
 def-protocol-method to-list ( obj -- mal-list )
 def-protocol-method empty? ( obj -- mal-bool )
 def-protocol-method mal-count ( obj -- mal-int )
+def-protocol-method sequential? ( obj -- mal-bool )
+
+
+\ Fully evalutate any Mal object:
+def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+def-protocol-method eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+
+
 
 : m= ( a b -- bool )
     2dup = if
@@ -259,6 +276,11 @@ MalType%
   cell% field MalList/start
 deftype MalList
 
+: MalList. ( start count -- mal-list )
+    MalList new
+    swap over MalList/count ! ( start list )
+    swap over MalList/start ! ( list ) ;
+
 : here>MalList ( old-here -- mal-list )
     here over - { bytes } ( old-here )
     MalList new bytes ( old-here mal-list bytes )
@@ -268,8 +290,22 @@ deftype MalList
     0 bytes - allot \ pop list contents from dictionary stack
     ;
 
+: MalList/concat ( list-of-lists )
+    dup MalList/start @ swap MalList/count @ { lists argc }
+    0   lists argc cells +  lists  +do ( count )
+        i @ to-list MalList/count @ +
+    cell +loop { count }
+    count cells allocate throw { start }
+    start   lists argc cells +  lists  +do ( target )
+        i @ to-list MalList/count @ cells  2dup  i @ to-list MalList/start @  -rot  ( target bytes src target bytes )
+        cmove ( target bytes )
+        + ( new-target )
+    cell +loop
+    drop start count MalList. ;
+
 MalList
   extend to-list ;;
+  extend sequential? drop mal-true ;;
   extend conj { elem old-list -- list }
     old-list MalList/count @ 1+ { new-count }
     new-count cells allocate throw { new-start }
@@ -277,10 +313,7 @@ MalList
     new-count 1 > if
       old-list MalList/start @   new-start cell+   new-count 1- cells  cmove
     endif
-
-    MalList new
-    new-count over MalList/count !
-    new-start over MalList/start ! ;;
+    new-start new-count MalList. ;;
   extend empty? MalList/count @ 0= mal-bool ;;
   extend mal-count MalList/count @ MalInt. ;;
   extend mal=
@@ -306,9 +339,9 @@ drop
 MalList new 0 over MalList/count ! constant MalList/Empty
 
 : MalList/rest { list -- list }
-    MalList new
-    list MalList/start @   cell+   over MalList/start !
-    list MalList/count @   1-      over MalList/count ! ;
+    list MalList/start @   cell+
+    list MalList/count @   1-
+    MalList. ;
 
 
 MalType%
@@ -316,6 +349,7 @@ MalType%
 deftype MalVector
 
 MalVector
+  extend sequential? drop mal-true ;;
   extend to-list
     MalVector/list @ ;;
   extend empty?
@@ -326,6 +360,15 @@ MalVector
     MalList/count @ MalInt. ;;
   extend mal=
     MalVector/list @ swap m= ;;
+  extend conj
+    MalVector/list @ { elem old-list }
+    old-list MalList/count @ { old-count }
+    old-count 1+ cells allocate throw { new-start }
+    elem new-start old-count cells + !
+    old-list MalList/start @   new-start old-count cells  cmove
+    new-start   old-count 1+  MalList.
+    MalVector new swap
+    over MalVector/list ! ;;
 drop
 
 MalType%
@@ -346,6 +389,19 @@ MalMap
     conj conj
     MalMap new dup -rot MalMap/list ! \ put back in map
     ;;
+  extend dissoc { k map -- map }
+    map MalMap/list @
+    dup MalList/start @ swap MalList/count @ { start count }
+    map \ return original if key not found
+    count 0 +do
+        start i cells + @ k mal= if
+            drop here
+            start i MalList. ,
+            start i 2 + cells +  count i - 2 - MalList. ,
+            here>MalList MalList/concat
+            MalMap new dup -rot MalMap/list ! \ put back in map
+        endif
+    2 +loop ;;
   extend get { not-found k map -- value }
     map MalMap/list @
     dup MalList/start @ { start }
@@ -377,12 +433,15 @@ MalDefault
   extend as-native ;; ( obj -- obj )
   extend to-list drop 0 ;;
   extend empty? drop mal-true ;;
+  extend sequential? drop mal-false ;;
 drop
 
 MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
+  extend get drop 2drop mal-nil ;;
+  extend to-list drop MalList/Empty ;;
   extend empty? drop mal-true ;;
   extend mal-count drop 0 MalInt. ;;
   extend mal= drop mal-nil = ;;
@@ -499,3 +558,9 @@ deftype SpecialOp
 
 : SpecialOp.
     SpecialOp new swap over SpecialOp/xt ! ;
+
+MalType%
+  cell% field Atom/val
+deftype Atom
+
+: Atom. Atom new swap over Atom/val ! ;
-- 
cgit v1.2.3


From 6512bd80002eb106a304b035e9592847d90ef23c Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 19 Feb 2015 18:34:59 -0500
Subject: forth: Self-hosted mal passes all tests

---
 forth/core.fs          |   8 +-
 forth/step9_try.fs     |   4 -
 forth/stepA_interop.fs | 392 +++++++++++++++++++++++++++++++++++++++++++++++++
 forth/types.fs         |  31 ++--
 4 files changed, 417 insertions(+), 18 deletions(-)
 create mode 100644 forth/stepA_interop.fs

(limited to 'forth')

diff --git a/forth/core.fs b/forth/core.fs
index 4216574..1a1cc4d 100644
--- a/forth/core.fs
+++ b/forth/core.fs
@@ -202,12 +202,16 @@ defcore apply { argv argc -- val }
     more-args MalList/start @   final-argv list0len cells +  final-argc list0len - cells  cmove
     final-argv final-argc argv @  invoke ;;
 
+defcore throw ( argv argc -- )
+    drop @ to exception-object
+    1 throw ;;
 
 defcore map?     drop @ mal-type @ MalMap     = mal-bool ;;
 defcore list?    drop @ mal-type @ MalList    = mal-bool ;;
 defcore vector?  drop @ mal-type @ MalVector  = mal-bool ;;
 defcore keyword? drop @ mal-type @ MalKeyword = mal-bool ;;
 defcore symbol?  drop @ mal-type @ MalSymbol  = mal-bool ;;
+defcore atom?    drop @ mal-type @ Atom       = mal-bool ;;
 defcore true?    drop @ mal-true  = mal-bool ;;
 defcore false?   drop @ mal-false = mal-bool ;;
 defcore nil?     drop @ mal-nil   = mal-bool ;;
@@ -215,4 +219,6 @@ defcore nil?     drop @ mal-nil   = mal-bool ;;
 defcore sequential? drop @ sequential? ;;
 
 defcore keyword  drop @ unpack-str MalKeyword. ;;
-defcore symbol   drop @ unpack-str MalSymbol. ;;
\ No newline at end of file
+defcore symbol   drop @ unpack-str MalSymbol. ;;
+
+defcore time-ms 2drop utime d>s 1000 / MalInt. ;;
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
index 356304a..e7293db 100644
--- a/forth/step9_try.fs
+++ b/forth/step9_try.fs
@@ -272,10 +272,6 @@ defspecial try* { env list -- val }
         catch-env  catch0 cell+ @  TCO-eval
     endif ;;
 
-defspecial throw ( env list -- )
-    MalList/start @ cell+ @ eval to exception-object
-    1 throw ;;
-
 MalSymbol
   extend mal-eval { env sym -- val }
     0 sym env get
diff --git a/forth/stepA_interop.fs b/forth/stepA_interop.fs
new file mode 100644
index 0000000..d25d094
--- /dev/null
+++ b/forth/stepA_interop.fs
@@ -0,0 +1,392 @@
+require reader.fs
+require printer.fs
+require core.fs
+
+core MalEnv. constant repl-env
+
+\ Fully evalutate any Mal object:
+\ def-protocol-method mal-eval ( env ast -- val )
+
+\ Invoke an object, given whole env and unevaluated argument forms:
+\ def-protocol-method eval-invoke ( env list obj -- ... )
+
+\ Invoke a function, given parameter values
+\ def-protocol-method invoke ( argv argc mal-fn -- ... )
+
+99999999 constant TCO-eval
+
+: read read-str ;
+: eval ( env obj )
+    begin
+        \ ." eval-> " dup pr-str safe-type cr
+        mal-eval
+        dup TCO-eval =
+    while
+        drop
+    repeat ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
+
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
+
+MalKeyword
+  extend eval-invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  TCO-eval
+        else
+            mal-nil
+        endif
+    endif ;;
+  extend invoke { argv argc kw -- val }
+    0   kw   argv @   get
+    ?dup 0= if
+        argc 1 > if
+            argv cell+ @
+        else
+            mal-nil
+        endif
+    endif ;;
+drop
+
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
+MalNativeFn
+  extend eval-invoke { env list this -- list }
+    env list eval-rest ( argv argc )
+    this invoke ;;
+  extend invoke ( argv argc this -- val )
+    MalNativeFn/xt @ execute ;;
+drop
+
+SpecialOp
+  extend eval-invoke ( env list this -- list )
+    SpecialOp/xt @ execute ;;
+drop
+
+: install-special ( symbol xt )
+    SpecialOp. repl-env env/set ;
+
+: defspecial
+    parse-allot-name MalSymbol.
+    ['] install-special
+    :noname
+    ;
+
+: is-pair? ( obj -- bool )
+    empty? mal-false = ;
+
+defspecial quote ( env list -- form )
+    nip MalList/start @ cell+ @ ;;
+
+s" concat" MalSymbol. constant concat-sym
+s" cons" MalSymbol. constant cons-sym
+
+defer quasiquote
+: quasiquote0 { ast -- form }
+    ast is-pair? 0= if
+        here quote-sym , ast , here>MalList
+    else
+        ast to-list MalList/start @ { ast-start }
+        ast-start @ { ast[0] }
+        ast[0] unquote-sym m= if
+            ast-start cell+ @
+        else
+            ast[0] is-pair? if
+                ast[0] to-list MalList/start @ { ast[0]-start }
+                ast[0]-start @ splice-unquote-sym m= if
+                    here
+                    concat-sym ,
+                    ast[0]-start cell+ @ ,
+                    ast to-list MalList/rest quasiquote ,
+                    here>MalList
+                    false
+                else true endif
+            else true endif
+            if
+                here
+                cons-sym ,
+                ast[0] quasiquote ,
+                ast to-list MalList/rest quasiquote ,
+                here>MalList
+            endif
+        endif
+    endif ;
+' quasiquote0 is quasiquote
+
+defspecial quasiquote ( env list )
+    MalList/start @ cell+ @ ( ast )
+    quasiquote TCO-eval ;;
+
+defspecial def! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set val ;;
+
+defspecial defmacro! { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    arg0 @ ( key )
+    env arg0 cell+ @ eval { val }
+    true val MalUserFn/is-macro? !
+    val env env/set
+    val ;;
+
+defspecial let* { old-env list -- val }
+    old-env MalEnv. { env }
+    list MalList/start @ cell+ dup { arg0 }
+    @ to-list
+    dup MalList/start @ { bindings-start } ( list )
+    MalList/count @ 0 +do
+        bindings-start i cells + dup @ swap cell+ @ ( sym expr )
+        env swap eval
+        env env/set
+    2 +loop
+    env arg0 cell+ @ TCO-eval
+    \ TODO: dec refcount of env
+    ;;
+
+defspecial do { env list -- val }
+    list MalList/start @ { start }
+    list MalList/count @ dup 1- { last } 1 ?do
+        env   start i cells + @
+        i last = if
+            TCO-eval
+        else
+            eval drop
+        endif
+    loop ;;
+
+defspecial if { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    env arg0 @ eval ( test-val )
+    dup mal-false = if
+        drop -1
+    else
+        mal-nil =
+    endif
+    if
+        \ branch to false
+        list MalList/count @ 3 > if
+            env arg0 cell+ cell+ @ TCO-eval
+        else
+            mal-nil
+        endif
+    else
+        \ branch to true
+        env arg0 cell+ @ TCO-eval
+    endif ;;
+
+s" &" MalSymbol. constant &-sym
+
+: new-user-fn-env { argv argc mal-fn -- env }
+    mal-fn MalUserFn/formal-args @ { f-args-list }
+    mal-fn MalUserFn/env @ MalEnv. { env }
+
+    f-args-list MalList/start @ { f-args }
+    f-args-list MalList/count @ ?dup 0= if else
+        \ pass nil for last arg, unless overridden below
+        1- cells f-args + @ mal-nil env env/set
+    endif
+    argc 0 ?do
+        f-args i cells + @
+        dup &-sym m= if
+            drop
+            argc i - { c }
+            c cells allocate throw { start }
+            argv i cells +  start  c cells  cmove
+            f-args i 1+ cells + @ ( more-args-symbol )
+            start c MalList. env env/set
+            leave
+        endif
+        argv i cells + @
+        env env/set
+    loop
+    env ;
+
+MalUserFn
+  extend eval-invoke { call-env list mal-fn -- list }
+    mal-fn MalUserFn/is-macro? @ if
+        list MalList/start @ cell+  \ argv
+        list MalList/count @ 1-     \ argc
+        mal-fn new-user-fn-env { env }
+        env   mal-fn MalUserFn/body @   eval
+        call-env swap TCO-eval
+    else
+        call-env list eval-rest
+        mal-fn invoke
+    endif ;;
+
+  extend invoke ( argv argc mal-fn )
+    dup { mal-fn } new-user-fn-env { env }
+    env   mal-fn MalUserFn/body @   TCO-eval ;;
+drop
+
+defspecial fn* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    MalUserFn new
+    false over MalUserFn/is-macro? !
+    env over MalUserFn/env !
+    arg0 @ to-list over MalUserFn/formal-args !
+    arg0 cell+ @ over MalUserFn/body ! ;;
+
+defspecial macroexpand ( env list[_,form] -- form )
+    MalList/start @ cell+ @ swap over ( form env form )
+    MalList/start @ @ ( form env macro-name-expr )
+    eval { macro-fn } ( form )
+    dup MalList/start @ cell+  swap MalList/count @ 1- macro-fn ( argv argc fn )
+    new-user-fn-env ( env )
+    macro-fn MalUserFn/body @   TCO-eval ;;
+
+5555555555 constant pre-try
+
+defspecial try* { env list -- val }
+    list MalList/start @ cell+ { arg0 }
+    pre-try
+    env arg0 @ ['] eval catch ?dup 0= if
+        nip
+    else { errno }
+        begin pre-try = until
+        errno 1 <> if
+            s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+            to exception-object
+        endif
+        arg0 cell+ @ ( list[catch*,sym,form] )
+        MalList/start @ cell+ { catch0 }
+        env MalEnv. { catch-env }
+        catch0 @ exception-object catch-env env/set
+        catch-env  catch0 cell+ @  TCO-eval
+    endif ;;
+
+MalSymbol
+  extend mal-eval { env sym -- val }
+    0 sym env get
+    dup 0= if
+        drop
+        0 0 s" ' not found" sym as-native s" '" ...throw-str
+    endif ;;
+drop
+
+: eval-ast { env list -- list }
+    here
+    list MalList/start @ { expr-start }
+    list MalList/count @ 0 ?do
+        env expr-start i cells + @ eval ,
+    loop
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot eval-invoke ;;
+drop
+
+MalVector
+  extend mal-eval ( env vector -- vector )
+    MalVector/list @ eval-ast
+    MalVector new swap over MalVector/list ! ;;
+drop
+
+MalMap
+  extend mal-eval ( env map -- map )
+    MalMap/list @ eval-ast
+    MalMap new swap over MalMap/list ! ;;
+drop
+
+defcore eval ( argv argc )
+  drop @ repl-env swap eval ;;
+
+: rep ( str-addr str-len -- val )
+    read
+    repl-env swap eval
+    print ;
+
+: mk-args-list ( -- )
+    here
+    begin
+        next-arg 2dup 0 0 d<> while
+            MalString. ,
+    repeat
+    2drop here>MalList ;
+
+create buff 128 allot
+77777777777 constant stack-leak-detect
+
+: nop ;
+
+defcore map ( argv argc -- list )
+    drop dup @ swap cell+ @ to-list { fn list }
+    here
+    list MalList/start @   list MalList/count @  cells   over + swap   +do
+        i 1 fn invoke
+        dup TCO-eval = if drop eval endif
+        ,
+    cell +loop
+    here>MalList ;;
+
+defcore readline ( argv argc -- mal-string )
+    drop @ unpack-str type stdout flush-file drop
+    buff 128 stdin read-line throw
+    if buff swap MalString. else drop mal-nil endif ;;
+
+s\" (def! *host-language* \"forth\")" rep drop
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
+
+: repl ( -- )
+    s\" (println (str \"Mal [\" *host-language* \"]\"))" rep drop
+    begin
+      ." user> "
+      stack-leak-detect
+      buff 128 stdin read-line throw
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
+      ['] rep
+      \ execute ['] nop \ uncomment to see stack traces
+      catch ?dup 0= if
+          safe-type cr
+          stack-leak-detect <> if ." --stack leak--" cr endif
+      else { errno }
+          begin stack-leak-detect = until
+          errno 1 <> if
+              s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
+              to exception-object
+          endif
+          ." Uncaught mal or forth exception: "
+          exception-object pr-str safe-type cr
+      endif
+    repeat ;
+
+: main ( -- )
+    mk-args-list { args-list }
+    args-list MalList/count @ 0= if
+        s" *ARGV*" MalSymbol. MalList/Empty repl-env env/set
+        repl
+    else
+        args-list MalList/start @ @ { filename }
+        s" *ARGV*" MalSymbol. args-list MalList/rest repl-env env/set
+
+        repl-env
+        here s" load-file" MalSymbol. , filename , here>MalList
+        eval print
+    endif ;
+
+main
+cr
+bye
+
+4
\ No newline at end of file
diff --git a/forth/types.fs b/forth/types.fs
index 1ce74d9..b936603 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -317,21 +317,25 @@ MalList
   extend empty? MalList/count @ 0= mal-bool ;;
   extend mal-count MalList/count @ MalInt. ;;
   extend mal=
-    swap to-list dup 0= if
-        nip
+    over mal-nil = if
+        2drop false
     else
-        2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
-            -rot MalList/start @ swap MalList/start @ { start-b start-a }
-            true swap ( return-val count )
-            0 ?do
-                start-a i cells + @
-                start-b i cells + @
-                m= if else
-                    drop false leave
-                endif
-            loop
+        swap to-list dup 0= if
+            nip
         else
-            drop 2drop false
+            2dup MalList/count @ swap MalList/count @ over = if ( list-a list-b count )
+                -rot MalList/start @ swap MalList/start @ { start-b start-a }
+                true swap ( return-val count )
+                0 ?do
+                    start-a i cells + @
+                    start-b i cells + @
+                    m= if else
+                        drop false leave
+                    endif
+                loop
+            else
+                drop 2drop false
+            endif
         endif
     endif ;;
 drop
@@ -434,6 +438,7 @@ MalDefault
   extend to-list drop 0 ;;
   extend empty? drop mal-true ;;
   extend sequential? drop mal-false ;;
+  extend mal= = ;;
 drop
 
 MalNil
-- 
cgit v1.2.3


From 45c1894b9690b1156ffdc2caeb726bbc9526597a Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Thu, 19 Feb 2015 19:42:52 -0500
Subject: forth: Back-propogate fixes from stepA through step1

---
 forth/step1_read_print.fs |  22 ++++-----
 forth/step2_eval.fs       |  86 +++++++++++++++++++---------------
 forth/step3_env.fs        |  93 ++++++++++++++++++-------------------
 forth/step4_if_fn_do.fs   | 115 +++++++++++++++++++---------------------------
 forth/step5_tco.fs        |  59 ++++++++++--------------
 forth/step6_file.fs       |  33 ++++++-------
 forth/step7_quote.fs      |  33 ++++++-------
 forth/step8_macros.fs     |  26 ++++-------
 forth/step9_try.fs        |  45 +++++++-----------
 forth/stepA_interop.fs    |  27 ++++-------
 forth/types.fs            |   2 -
 11 files changed, 233 insertions(+), 308 deletions(-)

(limited to 'forth')

diff --git a/forth/step1_read_print.fs b/forth/step1_read_print.fs
index 02783bf..9e42995 100644
--- a/forth/step1_read_print.fs
+++ b/forth/step1_read_print.fs
@@ -3,34 +3,32 @@ require printer.fs
 
 : read read-str ;
 : eval ;
-: print pr-str ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
 
-: rep
+: rep ( str-addr str-len -- str-addr str-len )
     read
     eval
     print ;
 
 create buff 128 allot
+77777777777 constant stack-leak-detect
 
 : read-lines
     begin
       ." user> "
+      stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
       \ execute safe-type
-      catch 0= if safe-type endif
+      catch ?dup 0= if safe-type else ." Caught error " . endif
       cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
     repeat ;
 
-\ s" 1   (42 1 (2 12 8)) 35" swap 1+ swap .s read-str .s
-\ s" 7" .s read-str .s
-\ cr
-\ pr-str safe-type cr
-\ new-str s" hello" str-append char ! str-append-char safe-type
-\ s\" he\nllo" MalString. pr-str safe-type cr
-
 read-lines
 cr
 bye
diff --git a/forth/step2_eval.fs b/forth/step2_eval.fs
index 4963111..2b55ce0 100644
--- a/forth/step2_eval.fs
+++ b/forth/step2_eval.fs
@@ -13,23 +13,43 @@ MalMap/Empty
     s" /" MalSymbol. :noname args-as-native / MalInt. ; MalNativeFn. rot assoc
 value repl-env
 
-def-protocol-method mal-eval ( env ast -- val )
-def-protocol-method mal-eval-ast ( env ast -- val )
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
 
-MalDefault extend mal-eval nip ;; drop
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { argv argc kw -- val }
-    argc 1 > if argv cell+ @ else mal-nil endif \ not-found
-    kw \ key
-    argv @ \ map
-    get ;;
+  extend eval-invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
+    ?dup 0= if
+        \ compute not-found value
+        list MalList/count @ 1 > if
+            env  list MalList/start @ 2 cells + @  eval
+        else
+            mal-nil
+        endif
+    endif ;;
 drop
 
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
+    loop
+    target argc ;
+
 MalNativeFn
-  extend invoke ( ... mal-fn -- ... )
-    MalNativeFn/xt @ execute ;;
+  extend eval-invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
 drop
 
 MalSymbol
@@ -44,62 +64,52 @@ MalSymbol
     endif ;;
 drop
 
-MalList
-  extend mal-eval { env list -- val }
-    \ Pass args on dictionary stack (!)
-    \ TODO: consider allocate and free of a real MalList instead
-    here { val-start }
-    list MalList/start @ { expr-start }
-    list MalList/count @ 0 ?do
-        env expr-start i cells + @ mal-eval ,
-    loop
-    val-start cell+  here val-start - cell / 1-  val-start @  ( argv argc MalNativeFn )
-    invoke
-    val-start here - allot ;;
-  extend mal-eval-ast { env list -- list }
+: eval-ast { env list -- list }
     here
     list MalList/start @ { expr-start }
     list MalList/count @ 0 ?do
-        env expr-start i cells + @ mal-eval ,
+        env expr-start i cells + @ eval ,
     loop
-    here>MalList ;;
+    here>MalList ;
+
+MalList
+  extend mal-eval { env list -- val }
+    env list MalList/start @ @ eval
+    env list rot eval-invoke ;;
 drop
 
 MalVector
   extend mal-eval ( env vector -- vector )
-    MalVector/list @ mal-eval-ast
+    MalVector/list @ eval-ast
     MalVector new swap over MalVector/list ! ;;
 drop
 
 MalMap
   extend mal-eval ( env map -- map )
-    MalMap/list @ mal-eval-ast
+    MalMap/list @ eval-ast
     MalMap new swap over MalMap/list ! ;;
 drop
 
-: read read-str ;
-: eval ( env obj ) mal-eval ;
-: print
-    \ ." Type: " dup mal-type @ type-name safe-type cr
-    pr-str ;
-
-: rep ( str -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
 
 create buff 128 allot
+77777777777 constant stack-leak-detect
 
 : read-lines
     begin
       ." user> "
+      stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
       \ execute safe-type
-      catch 0= if safe-type else ." Caught error" endif
+      catch ?dup 0= if safe-type else ." Caught error " . endif
       cr
+      stack-leak-detect <> if ." --stack leak--" cr endif
     repeat ;
 
 read-lines
diff --git a/forth/step3_env.fs b/forth/step3_env.fs
index 7dc9d7e..676bfcc 100644
--- a/forth/step3_env.fs
+++ b/forth/step3_env.fs
@@ -13,44 +13,47 @@ s" -" MalSymbol.  :noname args-as-native - MalInt. ; MalNativeFn.  repl-env env/
 s" *" MalSymbol.  :noname args-as-native * MalInt. ; MalNativeFn.  repl-env env/set
 s" /" MalSymbol.  :noname args-as-native / MalInt. ; MalNativeFn.  repl-env env/set
 
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
 
-MalDefault extend mal-eval nip ;; drop
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
-    0   kw   env list MalList/start @ cell+ @ mal-eval   get
+  extend eval-invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
         list MalList/count @ 1 > if
-            env  list MalList/start @ 2 cells + @  mal-eval
+            env  list MalList/start @ 2 cells + @  eval
         else
             mal-nil
         endif
     endif ;;
 drop
 
-MalNativeFn
-  extend invoke { env list this -- list }
-    \ Pass args on dictionary stack (!)
-    \ TODO: consider allocate and free of a real MalList instead
-    \ Normal list, evaluate and invoke
-    here { val-start }
-    list MalList/start @ { expr-start }
-    list MalList/count @ 1 ?do
-        env expr-start i cells + @ mal-eval ,
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
+    list MalList/start @ cell+ { expr-start }
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
     loop
-    val-start  here val-start - cell /  this  ( argv argc MalNativeFn )
-    MalNativeFn/xt @ execute
-    val-start here - allot ;;
+    target argc ;
+
+MalNativeFn
+  extend eval-invoke ( env list this -- list )
+    MalNativeFn/xt @ { xt }
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -66,24 +69,23 @@ drop
 defspecial quote ( env list -- form )
     nip MalList/start @ cell+ @ ;;
 
-defspecial def! { env list -- }
+defspecial def! { env list -- val }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
-    env arg0 cell+ @ mal-eval dup { val } ( key val )
-    env env/set
-    val ;;
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set val ;;
 
-defspecial let* { old-env list -- }
+defspecial let* { old-env list -- val }
     old-env MalEnv. { env }
     list MalList/start @ cell+ dup { arg0 }
     @ to-list
     dup MalList/start @ { bindings-start } ( list )
     MalList/count @ 0 +do
         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
-        env swap mal-eval
+        env swap eval
         env env/set
     2 +loop
-    env arg0 cell+ @ mal-eval
+    env arg0 cell+ @ eval
     \ TODO: dec refcount of env
     ;;
 
@@ -99,57 +101,52 @@ MalSymbol
     endif ;;
 drop
 
-: mal-eval-ast { env list -- list }
+: eval-ast { env list -- list }
     here
     list MalList/start @ { expr-start }
     list MalList/count @ 0 ?do
-        env expr-start i cells + @ mal-eval ,
+        env expr-start i cells + @ eval ,
     loop
     here>MalList ;
 
 MalList
   extend mal-eval { env list -- val }
-    env list MalList/start @ @ mal-eval
-    env list rot invoke ;;
+    env list MalList/start @ @ eval
+    env list rot eval-invoke ;;
 drop
 
 MalVector
   extend mal-eval ( env vector -- vector )
-    MalVector/list @ mal-eval-ast
+    MalVector/list @ eval-ast
     MalVector new swap over MalVector/list ! ;;
 drop
 
 MalMap
   extend mal-eval ( env map -- map )
-    MalMap/list @ mal-eval-ast
+    MalMap/list @ eval-ast
     MalMap new swap over MalMap/list ! ;;
 drop
 
-: read read-str ;
-: eval ( env obj ) mal-eval ;
-: print
-    \ ." Type: " dup mal-type @ type-name safe-type cr
-    pr-str ;
-
-: rep ( str -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
 
 create buff 128 allot
+77777777777 constant stack-leak-detect
 
 : read-lines
     begin
       ." user> "
-      42042042042
+      stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
-      execute safe-type
-      \ catch 0= if safe-type else ." Caught error" endif
+      \ execute safe-type
+      catch ?dup 0= if safe-type else ." Caught error " . endif
       cr
-      42042042042 <> if ." --stack leak--" cr endif
+      stack-leak-detect <> if ." --stack leak--" cr endif
     repeat ;
 
 read-lines
diff --git a/forth/step4_if_fn_do.fs b/forth/step4_if_fn_do.fs
index 46163bc..4fd277e 100644
--- a/forth/step4_if_fn_do.fs
+++ b/forth/step4_if_fn_do.fs
@@ -4,53 +4,47 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
+: read read-str ;
+: eval ( env obj ) mal-eval ;
+: print
+    \ ." Type: " dup mal-type @ type-name safe-type cr
+    pr-str ;
 
-MalDefault extend mal-eval nip ;; drop
+MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
-    0   kw   env list MalList/start @ cell+ @ mal-eval   get
+  extend eval-invoke { env list kw -- val }
+    0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
         list MalList/count @ 1 > if
-            env  list MalList/start @ 2 cells + @  mal-eval
+            env  list MalList/start @ 2 cells + @  eval
         else
             mal-nil
         endif
     endif ;;
 drop
 
-\ eval all but the first item of list, storing in temporary memory
-\ that should be freed with free-eval-rest when done.
-: eval-rest { env list -- mem-token argv argc }
-    \ Pass args on dictionary stack (!)
-    \ TODO: consider allocate and free of a real MalList instead
-    \ Normal list, evaluate and invoke
-    here { val-start }
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
     list MalList/start @ cell+ { expr-start }
-    list MalList/count @ 1- dup { argc } 0 ?do
-        env expr-start i cells + @ mal-eval ,
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
     loop
-    val-start  val-start  argc ;
-
-: free-eval-rest ( mem-token/val-start -- )
-    here - allot ;
+    target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     MalNativeFn/xt @ { xt }
-    eval-rest ( mem-token argv argc )
-    xt execute ( mem-token return-val )
-    swap free-eval-rest ;;
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -69,9 +63,8 @@ defspecial quote ( env list -- form )
 defspecial def! { env list -- val }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
-    env arg0 cell+ @ mal-eval dup { val } ( key val )
-    env env/set
-    val ;;
+    env arg0 cell+ @ eval dup { val } ( key val )
+    env env/set val ;;
 
 defspecial let* { old-env list -- val }
     old-env MalEnv. { env }
@@ -80,10 +73,10 @@ defspecial let* { old-env list -- val }
     dup MalList/start @ { bindings-start } ( list )
     MalList/count @ 0 +do
         bindings-start i cells + dup @ swap cell+ @ ( sym expr )
-        env swap mal-eval
+        env swap eval
         env env/set
     2 +loop
-    env arg0 cell+ @ mal-eval
+    env arg0 cell+ @ eval
     \ TODO: dec refcount of env
     ;;
 
@@ -92,13 +85,13 @@ defspecial do { env list -- val }
     0
     list MalList/count @ 1 ?do
         drop
-        dup i cells + @ env swap mal-eval
+        dup i cells + @ env swap eval
     loop
     nip ;;
 
 defspecial if { env list -- val }
     list MalList/start @ cell+ { arg0 }
-    env arg0 @ mal-eval ( test-val )
+    env arg0 @ eval ( test-val )
     dup mal-false = if
         drop -1
     else
@@ -107,30 +100,22 @@ defspecial if { env list -- val }
     if
         \ branch to false
         list MalList/count @ 3 > if
-            env arg0 cell+ cell+ @ mal-eval
+            env arg0 cell+ cell+ @ eval
         else
             mal-nil
         endif
     else
         \ branch to true
-        env arg0 cell+ @ mal-eval
+        env arg0 cell+ @ eval
     endif ;;
 
 s" &" MalSymbol. constant &-sym
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
-    call-env list eval-rest { mem-token argv argc }
+  extend eval-invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { argv argc }
 
     mal-fn MalUserFn/formal-args @ { f-args-list }
-    \ \ This isn't correct for fns with & in their f-args-list:
-    \ f-args-list MalList/count @ argc 2dup = if
-    \     2drop
-    \ else
-    \     ." Argument mismatch on user fn. Got " . ." but expected " . cr
-    \     1 throw
-    \ endif
-
     mal-fn MalUserFn/env @ MalEnv. { env }
 
     f-args-list MalList/start @ { f-args }
@@ -154,9 +139,8 @@ MalUserFn
         env env/set
     loop
 
-    env   mal-fn MalUserFn/body @   mal-eval
-
-    mem-token free-eval-rest ;;
+    env   mal-fn MalUserFn/body @   eval ;;
+drop
 
 defspecial fn* { env list -- val }
     list MalList/start @ cell+ { arg0 }
@@ -177,57 +161,52 @@ MalSymbol
     endif ;;
 drop
 
-: mal-eval-ast { env list -- list }
+: eval-ast { env list -- list }
     here
     list MalList/start @ { expr-start }
     list MalList/count @ 0 ?do
-        env expr-start i cells + @ mal-eval ,
+        env expr-start i cells + @ eval ,
     loop
     here>MalList ;
 
 MalList
   extend mal-eval { env list -- val }
-    env list MalList/start @ @ mal-eval
-    env list rot invoke ;;
+    env list MalList/start @ @ eval
+    env list rot eval-invoke ;;
 drop
 
 MalVector
   extend mal-eval ( env vector -- vector )
-    MalVector/list @ mal-eval-ast
+    MalVector/list @ eval-ast
     MalVector new swap over MalVector/list ! ;;
 drop
 
 MalMap
   extend mal-eval ( env map -- map )
-    MalMap/list @ mal-eval-ast
+    MalMap/list @ eval-ast
     MalMap new swap over MalMap/list ! ;;
 drop
 
-: read read-str ;
-: eval ( env obj ) mal-eval ;
-: print
-    \ ." Type: " dup mal-type @ type-name safe-type cr
-    pr-str ;
-
-: rep ( str -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
 
 create buff 128 allot
+77777777777 constant stack-leak-detect
 
 : read-lines
     begin
       ." user> "
-      77777777777
+      stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
-      execute safe-type
-      \ catch 0= if safe-type else ." Caught error" endif
+      \ execute safe-type
+      catch ?dup 0= if safe-type else ." Caught error " . endif
       cr
-      77777777777 <> if ." --stack leak--" cr endif
+      stack-leak-detect <> if ." --stack leak--" cr endif
     repeat ;
 
 read-lines
diff --git a/forth/step5_tco.fs b/forth/step5_tco.fs
index a420719..f7372db 100644
--- a/forth/step5_tco.fs
+++ b/forth/step5_tco.fs
@@ -4,17 +4,12 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
-
 99999999 constant TCO-eval
 
 : read read-str ;
 : eval ( env obj )
     begin
+        \ ." eval-> " dup pr-str safe-type cr
         mal-eval
         dup TCO-eval =
     while
@@ -27,7 +22,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
+  extend eval-invoke { env list kw -- val }
     0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
@@ -39,32 +34,26 @@ MalKeyword
     endif ;;
 drop
 
-\ eval all but the first item of list, storing in temporary memory
-\ that should be freed with free-eval-rest when done.
-: eval-rest { env list -- mem-token argv argc }
-    \ Pass args on dictionary stack (!)
-    \ TODO: consider allocate and free of a real MalList instead
-    \ Normal list, evaluate and invoke
-    here { val-start }
+\ eval all but the first item of list
+: eval-rest { env list -- argv argc }
     list MalList/start @ cell+ { expr-start }
-    list MalList/count @ 1- dup { argc } 0 ?do
-        env expr-start i cells + @ eval ,
+    list MalList/count @ 1- { argc }
+    argc cells allocate throw { target }
+    argc 0 ?do
+        env expr-start i cells + @ eval
+        target i cells + !
     loop
-    val-start  val-start  argc ;
-
-: free-eval-rest ( mem-token/val-start -- )
-    here - allot ;
+    target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     MalNativeFn/xt @ { xt }
-    eval-rest ( mem-token argv argc )
-    xt execute ( mem-token return-val )
-    swap free-eval-rest ;;
+    eval-rest ( argv argc )
+    xt execute ( return-val ) ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -84,8 +73,7 @@ defspecial def! { env list -- val }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
     env arg0 cell+ @ eval dup { val } ( key val )
-    env env/set
-    val ;;
+    env env/set val ;;
 
 defspecial let* { old-env list -- val }
     old-env MalEnv. { env }
@@ -135,8 +123,8 @@ defspecial if { env list -- val }
 s" &" MalSymbol. constant &-sym
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
-    call-env list eval-rest { mem-token argv argc }
+  extend eval-invoke { call-env list mal-fn -- list }
+    call-env list eval-rest { argv argc }
 
     mal-fn MalUserFn/formal-args @ { f-args-list }
     mal-fn MalUserFn/env @ MalEnv. { env }
@@ -162,9 +150,8 @@ MalUserFn
         env env/set
     loop
 
-    env   mal-fn MalUserFn/body @   TCO-eval
-
-    mem-token free-eval-rest ;;
+    env   mal-fn MalUserFn/body @   TCO-eval ;;
+drop
 
 defspecial fn* { env list -- val }
     list MalList/start @ cell+ { arg0 }
@@ -196,7 +183,7 @@ drop
 MalList
   extend mal-eval { env list -- val }
     env list MalList/start @ @ eval
-    env list rot invoke ;;
+    env list rot eval-invoke ;;
 drop
 
 MalVector
@@ -211,7 +198,7 @@ MalMap
     MalMap new swap over MalMap/list ! ;;
 drop
 
-: rep ( str -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
@@ -224,8 +211,8 @@ create buff 128 allot
       ." user> "
       stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
       \ execute safe-type
       catch ?dup 0= if safe-type else ." Caught error " . endif
diff --git a/forth/step6_file.fs b/forth/step6_file.fs
index d675f6e..b3945ad 100644
--- a/forth/step6_file.fs
+++ b/forth/step6_file.fs
@@ -4,12 +4,6 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
-
 99999999 constant TCO-eval
 
 : read read-str ;
@@ -28,7 +22,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
+  extend eval-invoke { env list kw -- val }
     0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
@@ -52,14 +46,14 @@ drop
     target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     MalNativeFn/xt @ { xt }
     eval-rest ( argv argc )
     xt execute ( return-val ) ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -79,8 +73,7 @@ defspecial def! { env list -- val }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
     env arg0 cell+ @ eval dup { val } ( key val )
-    env env/set
-    val ;;
+    env env/set val ;;
 
 defspecial let* { old-env list -- val }
     old-env MalEnv. { env }
@@ -130,7 +123,7 @@ defspecial if { env list -- val }
 s" &" MalSymbol. constant &-sym
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
+  extend eval-invoke { call-env list mal-fn -- list }
     call-env list eval-rest { argv argc }
 
     mal-fn MalUserFn/formal-args @ { f-args-list }
@@ -190,7 +183,7 @@ drop
 MalList
   extend mal-eval { env list -- val }
     env list MalList/start @ @ eval
-    env list rot invoke ;;
+    env list rot eval-invoke ;;
 drop
 
 MalVector
@@ -208,7 +201,7 @@ drop
 defcore eval ( argv argc )
   drop @ repl-env swap eval ;;
 
-: rep ( str-addr str-len -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
@@ -221,21 +214,21 @@ defcore eval ( argv argc )
     repeat
     2drop here>MalList ;
 
-s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
-
 create buff 128 allot
 77777777777 constant stack-leak-detect
 
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+
 : repl ( -- )
     begin
       ." user> "
       stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
-      execute type
-      \ catch ?dup 0= if safe-type else ." Caught error " . endif
+      \ execute type
+      catch ?dup 0= if safe-type else ." Caught error " . endif
       cr
       stack-leak-detect <> if ." --stack leak--" cr endif
     repeat ;
diff --git a/forth/step7_quote.fs b/forth/step7_quote.fs
index 46c2fb2..0c6b909 100644
--- a/forth/step7_quote.fs
+++ b/forth/step7_quote.fs
@@ -4,12 +4,6 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
-
 99999999 constant TCO-eval
 
 : read read-str ;
@@ -28,7 +22,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
+  extend eval-invoke { env list kw -- val }
     0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
@@ -52,14 +46,14 @@ drop
     target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     MalNativeFn/xt @ { xt }
     eval-rest ( argv argc )
     xt execute ( return-val ) ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -121,8 +115,7 @@ defspecial def! { env list -- val }
     list MalList/start @ cell+ { arg0 }
     arg0 @ ( key )
     env arg0 cell+ @ eval dup { val } ( key val )
-    env env/set
-    val ;;
+    env env/set val ;;
 
 defspecial let* { old-env list -- val }
     old-env MalEnv. { env }
@@ -172,7 +165,7 @@ defspecial if { env list -- val }
 s" &" MalSymbol. constant &-sym
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
+  extend eval-invoke { call-env list mal-fn -- list }
     call-env list eval-rest { argv argc }
 
     mal-fn MalUserFn/formal-args @ { f-args-list }
@@ -232,7 +225,7 @@ drop
 MalList
   extend mal-eval { env list -- val }
     env list MalList/start @ @ eval
-    env list rot invoke ;;
+    env list rot eval-invoke ;;
 drop
 
 MalVector
@@ -250,7 +243,7 @@ drop
 defcore eval ( argv argc )
   drop @ repl-env swap eval ;;
 
-: rep ( str-addr str-len -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
@@ -263,21 +256,21 @@ defcore eval ( argv argc )
     repeat
     2drop here>MalList ;
 
-s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
-
 create buff 128 allot
 77777777777 constant stack-leak-detect
 
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+
 : repl ( -- )
     begin
       ." user> "
       stack-leak-detect
       buff 128 stdin read-line throw
-    while
-      buff swap
+    while ( num-bytes-read )
+      buff swap ( str-addr str-len )
       ['] rep
-      execute type
-      \ catch ?dup 0= if safe-type else ." Caught error " . endif
+      \ execute type
+      catch ?dup 0= if safe-type else ." Caught error " . endif
       cr
       stack-leak-detect <> if ." --stack leak--" cr endif
     repeat ;
diff --git a/forth/step8_macros.fs b/forth/step8_macros.fs
index c0a66c8..f01f3a9 100644
--- a/forth/step8_macros.fs
+++ b/forth/step8_macros.fs
@@ -4,12 +4,6 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-def-protocol-method invoke ( argv argc mal-fn -- ... )
-
 99999999 constant TCO-eval
 
 : read read-str ;
@@ -28,7 +22,7 @@ def-protocol-method invoke ( argv argc mal-fn -- ... )
 MalDefault extend mal-eval nip ;; drop \ By default, evalutate to yourself
 
 MalKeyword
-  extend invoke { env list kw -- val }
+  extend eval-invoke { env list kw -- val }
     0   kw   env list MalList/start @ cell+ @ eval   get
     ?dup 0= if
         \ compute not-found value
@@ -52,14 +46,14 @@ drop
     target argc ;
 
 MalNativeFn
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     MalNativeFn/xt @ { xt }
     eval-rest ( argv argc )
     xt execute ( return-val ) ;;
 drop
 
 SpecialOp
-  extend invoke ( env list this -- list )
+  extend eval-invoke ( env list this -- list )
     SpecialOp/xt @ execute ;;
 drop
 
@@ -205,7 +199,7 @@ s" &" MalSymbol. constant &-sym
     env ;
 
 MalUserFn
-  extend invoke { call-env list mal-fn -- list }
+  extend eval-invoke { call-env list mal-fn -- list }
     mal-fn MalUserFn/is-macro? @ if
         list MalList/start @ cell+  list MalList/count @ 1-
     else
@@ -259,7 +253,7 @@ drop
 MalList
   extend mal-eval { env list -- val }
     env list MalList/start @ @ eval
-    env list rot invoke ;;
+    env list rot eval-invoke ;;
 drop
 
 MalVector
@@ -277,7 +271,7 @@ drop
 defcore eval ( argv argc )
   drop @ repl-env swap eval ;;
 
-: rep ( str-addr str-len -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
@@ -290,13 +284,13 @@ defcore eval ( argv argc )
     repeat
     2drop here>MalList ;
 
-s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
-s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
-s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
-
 create buff 128 allot
 77777777777 constant stack-leak-detect
 
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop
+
 : repl ( -- )
     begin
       ." user> "
diff --git a/forth/step9_try.fs b/forth/step9_try.fs
index e7293db..e11c691 100644
--- a/forth/step9_try.fs
+++ b/forth/step9_try.fs
@@ -4,15 +4,6 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-\ def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-\ def-protocol-method eval-invoke ( env list obj -- ... )
-
-\ Invoke a function, given parameter values
-\ def-protocol-method invoke ( argv argc mal-fn -- ... )
-
 99999999 constant TCO-eval
 
 : read read-str ;
@@ -219,21 +210,19 @@ s" &" MalSymbol. constant &-sym
 MalUserFn
   extend eval-invoke { call-env list mal-fn -- list }
     mal-fn MalUserFn/is-macro? @ if
-        list MalList/start @ cell+  list MalList/count @ 1-
+        list MalList/start @ cell+  \ argv
+        list MalList/count @ 1-     \ argc
+        mal-fn new-user-fn-env { env }
+        env   mal-fn MalUserFn/body @   eval
+        call-env swap TCO-eval
     else
         call-env list eval-rest
-    endif
-    mal-fn invoke ;;
+        mal-fn invoke
+    endif ;;
 
   extend invoke ( argv argc mal-fn )
     dup { mal-fn } new-user-fn-env { env }
-
-    mal-fn MalUserFn/is-macro? @ if
-        env   mal-fn MalUserFn/body @   eval
-        env swap TCO-eval
-    else
-        env   mal-fn MalUserFn/body @   TCO-eval
-    endif ;;
+    env   mal-fn MalUserFn/body @   TCO-eval ;;
 drop
 
 defspecial fn* { env list -- val }
@@ -310,7 +299,7 @@ drop
 defcore eval ( argv argc )
   drop @ repl-env swap eval ;;
 
-: rep ( str-addr str-len -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
@@ -339,14 +328,14 @@ defcore map ( argv argc -- list )
     here>MalList ;;
 
 defcore readline ( argv argc -- mal-string )
-    drop @ unpack-str type
+    drop @ unpack-str type stdout flush-file drop
     buff 128 stdin read-line throw
-    if buff swap MalString. else mal-nil endif ;;
+    if buff swap MalString. else drop mal-nil endif ;;
 
-s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
-s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
-s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
-s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep 2drop
 
 : repl ( -- )
     begin
@@ -356,7 +345,7 @@ s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
     while ( num-bytes-read )
       buff swap ( str-addr str-len )
       ['] rep
-      execute ['] nop \ uncomment to see stack traces
+      \ execute ['] nop \ uncomment to see stack traces
       catch ?dup 0= if
           safe-type cr
           stack-leak-detect <> if ." --stack leak--" cr endif
@@ -388,5 +377,3 @@ s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
 main
 cr
 bye
-
-4
\ No newline at end of file
diff --git a/forth/stepA_interop.fs b/forth/stepA_interop.fs
index d25d094..0a4050a 100644
--- a/forth/stepA_interop.fs
+++ b/forth/stepA_interop.fs
@@ -4,15 +4,6 @@ require core.fs
 
 core MalEnv. constant repl-env
 
-\ Fully evalutate any Mal object:
-\ def-protocol-method mal-eval ( env ast -- val )
-
-\ Invoke an object, given whole env and unevaluated argument forms:
-\ def-protocol-method eval-invoke ( env list obj -- ... )
-
-\ Invoke a function, given parameter values
-\ def-protocol-method invoke ( argv argc mal-fn -- ... )
-
 99999999 constant TCO-eval
 
 : read read-str ;
@@ -308,7 +299,7 @@ drop
 defcore eval ( argv argc )
   drop @ repl-env swap eval ;;
 
-: rep ( str-addr str-len -- val )
+: rep ( str-addr str-len -- str-addr str-len )
     read
     repl-env swap eval
     print ;
@@ -341,14 +332,14 @@ defcore readline ( argv argc -- mal-string )
     buff 128 stdin read-line throw
     if buff swap MalString. else drop mal-nil endif ;;
 
-s\" (def! *host-language* \"forth\")" rep drop
-s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep drop
-s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep drop
-s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep drop
-s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
+s\" (def! *host-language* \"forth\")" rep 2drop
+s\" (def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" rep 2drop
+s\" (defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" rep 2drop
+s\" (defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" rep 2drop
+s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep 2drop
 
 : repl ( -- )
-    s\" (println (str \"Mal [\" *host-language* \"]\"))" rep drop
+    s\" (println (str \"Mal [\" *host-language* \"]\"))" rep 2drop
     begin
       ." user> "
       stack-leak-detect
@@ -366,7 +357,7 @@ s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
               s" forth-errno" MalKeyword. errno MalInt. MalMap/Empty assoc
               to exception-object
           endif
-          ." Uncaught mal or forth exception: "
+          ." Uncaught exception: "
           exception-object pr-str safe-type cr
       endif
     repeat ;
@@ -388,5 +379,3 @@ s\" (def! swap! (fn* [a f & args] (reset! a (apply f @a args))))" rep drop
 main
 cr
 bye
-
-4
\ No newline at end of file
diff --git a/forth/types.fs b/forth/types.fs
index b936603..791f327 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -241,8 +241,6 @@ def-protocol-method eval-invoke ( env list obj -- ... )
 def-protocol-method invoke ( argv argc mal-fn -- ... )
 
 
-
-
 : m= ( a b -- bool )
     2dup = if
         2drop true
-- 
cgit v1.2.3


From b254151c2a32203fe1920b4dd1db614ed2b0691b Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 20 Feb 2015 02:52:51 -0500
Subject: forth: Fix bug in extend-protocol array insertion

---
 forth/misc-tests.fs |  1 +
 forth/types.fs      | 11 ++++++++---
 2 files changed, 9 insertions(+), 3 deletions(-)

(limited to 'forth')

diff --git a/forth/misc-tests.fs b/forth/misc-tests.fs
index 2526067..35e665b 100644
--- a/forth/misc-tests.fs
+++ b/forth/misc-tests.fs
@@ -20,6 +20,7 @@ create za 2 , 6 , 7 , 10 , 15 , 80 , 81 ,
 7 za 8  array-find   0 test= 3 test=
 7 za 100 array-find  0 test= 7 test=
 7 za 1 array-find    0 test= 0 test=
+6 za 81 array-find   0 test= 6 test=
 
 10 new-array
 1 swap 0  5 array-insert
diff --git a/forth/types.fs b/forth/types.fs
index 791f327..5028bf3 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -30,8 +30,11 @@ require str.fs
       endif
     endif
   2dup = until
-  cells a-addr + @ key =
-  ;
+  dup a-length = if
+      drop false
+  else
+      cells a-addr + @ key =
+  endif ;
 
 \ Create a new array, one cell in length, initialized the provided value
 : new-array { value -- array }
@@ -170,7 +173,9 @@ MalType% deftype MalFalse MalFalse new constant mal-false
   else
     pxt array-find { idx found? }
     found? if \ overwrite
-      ." Warning: overwriting protocol method implementation"
+      ." Warning: overwriting protocol method implementation '"
+        pxt >name name>string safe-type ." ' on " type type-name safe-type ." , " idx . found? . cr
+
       type MalTypeType-method-vals @ idx cells + ixt !
     else \ resize
       type MalTypeType-methods dup @ 1+ dup rot ! ( new-count )
-- 
cgit v1.2.3


From b6607ac70f99ec0e465e3de1d9b397fea9b562ef Mon Sep 17 00:00:00 2001
From: Chouser <chouser@n01se.net>
Date: Fri, 20 Feb 2015 02:54:17 -0500
Subject: forth: Fix bug in (get nil ...)

---
 forth/types.fs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'forth')

diff --git a/forth/types.fs b/forth/types.fs
index 5028bf3..2c4c8e0 100644
--- a/forth/types.fs
+++ b/forth/types.fs
@@ -448,7 +448,7 @@ MalNil
   extend conj ( item nil -- mal-list )
     drop MalList/Empty conj ;;
   extend as-native drop 0 ;;
-  extend get drop 2drop mal-nil ;;
+  extend get 2drop ;;
   extend to-list drop MalList/Empty ;;
   extend empty? drop mal-true ;;
   extend mal-count drop 0 MalInt. ;;
-- 
cgit v1.2.3