1 nextexception +!
does> @ ;
-make-exception recoverable-exception
-make-exception unrecoverable-exception
-
-: display-exception-msg ( addr count -- )
+: except-message:
bold fg red
." Exception: "
- type
- reset-term ;
-
-: throw" immediate
- [compile] s"
+;
- ['] rot , ['] dup ,
+make-exception recoverable-exception
+make-exception unrecoverable-exception
- [compile] if
- ['] -rot ,
- ['] display-exception-msg ,
- [compile] then
-
- ['] throw ,
-;
+: throw reset-term throw ;
\ }}}
\ ---- List-structured memory ---- {{{
-10000 constant scheme-memsize
+20000 constant scheme-memsize
create car-cells scheme-memsize allot
create car-type-cells scheme-memsize allot
then
nextfree @ scheme-memsize >= if
- unrecoverable-exception throw s" Out of memory!"
+ except-message: ." Out of memory!" unrecoverable-exception throw
then
;
hide vars
hide vals
+objvar var
+
: lookup-var ( var env -- val )
+ 2over var obj!
get-vars-vals if
2swap 2drop car
else
- recoverable-exception throw" Tried to read unbound variable."
+ except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception throw
then
;
: set-var ( var val env -- )
>R >R 2swap R> R> ( val var env )
+ 2over var obj!
get-vars-vals if
2swap 2drop ( val vals )
set-car!
else
- recoverable-exception throw" Tried to set unbound variable."
+ except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw
then
;
+hide var
+
objvar env
: define-var ( var val env -- )
: ensure-arg-count ( args n -- )
dup 0= if
drop nil objeq? false = if
- recoverable-exception throw" Too many arguments for primitive procedure."
+ except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
then
else
-rot nil? if
- recoverable-exception throw" Too few arguments for primitive procedure."
+ except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
then
cdr rot 1- recurse
: ensure-arg-type-and-count ( tn tn-1 ... t2 t1 args n -- )
dup 0= if
drop nil objeq? false = if
- recoverable-exception throw" Too many arguments for primitive procedure."
+ except-message: ." Too many arguments for primitive procedure." recoverable-exception throw
then
else
-rot nil? if
- recoverable-exception throw" Too few arguments for primitive procedure."
+ except-message: ." Too few arguments for primitive procedure." recoverable-exception throw
then
2dup cdr 2swap car ( ... t1 n args' arg1 )
2rot 1- swap 2swap rot ( ... args' n-1 arg1 t1 )
istype? false = if
- recoverable-exception throw" Incorrect type for primitive procedure."
+ except-message: ." Incorrect type for primitive procedure." recoverable-exception throw
then
2drop recurse
: ensure-arg-type ( arg type -- arg )
istype? false = if
- recoverable-exception throw" Incorrect argument type for primitive procedure."
+ except-message: ." Incorrect argument type for primitive procedure." recoverable-exception throw
then
;
( Look up macro in macro table. Returns nil if
no macro is found. )
: lookup-macro ( name_symbol -- proc )
+
+ symbol-type istype? invert if
+ \ Early exit if argument is not a symbol
+ 2drop nil exit
+ then
+
macro-table obj@
begin
cdr ( env args )
nil? if
- recoverable-exception throw" no arguments to unquote."
+ except-message: ." no arguments to unquote." recoverable-exception throw
then
2dup cdr
nil? false = if
- recoverable-exception throw" too many arguments to unquote."
+ except-message: ." too many arguments to unquote." recoverable-exception throw
then
2drop car 2swap eval
2swap cdr ( env args )
nil? if
- recoverable-exception throw" no arguments to quasiquote."
+ except-message: ." no arguments to quasiquote." recoverable-exception throw
then
2dup cdr ( env args args-cdr )
nil? false = if
- recoverable-exception throw" too many arguments to quasiquote."
+ except-message: ." too many arguments to quasiquote." recoverable-exception throw
then
2drop car ( env arg )
: flatten-proc-args ( argvals argnames -- argvals' argnames' )
nil? if
2over nil? false = if
- recoverable-exception throw" Too many arguments for compound procedure."
+ except-message: ." Too many arguments for compound procedure." recoverable-exception throw
else
2drop
then
2over
nil? if
- recoverable-exception throw" Too few arguments for compound procedure."
+ except-message: ." Too few arguments for compound procedure." recoverable-exception throw
else
cdr
then
R> drop ['] eval goto-deferred \ Tail call optimization
endof
- recoverable-exception throw" Object not applicable."
+ except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw
endcase
;
-( Simply evaluates the given procedure with expbody as its argument. )
-: macro-expand ( proc expbody -- result )
- 2swap
- 2dup procedure-body ( expbody proc procbody )
- -2rot 2dup procedure-params ( procbody expbody proc argnames )
- -2rot procedure-env ( procbody argnames expbody procenv )
-
- -2rot 2swap
- flatten-proc-args
- 2swap 2rot
-
- extend-env eval-sequence eval
-;
-
:noname ( obj env -- result )
2swap
+ \ --- DEBUG ---
+ (
+ fg yellow ." Evaluating: " bold 2dup print reset-term
+ space fg green ." PS: " bold depth . reset-term
+ space fg blue ." RS: " bold RSP@ RSP0 - . reset-term cr
+ )
+
self-evaluating? if
2swap 2drop
exit
2over 2over ( env exp env exp )
operator ( env exp env opname )
- 2dup lookup-macro nil? false = if
- \ Macro function evaluation
+ 2swap eval ( env exp proc )
+
+ -2rot ( proc env exp )
+ operands 2swap ( proc operands env )
+ list-of-vals ( proc argvals )
+
+ apply
+ exit
+ then
+
+ except-message: ." tried to evaluate object with unknown type." recoverable-exception throw
+; is eval
- ( env exp env opname mproc )
- 2swap 2drop -2rot 2drop cdr ( env mproc body )
+\ }}}
- macro-expand
+\ ---- Macro Expansion ---- {{{
- 2swap
- ['] eval goto-deferred
- else
- \ Regular function application
+( Simply evaluates the given procedure with expbody as its argument. )
+: macro-eval ( proc expbody -- result )
+ 2swap
+ 2dup procedure-body ( expbody proc procbody )
+ -2rot 2dup procedure-params ( procbody expbody proc argnames )
+ -2rot procedure-env ( procbody argnames expbody procenv )
+
+ -2rot 2swap
+ flatten-proc-args
+ 2swap 2rot
- 2drop ( env exp env opname )
+ extend-env eval-sequence eval
+;
- 2swap eval ( env exp proc )
+:noname ( exp -- result )
- -2rot ( proc env exp )
- operands 2swap ( proc operands env )
- list-of-vals ( proc argvals )
+ quasiquote? if expand-quasiquote exit then
- apply
- exit
- then
- then
+ definition? if expand-definition exit then
- recoverable-exception throw" Tried to evaluate object with unknown type."
-; is eval
+ assignment? if expand-assignment exit then
+
+ macro-definition? if expand-define-macro exit then
+
+ if? if expand-if exit then
+
+ lambda? if expand-lambda exit then
+
+ begin? if expand-sequence exit then
+
+ application? if expand-apply exit then
+
+; is expand
\ }}}
none-type istype? if printnone exit then
port-type istype? if printport exit then
- recoverable-exception throw" Tried to print object with unknown type."
+ except-message: ." tried to print object with unknown type." recoverable-exception throw
; is print
\ }}}
2swap 2drop ( port obj )
+ expand
+
global-env obj@ eval ( port res )
again
;
include scheme-primitives.4th
- s" scheme-library.scm" load 2drop
+\ s" scheme-library.scm" load 2drop
\ }}}
true exit
then
+ expand
+
global-env obj@ eval
fg cyan ." ; " print reset-term
;
: repl
-
empty-parse-str
enable-gc
\ Display welcome message
- welcome-symbol nil cons global-env obj@ eval 2drop
+ \ welcome-symbol nil cons global-env obj@ eval 2drop
begin
['] repl-body catch
The Lambda Lab / projects / scheme.forth.jl.git / blobdiff