\ Copyright 2021 Bradley D. Nelson \ \ Licensed under the Apache License, Version 2.0 (the "License"); \ you may not use this file except in compliance with the License. \ You may obtain a copy of the License at \ \ http://www.apache.org/licenses/LICENSE-2.0 \ \ Unless required by applicable law or agreed to in writing, software \ distributed under the License is distributed on an "AS IS" BASIS, \ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. \ See the License for the specific language governing permissions and \ limitations under the License. ( Stack Baseline ) sp@ constant sp0 rp@ constant rp0 fp@ constant fp0 : depth ( -- n ) sp@ sp0 - cell/ ; : fdepth ( -- n ) fp@ fp0 - 4 / ; ( Useful heap size words ) : remaining ( -- n ) 'heap-start @ 'heap-size @ + 'heap @ - ; : used ( -- n ) 'heap @ sp@ 'stack-cells @ cells + - 28 + ; ( Quoting Words ) : ' bl parse 2dup find dup >r -rot r> 0= 'notfound @ execute 2drop ; : ['] ' aliteral ; immediate : char bl parse drop c@ ; : [char] char aliteral ; immediate ( Core Control Flow ) create BEGIN ' nop @ ' begin ! : begin ['] begin , here ; immediate create AGAIN ' branch @ ' again ! : again ['] again , , ; immediate create UNTIL ' 0branch @ ' until ! : until ['] until , , ; immediate create AHEAD ' branch @ ' ahead ! : ahead ['] ahead , here 0 , ; immediate create THEN ' nop @ ' then ! : then ['] then , here swap ! ; immediate create IF ' 0branch @ ' if ! : if ['] if , here 0 , ; immediate create ELSE ' branch @ ' else ! : else ['] else , here 0 , swap here swap ! ; immediate create WHILE ' 0branch @ ' while ! : while ['] while , here 0 , swap ; immediate create REPEAT ' branch @ ' repeat ! : repeat ['] repeat , , here swap ! ; immediate create AFT ' branch @ ' aft ! : aft drop ['] aft , here 0 , here swap ; immediate ( Recursion ) : recurse current @ @ aliteral ['] execute , ; immediate ( Postpone - done here so we have ['] and IF ) : immediate? ( xt -- f ) >flags 1 and 0= 0= ; : postpone ' dup immediate? if , else aliteral ['] , , then ; immediate ( Rstack nest depth ) variable nest-depth ( FOR..NEXT ) create FOR ' >r @ ' for ! : for 1 nest-depth +! ['] for , here ; immediate create NEXT ' donext @ ' next ! : next -1 nest-depth +! ['] next , , ; immediate ( DO..LOOP ) variable leaving : leaving, here leaving @ , leaving ! ; : leaving( leaving @ 0 leaving ! 2 nest-depth +! ; : )leaving leaving @ swap leaving ! -2 nest-depth +! begin dup while dup @ swap here swap ! repeat drop ; : DO ( n n -- .. ) swap r> -rot >r >r >r ; : do ( lim s -- ) leaving( postpone DO here ; immediate : ?DO ( n n -- n n f .. ) 2dup = if 2drop r> @ >r else swap r> cell+ -rot >r >r >r then ; : ?do ( lim s -- ) leaving( postpone ?DO leaving, here ; immediate : UNLOOP r> rdrop rdrop >r ; : LEAVE r> rdrop rdrop @ >r ; : leave postpone LEAVE leaving, ; immediate : +LOOP ( n -- ) dup 0< swap r> r> rot + dup r@ < -rot >r >r xor 0= if r> cell+ rdrop rdrop >r else r> @ >r then ; : +loop ( n -- ) postpone +LOOP , )leaving ; immediate : LOOP r> r> 1+ dup r@ < -rot >r >r 0= if r> cell+ rdrop rdrop >r else r> @ >r then ; : loop postpone LOOP , )leaving ; immediate create I ' r@ @ ' i ! ( i is same as r@ ) : J ( -- n ) rp@ 3 cells - @ ; : K ( -- n ) rp@ 5 cells - @ ; ( Exceptions ) variable handler handler 'throw-handler ! : catch ( xt -- n ) fp@ >r sp@ >r handler @ >r rp@ handler ! execute r> handler ! rdrop rdrop 0 ; : throw ( n -- ) dup if handler @ rp! r> handler ! r> swap >r sp! drop r> r> fp! else drop then ; ' throw 'notfound ! ( Values ) : value ( n -- ) constant ; : value-bind ( xt-val xt ) >r >body state @ if r@ ['] ! = if rdrop ['] doset , , else aliteral r> , then else r> execute then ; : to ( n -- ) ' ['] ! value-bind ; immediate : +to ( n -- ) ' ['] +! value-bind ; immediate ( Deferred Words ) : defer ( "name" -- ) create 0 , does> @ dup 0= throw execute ; : is ( xt "name -- ) postpone to ; immediate
Legal: site web personnel sans commerce / personal site without seling