99 lines
3.3 KiB
Forth
99 lines
3.3 KiB
Forth
\ 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
|
|
nest-depth handler +evaluate1 do-notfound interpret0
|
|
}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
|
|
|
|
( Move recognizers to separate vocabulary )
|
|
vocabulary recognizers recognizers definitions
|
|
transfer{
|
|
REC-FIND REC-NUM
|
|
RECTYPE: RECTYPE-NONE RECTYPE-WORD RECTYPE-IMM RECTYPE-NUM
|
|
SET-RECOGNIZERS GET-RECOGNIZERS
|
|
-RECOGNIZER +RECOGNIZER RECSTACK
|
|
RECOGNIZE
|
|
}transfer
|
|
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
|
|
)
|