From: Tim Vaughan Date: Tue, 31 Oct 2017 20:44:39 +0000 (+0100) Subject: Merge branch 'master' into call-cc X-Git-Url: https://thelambdalab.xyz/gitweb/index.cgi?p=scheme.forth.jl.git;a=commitdiff_plain;h=f71c5f93aefa930fd0ac175416523bc6a101e3df;hp=-c Merge branch 'master' into call-cc --- f71c5f93aefa930fd0ac175416523bc6a101e3df diff --combined src/scheme.4th index e94796c,2a509e6..93d2496 --- a/src/scheme.4th +++ b/src/scheme.4th @@@ -39,7 -39,6 +39,7 @@@ make-type pair-typ 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 = ; @@@ -76,6 -75,12 +76,6 @@@ create car-type-cells scheme-memsize al create cdr-cells scheme-memsize allot create cdr-type-cells scheme-memsize allot -variable gc-enabled -false gc-enabled ! - -: gc-enabled? - gc-enabled @ ; - create nextfrees scheme-memsize allot :noname scheme-memsize 0 do @@@ -91,7 -96,9 +91,7 @@@ variable nextfre nextfree ! nextfree @ scheme-memsize >= if - gc-enabled? if - collect-garbage - then + collect-garbage then nextfree @ scheme-memsize >= if @@@ -133,10 -140,6 +133,10 @@@ cdr-cells + ! ; +variable object-stack-base +: init-object-stack-base + depth object-stack-base ! ; + : nil 0 nil-type ; : nil? nil-type istype? ; @@@ -407,6 -410,9 +407,9 @@@ variable read-line-buffer-offse : make-frame ( vars vals -- frame ) cons ; + : add-frame-to-env ( frame env -- env ) + cons ; + : frame-vars ( frame -- vars ) car ; @@@ -421,99 -427,90 +424,90 @@@ ; : 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 @@@ -526,62 -523,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 -- ) @@@ -1722,10 -1663,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 ; @@@ -1974,9 -1911,6 +1968,9 @@@ : printcomp ( primobj -- ) 2drop ." " ; +: printcont ( primobj --) + 2drop ." " ; + : printnone ( noneobj -- ) 2drop ." Unspecified return value" ; @@@ -1995,7 -1929,6 +1989,7 @@@ 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 @@@ -2006,6 -1939,29 +2000,21 @@@ \ ---- Garbage Collection ---- {{{ + ( 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. + + NO OTHER OBJECTS WILL BE MARKED! + + 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. ) + -variable gc-stack-depth - -: enable-gc - depth gc-stack-depth ! - true gc-enabled ! ; - -: disable-gc - false gc-enabled ! ; + : pairlike? ( obj -- obj bool ) pair-type istype? if true exit then string-type istype? if true exit then @@@ -2081,7 -2037,7 +2090,7 @@@ 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 + @ @@@ -2130,8 -2086,11 +2139,8 @@@ include scheme-primitives.4th - enable-gc - + init-object-stack-base s" scheme-library.scm" load 2drop - - disable-gc \ }}} @@@ -2159,7 -2118,7 +2168,7 @@@ : repl empty-parse-str - enable-gc + init-object-stack-base \ Display welcome message welcome-symbol nil cons global-env obj@ eval 2drop @@@ -2173,6 -2132,8 +2182,6 @@@ throw false endcase until - - disable-gc ; forth definitions