diff options
Diffstat (limited to 'forth')
| -rw-r--r-- | forth/misc-tests.fs | 28 | ||||
| -rw-r--r-- | forth/printer.fs | 72 | ||||
| -rw-r--r-- | forth/reader.fs | 30 | ||||
| -rw-r--r-- | forth/step2_eval.fs | 106 | ||||
| -rw-r--r-- | forth/types.fs | 183 |
5 files changed, 387 insertions, 32 deletions
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 |