X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?a=blobdiff_plain;f=src%2Fscheme.4th;h=93d249650e2fdefa3cc98f31d9fa5a413963e12e;hb=f71c5f93aefa930fd0ac175416523bc6a101e3df;hp=d6dccd1c7d91aaf44c81693b7e4cb9005d519a76;hpb=3f60507c407dc22a19b4539d08cc926c54141653;p=scheme.forth.jl.git diff --git a/src/scheme.4th b/src/scheme.4th index d6dccd1..93d2496 100644 --- a/src/scheme.4th +++ b/src/scheme.4th @@ -39,6 +39,7 @@ make-type pair-type make-type symbol-type make-type primitive-proc-type make-type compound-proc-type +make-type continuation-type make-type port-type : istype? ( obj type -- obj bool ) over = ; @@ -62,7 +63,7 @@ variable nextexception make-exception recoverable-exception make-exception unrecoverable-exception -: throw reset-term throw ; +: throw reset-term cr throw ; \ }}} @@ -90,7 +91,7 @@ variable nextfree nextfree ! nextfree @ scheme-memsize >= if - collect-garbage + collect-garbage then nextfree @ scheme-memsize >= if @@ -132,6 +133,10 @@ variable nextfree cdr-cells + ! ; +variable object-stack-base +: init-object-stack-base + depth object-stack-base ! ; + : nil 0 nil-type ; : nil? nil-type istype? ; @@ -402,6 +407,9 @@ variable read-line-buffer-offset : make-frame ( vars vals -- frame ) cons ; +: add-frame-to-env ( frame env -- env ) + cons ; + : frame-vars ( frame -- vars ) car ; @@ -416,99 +424,90 @@ variable read-line-buffer-offset ; : extend-env ( vars vals env -- env ) - >R >R - make-frame - R> R> - cons + -2rot make-frame + 2swap add-frame-to-env ; -objvar vars -objvar vals - -: get-vars-vals-frame ( var frame -- bool ) - 2dup frame-vars vars obj! - frame-vals vals obj! +: get-vals-frame ( var frame -- vals | nil ) + 2dup frame-vars + 2swap frame-vals ( var vars vals ) begin - vars obj@ nil objeq? false = + nil? false = while - 2dup vars obj@ car objeq? if - 2drop true + + -2rot ( vals var vars ) + 2over 2over car objeq? if + 2drop 2drop exit then - vars obj@ cdr vars obj! - vals obj@ cdr vals obj! + cdr 2rot cdr repeat - 2drop false + 2drop 2drop 2drop + nil ; -: get-vars-vals ( var env -- vars? vals? bool ) +: get-vals ( var env -- vals | nil ) begin nil? false = while 2over 2over first-frame - get-vars-vals-frame if - 2drop 2drop - vars obj@ vals obj@ true + get-vals-frame nil? false = if + 2swap 2drop 2swap 2drop exit then + 2drop + enclosing-env repeat - 2drop 2drop - false + 2swap 2drop ; -hide vars -hide vals - -objvar var - +objvar var \ Used only for error messages : lookup-var ( var env -- val ) 2over var obj! - get-vars-vals if - 2swap 2drop car - else - except-message: ." tried to read unbound variable '" var obj@ print ." '." recoverable-exception throw + + get-vals nil? if + except-message: ." tried to read unbound variable '" var obj@ print ." '." + recoverable-exception throw then + + car ; : 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! + 2rot 2dup var obj! ( val env var ) + 2swap ( val var env ) + get-vals nil? if + except-message: ." tried to set unbound variable '" var obj@ print ." '." + recoverable-exception throw else - except-message: ." tried to set unbound variable '" var obj@ print ." '." recoverable-exception throw + ( val vals ) + set-car! then ; - hide var -objvar env - : define-var ( var val env -- ) - env obj! + first-frame ( var val frame ) + 2rot 2swap 2over 2over ( val var frame var frame ) - 2over env obj@ ( var val var env ) - get-vars-vals if - 2swap 2drop ( var val vals ) - set-car! + get-vals-frame nil? if 2drop - else - env obj@ - first-frame ( var val frame ) + -2rot 2swap 2rot add-binding + else + ( val var frame vals ) + 2swap 2drop 2swap 2drop + set-car! then ; -hide env - : make-procedure ( params body env -- proc ) nil cons cons cons @@ -521,6 +520,62 @@ global-env obj! \ }}} +\ ---- Continuations ---- {{{ + +: cons-return-stack ( -- listobj ) + rsp@ 1- rsp0 = if + nil exit + then + + nil rsp@ 1- rsp0 do + i 1+ @ fixnum-type 2swap cons + loop +; + +: cons-param-stack ( -- listobj ) + nil + + depth 2- object-stack-base @ = if + exit + then + + depth 2- object-stack-base @ do + PSP0 i + 1 + @ + PSP0 i + 2 + @ + + 2swap cons + 2 +loop +; + +: make-continuation + + cons-param-stack + cons-return-stack + cons drop continuation-type +; + +: continuation->pstack-list + drop pair-type car ; + +: continuation->rstack-list + drop pair-type cdr ; + +: restore-param-stack ( continuation -- obj_stack continuation ) + + 2dup >R >R + continuation->pstack-list + + ( Idea: allocate stack space first using psp!, + then copy objects from list. ) +; + +: restore-continuation + \ TODO: replace current parameter and return stacks with + \ contents of continuation object. +; + +\ }}} + \ ---- Primitives ---- {{{ : make-primitive ( cfa -- ) @@ -1661,6 +1716,10 @@ parse-idx-stack parse-idx-sp ! ['] evaluate-eproc goto endof + continuation-type of + \ TODO: Apply continuation + endof + except-message: ." object '" drop print ." ' not applicable." recoverable-exception throw endcase ; @@ -1909,6 +1968,9 @@ parse-idx-stack parse-idx-sp ! : printcomp ( primobj -- ) 2drop ." " ; +: printcont ( primobj --) + 2drop ." " ; + : printnone ( noneobj -- ) 2drop ." Unspecified return value" ; @@ -1927,6 +1989,7 @@ parse-idx-stack parse-idx-sp ! pair-type istype? if ." (" printpair ." )" exit then primitive-proc-type istype? if printprim exit then compound-proc-type istype? if printcomp exit then + continuation-type istype? if printcont exit then none-type istype? if printnone exit then port-type istype? if printport exit then @@ -1937,20 +2000,20 @@ parse-idx-stack parse-idx-sp ! \ ---- Garbage Collection ---- {{{ -variable gc-enabled -false gc-enabled ! - -variable gc-stack-depth +( Notes on garbage collection: + This is a mark-sweep garbage collector, invoked by cons. + The roots of the object tree used by the marking routine + include all objects in the parameter stack, and several + other fixed roots such as global-env, symbol-table, macro-table, + and the console-i/o-port. -: enable-gc - depth gc-stack-depth ! - true gc-enabled ! ; + NO OTHER OBJECTS WILL BE MARKED! -: disable-gc - false gc-enabled ! ; + This places implicit restrictions on when cons can be invoked. + Invoking cons when live objects are stored on the return stack + or in other variables than the above will result in possible + memory corruption if the cons triggers the GC. ) -: gc-enabled? - gc-enabled @ ; : pairlike? ( obj -- obj bool ) pair-type istype? if true exit then @@ -2018,9 +2081,7 @@ variable gc-stack-depth ; :noname - ." GC! " - - trace + \ ." GC! " gc-unmark @@ -2029,7 +2090,7 @@ variable gc-stack-depth console-i/o-port obj@ gc-mark-obj global-env obj@ gc-mark-obj - depth gc-stack-depth @ do + depth object-stack-base @ do PSP0 i + 1 + @ PSP0 i + 2 + @ @@ -2038,7 +2099,7 @@ variable gc-stack-depth gc-sweep - ." (" gc-count-marked . ." pairs marked as used.)" cr + \ ." (" gc-count-marked . ." pairs marked as used.)" cr ; is collect-garbage \ }}} @@ -2054,12 +2115,12 @@ variable gc-stack-depth begin \ DEBUG - bold fg blue ." READ from " 2over drop . ." ==> " reset-term + \ bold fg blue ." READ from " 2over drop . ." ==> " reset-term 2over read-port ( port res obj ) \ DEBUG - 2dup print cr + \ 2dup print cr 2dup EOF character-type objeq? if 2drop 2swap close-port @@ -2078,6 +2139,7 @@ variable gc-stack-depth include scheme-primitives.4th + init-object-stack-base s" scheme-library.scm" load 2drop \ }}} @@ -2106,10 +2168,10 @@ variable gc-stack-depth : repl empty-parse-str - enable-gc + init-object-stack-base \ 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