\ ========== Copyright Header Begin ==========================================
\ Hypervisor Software File: tokenize.fth
\ Copyright (c) 2006 Sun Microsystems, Inc. All Rights Reserved.
\ - Do no alter or remove copyright notices
\ - Redistribution and use of this software in source and binary forms, with
\ or without modification, are permitted provided that the following
\ - Redistribution of source code must retain the above copyright notice,
\ this list of conditions and the following disclaimer.
\ - Redistribution in binary form must reproduce the above copyright notice,
\ this list of conditions and the following disclaimer in the
\ documentation and/or other materials provided with the distribution.
\ Neither the name of Sun Microsystems, Inc. or the names of contributors
\ may be used to endorse or promote products derived from this software
\ without specific prior written permission.
\ This software is provided "AS IS," without a warranty of any kind.
\ ALL EXPRESS OR IMPLIED CONDITIONS, REPRESENTATIONS AND WARRANTIES,
\ INCLUDING ANY IMPLIED WARRANTY OF MERCHANTABILITY, FITNESS FOR A
\ PARTICULAR PURPOSE OR NON-INFRINGEMENT, ARE HEREBY EXCLUDED. SUN
\ MICROSYSTEMS, INC. ("SUN") AND ITS LICENSORS SHALL NOT BE LIABLE FOR
\ ANY DAMAGES SUFFERED BY LICENSEE AS A RESULT OF USING, MODIFYING OR
\ DISTRIBUTING THIS SOFTWARE OR ITS DERIVATIVES. IN NO EVENT WILL SUN
\ OR ITS LICENSORS BE LIABLE FOR ANY LOST REVENUE, PROFIT OR DATA, OR
\ FOR DIRECT, INDIRECT, SPECIAL, CONSEQUENTIAL, INCIDENTAL OR PUNITIVE
\ DAMAGES, HOWEVER CAUSED AND REGARDLESS OF THE THEORY OF LIABILITY,
\ ARISING OUT OF THE USE OF OR INABILITY TO USE THIS SOFTWARE, EVEN IF
\ SUN HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
\ You acknowledge that this software is not designed, licensed or
\ intended for use in the design, construction, operation or maintenance of
\ ========== Copyright Header End ============================================
id: @(#)tokenize.fth 1.16 06/02/16
purpose: Tokenizer program source - converts FCode source to byte codes
copyright: Copyright 2006 Sun Microsystems, Inc. All Rights Reserved
copyright: Use is subject to license terms.
\ Add a means to define symbols for use with ifdef
\ Add a means to set the start code from the command line
only forth also definitions
\ ' $report-name is include-hook
\ Force externals, this is for debugging
variable force-external? force-external? off
\ Force headers, also for debugging
variable force-headers? force-headers? off
\ Force headerless. For debugging and also
\ for trimming down your binary without
\ changing your source-base.
variable force-headerless? force-headerless? off
\ To activate any of the above, set it "on" from the command-line
also tokenizer also definitions
decimal warning off caps on
fload ${BP}/fm/lib/split.fth \ 32>8,8,8,8; 16>8,8; 8,8>16 ...
\ Keep quiet about warnings and statistics.
variable silent silent off
\ when true, #, #s, #> uses single vs double stack values.
variable pre1275 pre1275 off
\ true to prepend an a.out header to the output file
variable aout-header? aout-header? off
\ Statistics variables used in final statistics word
variable compiling \ True if in an FCode definition
variable #end0s #end0s off \ How many END0 tokens encountered
variable offset-8? offset-8? off \ Can be set to true by tokenize script
defer fcode-start-code \ start0, start1, start2, or start4
variable tokenization-error \ True if error encountered in FCode source
\ File header creation, fill in size later (see a.out(5) for format)
create header h# 01030107 , 0 , 0 , 0 , 0 , h# 4000 , 0 , 0 ,
\ Monitor current output counters
\ 'bhere' returns the total # of byte-codes output so far.
\ 'fhere' returns the current position in the file. This will be
\ different, because of the file header (32 bytes), and sometimes more
\ because of debugging information being output as well as byte-codes.
variable bytes-emitted \ Total # of byte-codes output so far
: bhere ( -- #token-bytes-emitted ) bytes-emitted @ ;
: fhere ( -- cur-file-pos ) ofd @ ftell ;
\ Vectored output primitives
\ put byte to output file
\ lbsplit .byte .byte .byte .byte
: inc ( adr -- ) 1 swap +! ; \ increment variable
variable checksum \ Running total of all emitted bytes
dup checksum +! .byte bytes-emitted inc
\ bytes-emitted @ .x checksum @ .x cr
\ The user-level "emit-byte" will *not* affect the running-total
\ length and checksum fields before "fcode-versionx" and after "end0"
\ This allows embedded binary before and after the fcode to work
\ correctly, i.e. leave the fcode-only image unaltered.
' .byte is emit-byte \ Will later be vectored to emit-fbyte
: emit-word ( w -- ) wbsplit emit-byte emit-byte ;
: emit-long ( l -- ) lwsplit emit-word emit-word ;
: emit-local-escape ( apf -- ) \ (adr+1)c@=0 then output 1 byte token
ca1+ dup c@ if emit-token else drop then
dup emit-local-escape emit-token
: pad-size ( -- ) \ Pad file to longword boundary
dup /l round-up swap - 0 ?do 0 emit-byte loop
\ Compiling word to create primitive tokens
variable which-version \ bit variable - each bit represents a version's use
variable #version1s \ accumulator of version 1 tokens compiled
variable #version1+2s \ accumulator of version 1+2 tokens compiled
variable #version2s \ accumulator of version 2.x tokens compiled
variable #version2.1s \ accumulator of version 2.1 tokens compiled
variable #version2.2s \ accumulator of version 2.2 tokens compiled
variable #version2.3s \ accumulator of version 2.3 tokens compiled
variable #version3s \ accumulator of version 3 tokens compiled
variable #obsoletes \ accumulator of obsolete tokens compiled
: or! ( adr bit$ -- ) over @ or swap ! ; \ or in bit string
: v1 ( -- ) which-version 1 or! ; \ FCode was/is versions 1
: v2 ( -- ) which-version 2 or! ; \ FCode was/is versions 2.0
: v2.1 ( -- ) which-version 4 or! ; \ FCode was/is versions 2.1
: v2.2 ( -- ) which-version 8 or! ; \ FCode was/is versions 2.2
: v2.3 ( -- ) which-version h# 10 or! ; \ FCode was/is versions 2.3
: v3 ( -- ) which-version h# 20 or! ; \ FCode was/is versions 3
: obs ( -- ) h# 40 which-version ! ; \ FCode is obsolete
\ We need a convenient way to mark ALL the obsoleted FCodes with obs
\ but we can't change them in their source files, because their
\ version-designators may be used elsewhere...
vocabulary obs-fcoder also obs-fcoder definitions
\ We're going to redefine, in this vocabulary, all of the
\ version-designators (except v1 , since, if a token
\ designated by v1 alone is used in an FCode source,
\ that will invalidate the tokenization) that are used
\ in the collection of obsoleted FCodes to designate
\ Put this vocabulary at the top of the search-order before
\ loading the obsoleted FCodes; it will act as a filter.
\ The codes v2.1 v2.3 or v3 are not used in the collection
\ of obsoleted FCodes, and might not even designate obsolete
h# 40 constant max-version
: check-version ( -- vers# )
which-version dup @ swap off
dup 0= abort" missing v1, v2 ... byte-code: prefix"
dup max-version > abort" something wrong with ver-flag; (too big)"
\ Print the token's name in back-and-forward quotes, thus: `name'
." `" >name name>string type ." '" \ No space after
: .token-warning ( pfa -- pfa )
where ." *** Warning: " dup body> .`name'
: count-version ( pfa vers# -- pfa )
." is an obsoleted version 1 token. ***"
h# 10 of #version2.3s endof
h# 20 of #version3s endof
." is an obsolete FCode token. ***" cr
\ Common preface to a tokenization-error message:
: .tokenization-error ( -- )
\ Include this in a definition of an obsolete word that will
\ have special redeeming behavior, but still should shout
\ a warning. Obtain the calling word's PFA from its
\ inevitable residue on the return stack.
r@ find-cfa >body \ PFA of calling word
\ Incorporate this into a special definition where a sequence
\ will replace the named token. The replacement sequence
\ should be passed as a string which will be interpreted
\ in the tokenization context. The calling word's name
\ will also be obtained from the return stack to be printed.
: replace ( $adr,len -- )
r@ find-cfa \ CFA of calling word
where ." *** Replacing " ( $adr,len cfa )
.`name' ." with: " ( $adr,len )
\ We're going to create the means to give an error message if
\ the target of ' ("tick") or ['] ("bracket-tick-bracket")
\ is not what the user expects it to be (e.g., a macro that
\ resolves into a multi-byte-code sequence).
\ Valid targets are words that will issue a direct byte-code.
\ Some of them can be identified by their defining-word;
\ the word-type function will yield that information.
\ We're going to create a linked-list of word-types that identify
\ valid "tick-targets". To do that, we'll create a modifying
\ word -- syntactically similar to immediate in that it
\ takes effect on the last definition made.
\ All the valid defining-words are create ... does> type words
\ and we're going to take advantage of that fact plus the fact
\ that the invocation of does> updates lastacf to point
\ at exactly the location that will be returned when word-type
\ is applied to a word defined by the defining-word just defined.
\ (Does this make your head spin? I'm positively giddy!)
\ First, we need a place to keep the start of the linked-list:
create tick-target-word-type-link null link,
\ Each entry in the linked list will consist of two items:
\ (1) The word-type token to be entered into the list
\ (2) A link pointing to the preceding link (null at end of list).
\ Support function. Enter the given CFA into the list whose
\ starter-pointer address is also given:
: (valid-tick-target) ( type-cfa link-start-addr -- )
here \ Establish new start of linked-list
swap ( here link-start-addr )
dup link@ ( here link-start-addr prev-link )
link, ( here link-start-addr )
\ Enter the word-type of words that will be defined by a newly-defined
\ defining-word into the list of valid "tick-targets".
\ Use this immediately after defining the defining-word.
\ (Syntactically similar to immediate .)
: valid-tick-target-word-type ( -- )
lastacf tick-target-word-type-link (valid-tick-target)
\ Scan through the linked-list, to find whether the word-type
\ of the function whose CFA is given is a valid tick-target.
\ Return a not-valid? flag, indicating whether further checking
\ is required, and under that, either the original CFA (if
\ it's not valid) or another false, to be passed on as the
\ not-valid? flag for the next customer...
\ Support function. Given a CFA (of a word-type or a function)
\ and the address of the link that starts the list, do the
\ actual search through the list:
: (bad-tick-target?) ( cfa link-start-addr -- cfa true | false false )
over true 2swap begin ( cfa true cfa link-adr )
another-link? while ( cfa true cfa next-link )
2dup /token - token@ = if
[ also hidden ] 4drop [ previous ] false false
then ( cfa true cfa next-link )
\ Rather than require awkward stack-dancing, we will not attempt to
\ retain the CFA on the stack, nor to return it. The calling
\ routine will have a much easier time handling that...
: bad-tick-target-word-type? ( cfa -- true | false false )
tick-target-word-type-link ( word-type link-start-addr )
(bad-tick-target?) ( word-type true | false false )
\ We will create an "exceptions list" that is a linked-list of
\ tokens of colon-definitions that are valid "tick-targets".
\ Start with a pointer to the start of the list
create tick-target-:-link null link,
\ The entries in this linked list are structured similarly to
\ the one preceding. The first item is the token of the
\ exempted word. It is remarkably similar in form... ;-)
\ Enter the newly-defined function into the list of valid
\ "tick-targets" even though its word-type (mainly colon)
\ Use this immediately after defining the function to validate.
\ (Syntactically similar to immediate .)
: valid-tick-target ( -- )
lastacf tick-target-:-link (valid-tick-target)
\ Scan through the linked-list, to find whether the function
\ whose CFA is given is a valid colon-defined tick-target.
: bad-:-tick-target? ( cfa -- cfa true | false false )
\ Chain together the categories we're testing.
\ At present, there are only two of 'em...
: bad-tick-target? ( cfa -- not-valid? )
\ Do the word-type test first because:
\ (A) It's faster (fewer entries in the table)
\ and (B) it's -- by far -- more frequently encountered.
dup bad-tick-target-word-type? if
dup bad-:-tick-target? nip
\ Give the error-message.
: .bad-tick-target ( cfa -- cfa )
." is not a valid target for ' or [']" cr
\ Shout if the next token in the input stream
\ isn't a valid target for ' or [']
\ Incorporate this into the ' or ['] words...
: ?valid-tick-target ( -- ) \ <name> (but does not consume it.)
parse-word ( old>in $adr,len )
dup bad-tick-target? if ( cfa )
\ Next token wasn't found; let normal ? mechanism handle it.
: byte-code: \ name ( token# table# -- ) \ Compiling
( -- ) \ At execute time, sends proper token# to output stream
; valid-tick-target-word-type
\ A v2-compat: definition need not necessarily be a valid "tick-target"
\ but we can detect if it is and mark it as such.
: v2-compat: \ old-name current-name ( -- )
create ' ( current-name-cfa )
dup bad-tick-target? 0= swap ( valid? cfa )
if valid-tick-target then
." Warning: Substituting " dup token@ .`name'
." for old name " dup body> .`name' cr
: Pre-1275: \ new-name new-name old-name ( -- )
hide ' token, ' token, reveal
." Warning: Substituting single stack item "
." for " dup token@ .`name' cr
: depend-load \ 'feature-symbol' file
safe-parse-word safe-parse-word ( symbol$ file$ )
2swap [get-symbol] drop if ( file$ )
" DEPEND" [get-symbol] drop if ( file$ )
fload ${BP}/fm/lib/message.fth
\ When executing, forth, tokens and 'reforth' words are allowed.
\ 'reforth' vocab. redefines certain words like : and constant.
\ When compiling, *only* prim. tokens, macros or new local tokens
\ are allowed. The file 'crosslis.fth' holds equivalent names
\ for missing primitives, e.g. : 2+ 2 + ;
\ Needed words that do not have primitive token equivalents
\ (e.g.: h# etc.) are handled with aliases to standard forth.
\ Control words (if, begin, loop, etc.) have custom definitions, as
\ do a limited set of string input words as well as words that
\ generate special literals, (e.g.: ascii control etc.).
\ Add allowed tokens into 'tokens' vocabulary
\ don't search the tokens voc because it includes numbers (-1, 0, 1, ..)
only forth also tokenizer also tokens definitions tokenizer
fload ${BP}/pkg/tokenizr/primlist.fth \ Basic ("complete"?) set of FCodes
fload ${BP}/pkg/tokenizr/obsfcode.fth
only forth also tokenizer also
\ For the rest of this file, the search order is *always* either:
\ context: forth forth root current: forth - or -
\ context: tokens forth root current: tokens - or -
\ context: reforth forth root current: reforth
alias th th \ becoming obsolete
alias td td \ becoming obsolete
alias [define] [define] \ define a symbol
alias [undef] [undef] \ undefine
alias [defined] [defined] \ forward parsed symbol-value
alias [ifexist] [ifexist]
alias [ifnexist] [ifnexist]
alias [message] [message] \ For spitting out compile info
alias depend-load depend-load
alias recursive recursive
\ Init search path during execution
: init-path ( ) \ Outside of definitions, allow 'tokens' and 'reforth'
only root also reforth also tokens definitions
: tokens-only ( -- ) \ Allow only tokens within definitions
only tokens also definitions
only forth also definitions
[ also tokens ] b(lit) [ previous ] emit-long
: tokenize-literal ( n 1 | d 2 -- )
2 = if swap emit-number then emit-number ;
\ Lookup table primitives
\ 'lookup' table contains 256 longword values, corresponding
\ to 256 possible local tokens. Entry #n contains the offset from the
\ beginning of the bytes-output file where the definition of local
\ token#n begins. For variables and constants, entry #n+1 contains
\ the actual value of the variable (0 initially) or constant.
8 constant first-local-escape
256 /l* constant 1tablesize \ Size of one 256-word table
1tablesize 8 * buffer: lookup
variable next-lookup# \ Next lookup# available
variable local-escape \ Current local escape-code
: advance-lookup# ( -- ) 1 next-lookup# +! ;
: lookup#-range-check ( -- )
next-lookup# @ d# 254 > if
1 local-escape +! 0 next-lookup# !
: next-lookup ( -- addr )
local-escape @ first-local-escape - 1tablesize * +
: set-lookup-pointer ( bhere -- ) \ Pnt cur lookup# to current byte-out
\ Go back and patch previous output items
: patch-byte ( byte addr -- ) \ Go back to 'addr' and insert 'val'
fhere >r \ Save current file pointer
ofd @ fseek \ Move back to 'addr' location
emit-fbyte -1 bytes-emitted +! \ fix forward reference
r> ofd @ fseek \ Restore current file pointer
: patch-word ( word addr -- ) >r wbsplit r@ patch-byte r> 1+ patch-byte ;
: patch-long ( long addr -- ) >r lwsplit r@ patch-word r> 2+ patch-word ;
variable dummy 0 dummy ! \ Use this form just so we can see
\ the name with emit-token during debug.
['] dummy >body emit-token \ Emit 0-value dummy token for now
variable local-start \ Byte-count at start of current word
: save-local-start ( -- ) \ Save current bytes-emitted value
\ Length & checksum creation
variable checksumloc \ Location of checksum and length fields
variable fcode-vers fcode-vers off
: .mult-fcode-vers-error ( -- )
??cr where ." Warning: Multiple Fcode-version# commands encountered. " cr
['] tokenize-literal is do-literal
[ forth ] ['] (header) is header [ tokenizer ]
\ The accepted plug-in format is:
\ fd - version1 fcode (1 byte) for first encountered fcode.
\ checksum - 2 bytes containing the fcode PROM checksum.
\ length - 4 bytes specifying the total usable length of fcode data
\ (i.e. from 'version1' to 'end0' inclusive)
\ The checksum is calculated by summing all remaining bytes, from just after
\ the length field to the end of the usable fcode data (as indicated
bhere abort" Fcode-version# should be the first FCode command!"
which-version off \ init version flag to normal state
#version1s off \ init version 1 code counter
#version1+2s off \ init version 1 and 2 code counter
#version2s off \ init version 2 code counter
#version2.1s off \ init version 2.1 code counter
#version2.2s off \ init version 2.2 code counter
#version2.3s off \ init version 2.3 code counter
#version3s off \ init version 3 code counter
#obsoletes off \ init obsolete code counter
checksum off \ Clear checksum bits set by version1
['] emit-fbyte is emit-byte
: ((fcode-version ( offset16? sub-ver# -- )
emit-byte \ sub-version (or violence?)
0 emit-word \ Filler for later checksum field
0 emit-long \ Filler for later length field
checksum off \ Needed again; we emited bytes we aren't counting.
[ tokens ] offset16 [ tokenizer ] \ compile offset16 Fcode
fcode-vers @ if .mult-fcode-vers-error
(fcode-version) version1 \ (0xfd token)
offset-8? @ 0= \ Compile offset16 Fcode?
3 \ sub-version (2.2 with fixed checksum)
fcode-vers @ if .mult-fcode-vers-error
[ tokens ] (fcode-version) start1 [ tokenizer ]
offset-8? off false \ Don't compile offset16 Fcode
3 \ sub-version (2.2 with fixed checksum)
' start1 is fcode-start-code
fcode-vers @ if .mult-fcode-vers-error
[ tokens ] (fcode-version) fcode-start-code [ tokenizer ]
offset-8? off false \ Don't compile offset16 Fcode
8 \ sub-version (3. P1275-compliant).
\ Test for branch offsets greter than one byte
: test-span ( delta -- ) \ Test if offset is too great
d# -128 d# 127 between 0= ( error? ) if
." Branch interval of +-127 bytes exceeded." cr
." Use OFFSET16 or, better yet, use shorter dfns." cr
\ Token control structure primitives
\ Number of bytes in a branch offset
: /branch-offset ( -- n ) 1 offset-8? @ 0= if 1+ then ;
: +Level ( -- ) 1 Level +! ;
: -Level ( -- ) -1 Level +! Level @ 0< abort" Bad conditional" ; \ XXX
: >Mark ( -- bhere fhere )
offset-8? @ 0= if emit-dummy then \ Two bytes if offset-16 is true
: >Resolve ( oldb oldf -- )
bhere rot - swap ( delta oldf )
over test-span patch-byte
: <Mark ( -- bhere fhere ) bhere fhere ;
: <Resolve ( oldb oldf -- )
\ Bypass the abort" built in to ?pairs and ?csp
: catch-tok.error ( XT -- error? )
\ We want to print the error using our format, (i.e., w/ leading " Error: ")
\ not the default. To do that, we need to temporarily suppress the action
\ of show-error and use our own instead...
['] show-error behavior ( error# old-show-error )
( old-show-error ) is show-error ( error# )
: tok?csp? ( -- error? ) ['] ?csp catch-tok.error ;
: tok?pairs? ( chk2 chk1 -- error? )
['] ?pairs catch-tok.error dup if nip nip then
: but ( b1 f1 t1 b2 f2 t2 -- b2 f2 t2 b1 f1 t1 )
>r rot >r 2swap ( b2 f2 b1 f1 ) ( r: t2 t1 )
r> r> swap >r -rot r> ( b2 f2 t2 b1 f1 t1 )
: +>Mark ( -- bhere fhere ) +Level >Mark ;
: +<Mark ( -- bhere fhere 11 ) +Level <Mark 11 ;
: ->Resolve ( oldb oldf chk2 chk1 -- )
tok?pairs? if 2drop else >Resolve -Level then
: -<Resolve ( oldb oldf chk -- )
11 tok?pairs? if 2drop else <Resolve -Level then
\ Use this to "Roll Your Own"
: token: ( bytecode -- ) \ Name
; valid-tick-target-word-type
\ Take Forth/tokenizer commands only
\ ['] interpret-do-literal is do-literal
[ forth ] ['] drop [ tokens ] is do-literal
only forth also tokenizer definitions
\ Restore normal FCode behavior
['] tokenize-literal is do-literal
compiling @ if tokens-only else init-path then
\ Token control structure words
\ !! Any word followed by ( T) is an executable token, *not* forth!
: ['] ( -- ) ?valid-tick-target b(') ; valid-tick-target
: to ( -- ) b(to) ; valid-tick-target
: ahead ( -- fhere 22 ) bbranch ( T) +>Mark h# 22 ;
: if ( -- fhere 22 ) b?branch ( T) +>Mark h# 22 ;
: then ( oldb oldf 22 -- )
[ tokenizer ] h# 22 ->Resolve [ tokens ]
: else ( fhere1 22 -- fhere2 22 )
ahead [ tokenizer ] but [ tokens ] ( fhere2 22 fhere1 22 )
: begin ( -- bhere fhere 11 ) b(<mark) ( T) +<Mark ;
: again ( oldb 11 -- ) bbranch ( T) -<Resolve ;
: until ( oldb 11 -- ) b?branch ( T) -<Resolve ;
: while ( bhere fhere 11 -- bhere2 fhere2 22 bhere fhere 11 )
[ tokenizer ] but ( whileb whilef 22 oldb 11 ) [ tokens ]
: repeat ( fhere 22 bhere 11 -- ) again ( T) then ( T) ;
+Level b(case) ( T) [ tokenizer ] 0 h# 44 [ tokens ]
: of ( 44 -- of-b of-f 55 )
h# 44 tok?pairs? [ also forth ] 0= if [ previous ]
[ also forth ] then [ previous ]
: endof ( of-b of-f 55 -- endof-b endof-f 44 )
b(endof) ( T) >Mark h# 66 ( of-b of-f endof-b endof-f )
[ also tokenizer ] but ( T)
h# 55 tok?pairs? [ forth ] 0= if
[ tokenizer ] >Resolve h# 44
[ forth ] then [ previous ]
: endcase ( 0 [endof-address 66 ...] 44 -- )
h# 44 tok?pairs? [ also forth ] 0= if
[ tokenizer ] >Resolve ( T) [ forth ]
[ tokenizer ] -Level ( T)
[ forth ] then [ previous ]
: do ( -- >b >f 33 <b <f 11 ) b(do) ( T) +>Mark h# 33 +<Mark ;
: ?do ( -- >b >f 33 <b <f 11 ) b(?do) ( T) +>Mark h# 33 +<Mark ;
: loop ( >b >f 33 <b <f 11 -- )
b(loop) ( T) [ tokenizer ] -<Resolve h# 33 ->Resolve [ tokens ]
: +loop ( >b >f 33 <b <f 11 -- )
b(+loop) ( T) [ tokenizer ] -<Resolve h# 33 ->Resolve [ tokens ]
: leave ( ??? -- ??? ) b(leave) ( T) ;
: ?leave ( ??? -- ??? ) if ( T) leave ( T) then ( T) ;
\ Add cross-compiler macros for common non-tokens
fload ${BP}/pkg/tokenizr/crosslis.fth
compiling @ if m-hex else hex then
compiling @ if m-decimal else decimal then
compiling @ if m-octal else octal then
compiling @ if m-binary else binary then
\ (Implementation word, will not be supported)
: ", ( adr len -- ) \ compile the string into byte-codes
dup emit-byte ( adr len )
\ (Implementation word, will not be supported)
[ tokenizer ] get-string [ hidden ] ",
: " \ text" ( -- ) \ Compiling ( -- adr len ) \ Executing
b(") [ also hidden ] ," [ previous ]
: s" \ text" ( -- ) \ Compiling ( -- adr len ) \ Executing
[ tokenizer ] ascii " parse [ hidden ] ", [ tokens ]
b(") [ tokenizer ] ascii ) parse [ hidden ] ", [ tokens ] type
: offset16 ( -- ) \ Intentional redefinition
offset-8? [ tokenizer ] off \ Set flag for 16-bit branch offsets
\ New NAME shorthand form for "name" property
encode-string b(") [ tokenizer ] " name"
[ tokenizer ] safe-parse-word drop c@ emit-number [ tokens ]
: control \ name ( -- n )
[ tokenizer ] safe-parse-word drop c@ h# 1f and emit-number [ tokens ]
.tokenization-error ." 'char' is not permitted inside FCode definitions"
.tokenization-error ." '[char]' is not permitted outside FCode definitions"
\ Three ways of creating a new token's name:
\ Make it an external name,
\ make it headered only if fcode-debug? is true,
\ or don't make its name at all.
also forth also hidden definitions
: make-external-token ( $adr,len -- )
: make-headerless-token ( $adr,len -- )
: make-headered-token ( $adr,len -- )
previous previous definitions
defer make-token-name ['] make-headerless-token to make-token-name
\ Create word for newly-defined 'local' tokens
safe-parse-word 2dup $create ( adr len )
local-escape @ c, emit-local advance-lookup#
; valid-tick-target-word-type
: define-local: ( -- ) also tokens definitions local: previous ;
\ End creation of new local token
.tokenization-error ." ';' only allowed within definitions."
[ also tokens ] reveal b(;) [ previous ]
: ; ( -- ) \ New version of ; to end new-token definitions
\ Create new local tokens
: start-local-token \ name ( -- )
bhere set-lookup-pointer define-local:
tokens-only \ Restrict search within localword to tokens
bhere crash-site ! [ also tokens ] crash unnest [ previous ]
\ The user may over-ride headerless directives in the source by
\ turning on the variable force-headers? or force-external?
\ before running the tokenize command. (This is most commonly
\ done on the comand-line.) Similarly, the user may over-ride
\ headers directives by turning on force-headerless?
\ In case of conflict, i.e., if more than one of these variables
\ are turned on, force-external? over-rides force-headers?
\ and force-headers? over-rides force-headerless?
\ Don't ever over-ride or down-grade the external directive!
: set-make-token-name ( ACF -- )
force-headerless? @ if drop ['] make-headerless-token then
force-headers? @ if drop ['] make-headered-token then
force-external? @ if drop ['] make-external-token then
only forth also tokenizer also reforth definitions
: headers ( -- ) ['] make-headered-token set-make-token-name ;
: headerless ( -- ) ['] make-headerless-token set-make-token-name ;
: external ( -- ) ['] make-external-token to make-token-name ;
alias copyright: copyright:
: defer \ name ( -- ) \ Compiling
crash-site @ set-lookup-pointer \ Deferred token points to 'crash'
define-local: [ also tokens ] b(defer) [ previous ]
: constant \ name ( -- ) \ Compiling ( -- n ) \ Executing
start-local-token ( n ) #constants inc
[ also tokens ] b(constant) [ previous ]
: value \ name ( -- ) \ Compiling ( -- n ) \ Executing
start-local-token ( n ) #values inc
[ also tokens ] b(value) [ previous ]
: variable \ name ( -- ) \ Compiling ( -- adr ) \ Executing
start-local-token #variables inc
[ also tokens ] b(variable) [ previous ]
\ Override certain Forth words in interpret state
\ We only allow 'create' in interpret state, for creating data tables
: create \ name ( -- ) \ This 'create' for interpreting only
[ also tokens ] b(create) [ previous ]
: buffer: \ name ( -- ) \ Tokenizing ( -- buff-adr ) \ Executing
start-local-token #buffers inc
[ also tokens ] b(buffer:) [ previous ]
\ Although ' is only allowed in interpret state, we can still make it a
\ valid target of itself because it results in the same thing as [']
[ also tokens ] b(') [ previous ]
[ also tokens ] b(:) [ previous ]
: dict-msg ( -- ) ." Dictionary storage is restricted. " where ;
: allot ( #bytes -- ) ." ALLOT - " dict-msg ;
\ New STRUCT structure words
: struct ( -- ) [ also tokens ] 0 [ previous ] ;
: field \ name ( -- ) \ Tokenizing ( struct-adr -- field-adr ) \ Executing
[ also tokens ] b(field) [ previous ]
: vocab-msg ." Vocabulary changing is not allowed. " where ;
\ : only vocab-msg ; \ Escape below with 'only'
: definitions vocab-msg ;
\ Save dangerous defining words for last
: : \ name ( -- ) \ New version of : to create new tokens
!csp \ save stack so ";" can check it
start-local-token colon-cf
only forth also tokenizer also definitions
\ Initialize prior to executing tokenize
\ Support routines: We want to be able to clear the dictionary
\ after we're done so that we can do multiple invocations of
\ tokenize from within a single invocation of the tokenizer.
create tkz-marker-cmnd ," marker tkz-barrier"
: set-tkz-marker ( -- ) tkz-marker-cmnd count eval ;
: clear-tkz-marker ( -- ) tkz-marker-cmnd count 7 /string eval ;
[ reforth ] headers [ tokenizer ]
first-local-escape local-escape !
\ Cleanup after executing tokenize
\ Show final compilation statistics
: .statistic ( $adr,len vble-addr -- )
" :Version 1 FCodes compiled (obsolete FCodes)"
" :Version 1 FCodes compiled"
" :Version 2.0 FCodes compiled (may require version 2 bootprom)"
" :Version 2.1 FCodes compiled (may require version 2.3 bootprom)"
" :Version 2.2 FCodes compiled (may require version 2.4 bootprom)"
" :Version 2.3 FCodes compiled (may require version 2.6 bootprom)"
" :Version 3 FCodes compiled (may require version 3 bootprom)"
" :Obsolete FCodes compiled (may not work on version 3 bootproms)"
: end0 ( -- ) \ Intentional redefinition
cr ." END0 encountered." cr
tokenization-error @ 0= if .statistics then
compiling @ 0= if 1 #end0s +! else #end0s off then
: .stat ( $adr,len vble-addr -- )
" Literals " #literals .stat
" Non-(lit) Primitives" #primitives .stat
" Application Codes" #apps .stat
" Local Codes Created" #locals .stat
" Variables" #variables .stat
" Constants" #constants .stat
" Buffer:s" #buffers .stat
: write-header ( -- ) header d# 32 ofd @ fputs ; \ don't affect checksum
: full-size ( -- size ) \ Entire file, except a.out header
ofd @ ftell aout-header? @ if d# 32 - then
: fcode-size ( -- size ) \ fcode-versionx thru end0 ONLY
??cr ." *** Warning: FCode token END0 is missing at the end of the file. ***" cr
fcode-size checksumloc @ 2+ patch-long
h# ffff and checksumloc @ patch-word
aout-header? @ if full-size 4 patch-long then
create symtab 4 , 5 c, 0 c, 0 w, 0 , 0 w, 0 c,
[ tokens ] Fcode-version1 [ tokenizer ]
[ tokens ] Fcode-version2 [ tokenizer ]
[ tokens ] Fcode-version3 [ tokenizer ]
variable append-label? append-label? off
symtab /symtab ofd @ fputs ( )
bl word label-string "copy ( )
label-string dup c@ dup >r ( adr len )
label-string r> 2+ ofd @ fputs ( )
: .fcode-vers-sb-first ( -- )
true abort" Fcode-version# should be the first FCode command!"
only forth also tokenizer also forth definitions
: patch-pci-byte ( byte offset -- )
aout-header? @ if d# 32 + then
fhere >r \ Save current file pointer
ofd @ fseek \ Move back to 'addr' location
r> ofd @ fseek \ Restore current file pointer
: patch-pci-word-le ( w offset -- )
>r wbsplit swap r@ patch-pci-byte
: set-pci-fcode-size ( -- )
fcode-size h# 200 round-up h# 200 / ( size%512 )
: pci-code-revision ( w -- )
pci-prom? 0= if drop exit then
." PCI Code Revision value too large. Must be a 2-byte value, "
." truncating to h#" dup .x cr
: pci-vpd-offset ( w -- )
pci-prom? 0= if drop exit then
." PCI VPD Offset value too large. Must be a 2-byte value, "
." truncating to h#" dup .x cr
d# 100 buffer: output-name-buf
\ Remove the filename extension if there is one in the last pathname component
: ?shorten-name ( input-file$ -- file$ )
begin dup while ( adr len adr len' )
1- 2dup + c@ case ( adr len adr len' )
\ Stop if we encounter "/" or "\" before a "."
ascii / of 2drop exit endof
ascii \ of 2drop exit endof
ascii . of 2swap 2drop exit endof
repeat ( adr len adr len' )
: synthesize-name ( input-file$ -- input-file$ output-file$ )
2dup ?shorten-name output-name-buf $cat
" .fc" output-name-buf $cat
: ?arg ( $len tokenizer? -- )
." tokenize input-filename"
if ." [ output-filename ]" then
: check-args ( input-file$ output-file$ -- )
dup 0= if 2drop synthesize-name then
: save$3 ( adr len -- pstr ) string3 pack ;
cr ." Output file not generated"
\ Generate common text for Tokenizer and De-Tokenizer Version display.
string-array tkz-version-string
," Copyright 1996-2006 Sun Microsystems, Inc. All Rights Reserved"
," Use is subject to license terms."
: .inp-fil ( $adr,len -- )
: .outp-fil ( $adr,len -- )
: .tokenizer-version ( inp-flnm$ outp-flnm$ -- inp-flnm$ outp-flnm$ )
['] tkz-version-string /string-array
0 do i tkz-version-string ". cr loop
: .detokenizer-version ( -- ) \ <input-filename> (but does not consume it.)
." \ FCode Detokenizer" 0 tkz-version-string ". cr
['] tkz-version-string /string-array
1 do ." \ " i tkz-version-string ". cr loop
only forth also tokenizer also forth definitions
\ The real nitty-gritty work of the tokenizer.
\ In order to get messages for all our errors,
\ we need a substitute for $do-undefined
\ Of course, we'll put it back when we're done...
: $tok-interpret-do-undefined
: (tokenize) ( input-filename$adr,len -- error? )
['] $do-undefined behavior >r
['] $tok-interpret-do-undefined
['] included catch ( n1 n2 error# | false )
?dup if .error 2drop true
else tokenization-error @
: $tokenize ( input-filename$ output-filename$ -- )
xref-init if 2swap xref-push-file 2swap xref-on then
\ Define the TOKENIZER? symbol so code can check against it.
0 0 " TOKENIZER?" [set-symbol]
['] .fcode-vers-sb-first is header
['] .fcode-vers-sb-first is do-literal
save$3 new-file ( input$ )
aout-header? @ if write-header then ( input$ )
\ Save the current stack depth
\ (now counting input$ ; later counting error? and the old depth)
\ Compare the current SP against the previous one
dup if ." Error: Stack depth changed" cr
cr ." Fatal error: Obsolete version 1 tokens used"
cr ." Output file not generated"
pci-prom? if set-pci-fcode-size false to pci-prom? then
fix-header \ !!! fix header last so checksum is correct.
: tokenize ( -- ) \ input-filename output-filename
parse-word parse-word $tokenize
only forth also tokenizer also forth definitions
\ Make the following variables available in vocabulary forth
alias append-label? append-label?
alias aout-header? aout-header?
alias offset-8? offset-8?
: pci-header ( vendor-id device-id class-code -- ) \ Generate ROM header
." Only one PCI Header is allowed"
\ The device-id and vendor-id should be 2-byte (word) values.
\ The class-code is a 3-byte value. This method will check that
\ the values passed in are not too big, but will not report a
\ problem if they are too small...
( vendor-id device-id class-code )
dup h# ff00.0000 and 0<> if ( vendor-id device-id class-code )
." Class-code value too large. Must be a 3-byte value!" cr
r> drop true >r ( vendor-id device-id class-code )
then ( vendor-id device-id class-code )
( vendor-id device-id class-code )
over h# ffff.0000 and 0<> if
." Device-id value too large. Must be a 2-byte value!" cr
r> drop true >r ( vendor-id device-id class-code )
( vendor-id device-id class-code )
rot dup h# ffff.0000 and 0<> if ( device-id class-code vendor-id )
." Vendor-id value too large. Must be a 2-byte value!" cr
r> drop true >r ( device-id class-code vendor-id )
then ( device-id class-code vendor-id )
r> if 3drop exit then ( device-id class-code vendor-id )
rot swap ( class-code device-id vendor-id )
\ Preliminaries out of the way, now to build the header...
( class-code device-id vendor-id )
55 emit-byte aa emit-byte ( class-code device-id vendor-id ) \ PCI magic number
34 emit-byte 00 emit-byte ( class-code device-id vendor-id ) \ Start of FCode
14 0 do 0 emit-byte loop ( class-code device-id vendor-id )
1c emit-byte 00 emit-byte ( class-code device-id vendor-id )
00 emit-byte 00 emit-byte ( class-code device-id vendor-id ) \ Start of PCI Data Structure:
ascii P emit-byte ( class-code device-id vendor-id ) \ PCIR string
ascii C emit-byte ( class-code device-id vendor-id )
ascii I emit-byte ( class-code device-id vendor-id )
ascii R emit-byte ( class-code device-id vendor-id )
\ Now we consume the vendor-id
wbsplit swap ( class-code device-id vend-hi vend-lo )
emit-byte emit-byte ( class-code device-id )
\ Now we consume the device-id
wbsplit swap ( class-code dev-hi dev-lo )
emit-byte emit-byte ( class-code )
00 emit-byte 00 emit-byte ( class-code ) \ 2 VPD
18 emit-byte 00 emit-byte ( class-code ) \ 2 DS len
00 emit-byte ( class-code ) \ 1 rev
\ Now we consume the class-code
lwsplit swap ( class-up class-lo )
wbsplit swap ( class-up class-lohi class-lolo )
emit-byte emit-byte ( class-up )
wbsplit swap ( class-uphi class-uplo )
\ Now finish off the header
10 emit-byte 00 emit-byte ( ) \ 2 image len XXX - We can't know this yet
01 emit-byte 00 emit-byte ( ) \ 2 rev of code
01 emit-byte ( ) \ 1 code type
80 emit-byte ( ) \ 1 indicator
00 emit-byte 00 emit-byte ( ) \ 2 reserved
fload ${BP}/pkg/fcode/detokeni.fth \ Detokenizer
" No new words defined yet." $create
warning on \ Set the default state before saving forth image.
projects / OpenSPARC-T2-SAM / blob