diff options
| -rw-r--r-- | forth/core.fs | 3 | ||||
| -rw-r--r-- | forth/printer.fs | 41 | ||||
| -rw-r--r-- | forth/reader.fs | 119 | ||||
| -rw-r--r-- | forth/step6_file.fs | 259 | ||||
| -rw-r--r-- | forth/types.fs | 6 |
5 files changed, 329 insertions, 99 deletions
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 |