\ 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. ( Implement Vocabularies ) ( normal: link, flags&len, code ) ( vocab: link, flags&len, code | link , len=0, voclink ) variable last-vocabulary : vocabulary ( "name" ) create current @ 2 cells + , 0 , last-vocabulary @ , current @ @ last-vocabulary ! does> context ! ; : definitions context @ current ! ; vocabulary FORTH ' forth >body @ >link ' forth >body ! forth definitions ( Make it easy to transfer words between vocabularies ) : xt-find& ( xt -- xt& ) context @ begin 2dup @ <> while @ >link& repeat nip ; : xt-hide ( xt -- ) xt-find& dup @ >link swap ! ; 8 constant BUILTIN_MARK : xt-transfer ( xt -- ) dup >flags BUILTIN_MARK and if drop exit then dup xt-hide current @ @ over >link& ! current @ ! ; : transfer ( "name" ) ' xt-transfer ; : }transfer ; : transfer{ begin ' dup ['] }transfer = if drop exit then xt-transfer again ; ( Watered down versions of these ) : only forth 0 context cell+ ! ; : voc-stack-end ( -- a ) context begin dup @ while cell+ repeat ; : also context context cell+ voc-stack-end over - 2 cells + cmove> ; : previous voc-stack-end context cell+ = throw context cell+ context voc-stack-end over - cell+ cmove ; : sealed 0 last-vocabulary @ >body ! ; ( Hide some words in an internals vocabulary ) vocabulary internals internals definitions ( Vocabulary chain for current scope, place at the -1 position ) variable scope scope context cell - ! transfer{ xt-find& xt-hide xt-transfer voc-stack-end last-vocabulary notfound *key *emit wascr eat-till-cr immediate? input-buffer ?echo ?arrow. arrow evaluate-buffer evaluate&fill aliteral value-bind leaving( )leaving leaving leaving, parse-quote digit $@ raw.s tib-setup input-limit sp-limit ?stack [SKIP] [SKIP]' raw-ok boot-prompt free. $place zplace BUILTIN_MARK }transfer ( Move branching opcodes to separate vocabulary ) vocabulary internalized internalized definitions : cleave ' >link xt-transfer ; cleave begin cleave again cleave until cleave ahead cleave then cleave if cleave else cleave while cleave repeat cleave aft cleave for cleave next cleave do cleave ?do cleave +loop cleave loop cleave leave forth definitions ( Make DOES> switch to compile mode when interpreted ) ( forth definitions internals ' does> : does> state @ if postpone does> exit then ['] constant @ current @ @ dup >r ! here r> cell+ ! postpone ] ; immediate xt-hide forth definitions )
Legal: site web personnel sans commerce / personal site without seling