make-type symbol-type
make-type primitive-proc-type
make-type compound-proc-type
-make-type fileport-type
+make-type port-type
: istype? ( obj type -- obj bool )
over = ;
drop ;
: fid>fileport ( fid -- fileport )
- fileport-type ;
+ port-type ;
: open-input-file ( addr n -- fileport )
r/o open-file drop fid>fileport
;
objvar console-i/o-port
-0 fileport-type console-i/o-port obj!
+0 port-type console-i/o-port obj!
objvar current-input-port
console-i/o-port obj@ current-input-port obj!
create-symbol λ λ-symbol
create-symbol begin begin-symbol
+\ Symbol to be bound to welcome message procedure by library
+create-symbol welcome welcome-symbol
+
\ }}}
\ ---- Environments ---- {{{
;
: readstring ( -- charlist )
- nextchar [char] " = if
- inc-parse-idx
- delim? false = if
- bold fg red
- ." No delimiter following right double quote. Aborting." cr
- reset-term abort
+ nil nil
+
+ begin
+ nextchar [char] " <>
+ while
+ nextchar [char] \ = if
+ inc-parse-idx
+ nextchar case
+ [char] n of '\n' endof
+ [char] " of [char] " endof
+ [char] \
+ endcase
+ else
+ nextchar
then
+ inc-parse-idx character-type
+ nil cons
- dec-parse-idx
+ ( firstchar prevchar thischar )
- 0 nil-type exit
- then
+ 2swap nil? if
+ 2drop 2swap 2drop 2dup ( thischar thischar )
+ else
+ ( firstchar thischar prevchar )
+ 2over 2swap set-cdr! ( firstchar thischar )
+ then
+ repeat
- nextchar [char] \ = if
- inc-parse-idx
- nextchar case
- [char] n of '\n' endof
- [char] " of [char] " endof
- [char] \
- endcase
- else
- nextchar
+ \ Discard previous character
+ 2drop
+
+ inc-parse-idx
+ delim? false = if
+ bold fg red
+ ." No delimiter following right double quote. Aborting." cr
+ reset-term abort
then
- inc-parse-idx character-type
- recurse
+ dec-parse-idx
- cons
+ nil? if
+ nil cons
+ then
+ drop string-type
;
: readsymbol ( -- charlist )
inc-parse-idx
readstring
- drop string-type
nextchar [char] " <> if
bold red ." Missing closing double-quote." reset-term cr
primitive-proc-type istype? if printprim exit then
compound-proc-type istype? if printcomp exit then
none-type istype? if printnone exit then
+ port-type istype? if printport exit then
recoverable-exception throw" Tried to print object with unknown type."
; is print
\ ---- Loading files ---- {{{
-: charlist>cstr ( charlist addr -- n )
-
- dup 2swap ( origaddr addr charlist )
-
- begin
- nil? false =
- while
- 2dup cdr 2swap car
- drop ( origaddr addr charlist char )
- -rot 2swap ( origaddr charlist addr char )
- over !
- 1+ -rot ( origaddr nextaddr charlist )
- repeat
-
- 2drop ( origaddr finaladdr )
- swap -
-;
-
: load ( addr n -- finalResult )
open-input-file
;
: repl
- cr ." Welcome to scheme.forth.jl!" cr
- ." Use Ctrl-D to exit." cr
empty-parse-str
enable-gc
+ \ Display welcome message
+ welcome-symbol nil cons global-env obj@ eval 2drop
+
begin
['] repl-body catch
case