(
Utility words
Copyright (c) 1988
Elijah Laboratories Inc.
Written by: R. J. Brown
Elijah Laboratories Inc.
201 West High Street
P. O. Box 833
Warsaw KY 41095
1 606 567-4613
rj brown @ ecfb / lmi
This file defines various useful utility words. It is
basically a catch-all repository for miscelaneous widgets.
The material contained in this file is Copyright [c] 1988
Elijah Laboratories Inc. All rights reserved world wide.
Permission is hereby granted to reproduce this document in
whole or in part provided that such reproductions refer to the
fact that the copied material is subject to copyright by Elijah
Laboratories, Inc. No changes or modifications may be made to
the copied material unless it is clearly indicated that such
changes were not incorporated in the original copyrighted work.
)
( Machine independent word size tools. )
WSIZE CONSTANT 1w ( -- #bytes/word ; machine word size )
1 CONSTANT 1b ( -- #bytes/byte == 1 always in F83! )
1w CONSTANT 1W 1b CONSTANT 1B ( allow upper or lower case )
: w+ 1w + ; : W+ w+ ; ( n -- n+1w ; add 1 word offset )
: w- 1w - ; : W- w- ; ( n -- n-1w ; subtract 1 word offset )
: w* 1w * ; : W* w* ; ( n -- n*1w ; n words offset )
: w*+ w* + ; : W*+ w*+ ; ( k n -- k+n*1w ; add n words offset )
: w/ 1w / ; : W/ w/ ; ( nb -- nw ; # bytes to # words )
1w 2* CONSTANT 1d \ no upper case equiv because of name clash
: d+ 1d + ; \ with Forth-83 standard D-words.
: d- 1d - ;
: d* 1d * ;
: d*+ d* + ;
: d/ 1d / ;
EXISTS? FPSIZE .IF FPSIZE CONSTANT 1f 1f CONSTANT 1F
: f+ 1f + ; : F+ f+ ; : f- 1f - ; : F- f- ;
: f* 1f * ; : F* f* ; : f*+ f* + ; : F*+ f*+ ;
: f/ 1f / ; : F/ f/ ;
: IFIX FIX DROP ; ( float -- int ) .THEN
\ Determine the implementation dependant pointer size.
\ HERE \ dictionary position before ptr
\ NULPTR PTR P \ allocate a pointer
\ HERE \ dictionary position after ptr
\ FORGET P \ get rid of pointer
\ SWAP - CONSTANT 1p \ compute size and give it a name
1w CONSTANT 1p \ for UR/Forth-386 !!!
\ Define pointer word size tools.
: p+ 1p + ;
: p- 1p - ;
: p* 1p * ;
: p*+ p* + ;
: p/ 1p / ;
( Words for handling segmented address space transparently. )
\ 1w 4 = .IF
\ : >S:O ADDR>S&O ;
\ : S:O> S&O>ADDR ;
\ .ELSE
: >S:O ( Do nothing! ) ; IMMEDIATE
: S:O> ( Do nothing! ) ; IMMEDIATE
\ .THEN
( The above is for LMI Forths. Do whatever you have to here
for your own favorite brand of the language. )
( Convenient words to have around. )
0 CONSTANT NIL ( -- false ; logical False value )
NIL NOT CONSTANT T ( -- true ; logical True value )
: T! T SWAP ! ; ( &v -- ; sets to T )
: NIL! NIL SWAP ! ; ( &v -- ; sets to NIL )
: FLIP DUP @ 0= SWAP ! ; ( &v -- ; reverses truth )
: SETQ ' SWAP ! ; ( &vec -- \ &vec SETQ <word> )
: ++ 1 SWAP +! ; ( addr -- ; increments word )
: -- -1 SWAP +! ; ( addr -- ; decrements word )
: R++ R> 1+ >R ; ( -- ; increment top of R-stack )
: R-- R> 1- >R ; ( -- ; decrement top of R-stack )
: SWOOP SWAP DUP ; ( x y -- y x x ; for combining tests )
: ... ; IMMEDIATE ( elipsis "noise word" for stubs, etc. )
: 3DUP 2 PICK 2 PICK 2 PICK ; ( copy top 3 stack elements )
: ?IF COMPILE ?DUP [COMPILE] IF ; IMMEDIATE
: NDUP BEGIN DUP WHILE 1- ( ... n -- ... ... ; DUP n items )
OVER SWAP REPEAT DROP ;
: NDROP 0 ?DO DROP LOOP ; ( ... n -- ; DROPs n items )
: NSWAP ( a..b c..d n -- c..d a..b ; SWAPs n word elements )
DUP 2* 1- SWAP
0 ?DO
DUP >R ROLL R>
LOOP DROP ;
( Compile time, or "early binding", literal definition.
Use as: #[ bit1 bit2 ... ]# for autocombining bit names,
as: #[ fld1 fld2 ... ]+ for constant structure offset,
or as: [ 2 3 + 7 * 5 / ]# for compile time expression. )
: #[ 0 [COMPILE] [ ; IMMEDIATE ( begin compile time literal )
: ]# [COMPILE] ] [COMPILE] LITERAL ; IMMEDIATE ( end it )
: ]+ [COMPILE] ]# COMPILE + ; IMMEDIATE ( end cmp time offset )
: ]- [COMPILE] ]# COMPILE - ; IMMEDIATE ( end negative offset )
(
These words are used to give names to bits.
Usage:
#bits{ #bit <bit-1> ... #bit <bit-n> }#bits
)
: #bits{ 1 ; ( begin a series of bit definitions )
: #bit CREATE DUP , 2* DOES> @ OR ; ( n -- 2n \ 2n ; name bit )
: }#bits DROP ; ( end a series of bit definitions )
8 CONSTANT BITS/BYTE \ number of bits in a byte
: TRANSLATE-TABLE CREATE ( -- \ TRANSLATE-TABLE name n , ... )
DOES> + C@ ; ( n -- m ; translate a byte )
TRANSLATE-TABLE >MASK ( bit# -- bit-mask ; return a bit-mask )
1 C, 2 C, 4 C, 8 C, 16 C, 32 C, 64 C, 128 C,
: BIT[] ( n -- mask offset ; to index into a bit string )
BITS/BYTE /MOD SWAP >MASK SWAP ;
: BIT[]@ ( n base -- flag ; fetch truth value of a bit )
SWAP BIT[] ROT + C@ AND 0<> ;
: BIT[]! ( flag n base -- ; store truth value to a bit )
SWAP BIT[] SWAP >R + \ flag addr <-P R-> mask
DUP @ R@ NOT AND \ turn off addressed bit
ROT 0<> R> AND OR \ OR in flag's truth value
SWAP ! ; \ replace entire byte
: +BIT[] T -ROT BIT[]! ; ( n base -- ; set a bit )
: -BIT[] NIL -ROT BIT[]! ; ( n base -- ; clear a bit )
: ~BIT[] ( n base -- ; toggle a bit )
2DUP BIT[]@ NOT -ROT BIT[]! ; \ could be faster...
\ symbols ala Lisp
( Retrieve the unique tag associated with a symbol. If the
symbol is not defined, then create it, otherwise just return
its address. )
: $ ( -- cfa \ $ <token> ; create <token> if needed )
>IN @ BL WORD FIND ( save input ptr & find token )
IF NIP ( trash ptr & return cfa if found )
ELSE DROP >IN ! CREATE ( else create it )
LAST @ NAME> THEN ; ( and return its cfa )
: [$] ( compile time version of $ )
LAST @ $ ( save so UNSMUDGE won't get confused! )
[COMPILE] LITERAL LAST ! ; IMMEDIATE ( fix for UNSMUDGE )
\ embedded colon defs
( Braces define "literal words" similar to unnamed LAMBDA
expressions in Lisp. The code> : foo bar baz ;
: moby ... ['] foo ... ;
may be replaced by -----------> : moby ... { bar baz } ... ;
and acheive the same effect without making foo a word too. )
: { ( -- branch-patch-addr init-state unnamed-pfa )
STATE @ DUP >R IF ( begin an unnamed word definition )
COMPILE branch ( build skeleton branch around it )
HERE 0 ,
ELSE ] THEN
R> HERE ; IMMEDIATE
: } ( branch-patch-addr init-state unnamed-pfa -- unnamed-cfa )
COMPILE EXIT ( end definition with EXIT )
CP @ SWAP PFA, nest JMP, SWAP \ build code field
IF SWAP HERE OVER - SWAP ! ( patch offset into branch skel )
[COMPILE] LITERAL
ELSE [COMPILE] [
THEN ; IMMEDIATE ( compile cfa as literal )
\ odd exits & tock
( A good old fashioned GOTO is sometimes quite useful. )
: GOTO R> DROP >BODY >S:O >R ; ( &word -- \ ['] word GOTO )
: GO ' [COMPILE] LITERAL COMPILE GOTO ; IMMEDIATE \ GO word
( These words return from the word that called them. )
: 2EXIT R> R> 2DROP ; ( double whammy return )
: ;; COMPILE R> COMPILE DROP [COMPILE] ; ; IMMEDIATE ( ditto )
: ?EXIT IF R> DROP THEN ; ( conditional exit ala muLisp )
( `, pronounced "tock" does either a : or R: as needed. If
tick provides the address, tock provides the data. )
: ` >IN @ >R BL WORD R> >IN ! FIND IF R: ELSE : THEN ;
\ debugging aids
: X. BL EMIT BASE @ 16 BASE !
SWAP 4 U.R BL EMIT BASE ! ; ( n -- ; hex print )
: .' ' CR DUP ." cfa " X. \ show name & addresses
DUP >BODY ." pfa " X.
BL EMIT >NAME .NAME ;
\ stolen from C
: |! OVER @ OR SWAP ! ; ( addr bits -- ; *addr |= bits )
\ stolen from FORTRAN IV
: ** ( k n -- k**n ; raise integer to an integer power )
1 SWAP 0 DO OVER * LOOP NIP ;
( This word delays execution for the specified number of
timer ticks. Since the need to delay occurs frequently in
the source code, and it is handled differently depending on
whether multitasking is being used or not, it is isolated here
to provide a single point of change for maintenence reasons. )
VARIABLE #ticks \ timer cell
: ticks-delay ( n -- ) \ delay n ticks
#ticks ! \ initialize ticker
#ticks TICKER DROP \ start ticker
BEGIN #ticks @ WHILE REPEAT ; \ wait till expired
: BETWEEN? ( x i j -- flag ) \ T if i <= x <= j else NIL
>R OVER <= SWAP R> <= AND 0<> ;
ASCII A CONSTANT 'A' ASCII Z CONSTANT 'Z'
ASCII a CONSTANT 'a' ASCII z CONSTANT 'z'
: TO-UPPER ( ^string ^STRING -- ^STRING ) \ convert a string to upper case
OVER C@ OVER C! \ copy length
OVER C@ 1+ 1 ?DO \ copy & convert string
OVER I + C@ \ get source char
DUP 'a' 'z' BETWEEN? \ is it lower case?
IF 'a' - 'A' + THEN \ yes, make it upper
OVER I + C! LOOP NIP ; \ put in STRING, &ct.
DECIMAL 13 CONSTANT <CR> \ carriage return is line delimiter
: .\ <CR> WORD COUNT TYPE CR ; IMMEDIATE \ for messages in INCLUDE files
: D>S COMPILE DROP ; IMMEDIATE \ for symetry with S>D