Permalink
Fetching contributors…
Cannot retrieve contributors at this time
541 lines (446 sloc) 10.3 KB
\ meta.fs
\
\ Copyright (c) 2009 Openmoko Inc.
\
\ Authors Christopher Hall <hsw@openmoko.com>
\
\ Redistribution and use in source and binary forms, with or without
\ modification, are permitted provided that the following conditions are
\ met:
\
\ 1. Redistributions of source code must retain the above copyright
\ notice, this list of conditions and the following disclaimer.
\
\ 2. Redistributions 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.
\
\ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY
\ EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
\ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
\ PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE CONTRIBUTORS BE LIABLE
\ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
\ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
\ SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
\ BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
\ WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
\ OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
\ IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
forth definitions
vocabulary meta-compiler immediate
vocabulary meta-words immediate
vocabulary meta-interpret immediate
vocabulary meta-assemble immediate
\ word for meta compiler
only forth
also meta-compiler definitions
variable label-count
variable meta-state
variable suppress-once
: tab 9 emit ;
: getline
refill 0= abort" premature EOF"
;
variable cross-dict-flag
: cross-dict-name ( -- )
cross-dict-flag @
0 cross-dict-flag !
case
0 of
." forth_dict"
endof
1 of
." root_dict"
endof
endcase
space ;
: gen-label ( -- n )
1 label-count +! label-count @ ;
: type-nodash ( c-addr u -- )
0 ?do
dup c@ dup [char] - = if
drop [char] _
then
emit
char+
loop drop ;
: escaped-type ( c-addr u -- )
0 ?do
dup c@ dup case
[char] " of
drop
[char] \ emit [char] 0 emit
[char] 4 emit [char] 2 emit
endof
[char] \ of
drop
[char] \ dup emit emit
endof
[char] ; of
drop
." \073"
endof
emit
endcase
char+
loop drop ;
: hex. ( u -- ) base @ >r hex ." 0x" u. r> base ! ;
: .long ( -- ) tab ." .long" tab ;
: .byte ( -- ) tab ." .byte" tab ;
: suppress true suppress-once ! ;
: output-symbol-pre ( -- f )
suppress-once @ 0= dup if
.long
then ;
: output-symbol-post ( f -- )
if cr then
false suppress-once ! ;
: output-symbol" ( string<quote> -- )
postpone output-symbol-pre
postpone ."
postpone output-symbol-post
; immediate
: .lstring ( -- \ "<string>" )
tab ." LSTRING" tab 34 emit
[char] " parse escaped-type 34 emit cr ;
: _number ( s-addr -- u \ number )
base @ >r \ R: base
>r 0 dup r> count \ ud c-addr u
over c@ \ ud c-addr u
0 >r \ R: 0 (positive)
case
[char] + of swap char+ swap 1- endof
[char] - of swap char+ swap 1- r> drop 1 >r endof
[char] % of swap char+ swap 1- 2 base ! endof
[char] & of swap char+ swap 1- 8 base ! endof
[char] # of swap char+ swap 1- 10 base ! endof
[char] $ of swap char+ swap 1- 16 base ! endof
endcase
\ ud c-addr u R: base sign
>number ( d c-addr u )
?dup if
." .error " 34 emit ." ***INVALID: " type 34 emit cr -1
\ ." >>" type 2drop true abort" invalid number"
then
2drop
r> if negate then
r> base !
;
: _interpret ( -- )
false meta-state ! ;
: _compile ( -- )
true meta-state ! ;
: _literal ( u -- )
.long ." paren_lit_paren, " . cr ;
variable last-parsed-word-xt
: quoted-parse-word ( flag -- )
0 last-parsed-word-xt !
parse-word 2dup
34 emit
escaped-type
34 emit
space
['] meta-words >body
search-wordlist if
suppress dup last-parsed-word-xt ! execute
else
." !!ERROR: not found in symbol.fi!!"
then
space
if
last-parsed-word-xt @ ?dup if
." flags_"
suppress execute
then
else
." 0"
then
cr
;
: set-flags-to-zero ( -- )
last-parsed-word-xt @ ?dup if
." flags_"
suppress execute
." = 0" cr
then
;
: meta-constant ( C: x "<spaces>name" -- ) ( -- x )
>r get-order get-current
only postpone forth also postpone meta-interpret
definitions
r> constant
set-current set-order ;
: meta-compile ( -- )
." ;;; Meta Compiler starting" cr
begin
\ cr ." >> "
bl word dup count nip if
\ dup count 34 emit type 34 emit bl emit
meta-state @ if \ compiling
only [compile] meta-words
also [compile] meta-assemble
find if
execute
else
_number _literal
then
else \ interpreting
only [compile] forth
also [compile] meta-interpret
find if
execute
else
_number
then
then
else
drop
refill 0= if
." ;;; Meta Compiler exiting" cr cr
only [compile] forth
exit
then
then
again
;
\ words that are more than just a simple print
\ these override the meta-words versions
\ used in interpret mode
only forth
also meta-interpret definitions
meta-compiler
\ the next definition will be in this dictionary
: cross-root-definition ( -- ) 1 cross-dict-flag ! ;
: :: ( -- \ word )
parse-word 2drop ;
: code ( -- \ string )
cr
tab ." CODE" tab cross-dict-name
true quoted-parse-word
\ rest of line is ignored
begin
getline
tib #tib @ s" end-code" str= 0= while
tib c@ [char] \ =
if ." ;;; " then
tib #tib @ type cr
repeat
getline
tab ." END_CODE" cr
set-flags-to-zero
;
: ] ( -- ) _compile ;
: : ( -- \ word )
cr
tab ." COLON" tab cross-dict-name
true quoted-parse-word
_compile
;
: constant ( x -- \ word )
cr
tab ." CONSTANT" tab cross-dict-name
dup constant
latestxt >name cell+ dup cell+ swap @ 255 and
34 emit
escaped-type
34 emit
parse-word 2drop parse-word 2drop \ ignore :: <word>
space
latestxt >name cell+ dup cell+ swap @ 255 and
['] meta-words >body
search-wordlist if
suppress execute ." 0"
else
." !!ERROR: not found in symbol.fi!!
then
cr .long . cr
;
: forth ;
: c33 ;
: only ;
: also ;
: variable ( -- \ word )
cr
tab ." VARIABLE" tab cross-dict-name
false quoted-parse-word
.long 0 . cr
;
: create ( -- \ word )
cr
tab ." CREATE" tab cross-dict-name
false quoted-parse-word
;
: <',> ( -- \ word)
get-order
only postpone meta-words
bl word
find if
execute
else
." .error ***unknown***" cr
then
set-order
;
: allot ( u -- )
3 + 4 /
tab ." .rept" tab . cr
.long 0 . cr
tab ." .endr" cr
;
: , ( u -- )
.long hex. cr
;
: c, ( u -- )
.byte hex. cr
;
: immediate ( -- )
last-parsed-word-xt @ ?dup if
dup
." flags_" suppress execute ." = "
." flags_" suppress execute ." + FLAG_IMMEDIATE"
cr
then ;
: compile-only ( -- )
last-parsed-word-xt @ ?dup if
dup
." flags_" suppress execute ." = "
." flags_" suppress execute ." + FLAG_COMPILE_ONLY"
cr
then ;
\ should not be here **************************************************
: literal ( u -- ) _literal ;
: cells ( u -- u ) 4 * ;
: cell+ ( u -- u ) 4 + ;
: cell- ( u -- u ) 4 - ;
\ word that are more than just a simple print
\ these override the meta-words versions
\ used in compile/assembly generation mode
only forth
also meta-assemble definitions
meta-compiler
: :: ( -- \ word )
parse-word 2drop ;
: .( ( -- \ string )
[char] ) parse type ;
: [char] ( -- c \ word)
char _literal ;
: [ctrl] ( -- c \ word)
char 31 and _literal ;
: literal ( u -- ) _literal ;
: ; .long ." exit" cr
tab ." END_COLON" cr
set-flags-to-zero
_interpret ;
: [ ( -- )
_interpret ;
: do ( -- dest label )
gen-label dup
.long ." paren_do_paren, L" . cr
." L" gen-label dup . [char] : emit cr ;
: ?do ( -- dest label )
gen-label dup
.long ." paren_question_do_paren, L" . cr
." L" gen-label dup . [char] : emit cr ;
: loop ( dest label -- )
.long ." paren_loop_paren, L" . cr
." L" . [char] : emit cr ;
: +loop ( dest label -- )
.long ." paren_plus_loop_paren, L" . cr
." L" . [char] : emit cr ;
: begin ( -- label )
." L" gen-label dup . [char] : emit cr ;
: again ( label -- )
.long ." branch, L" . cr ;
: while ( dest -- origin dest )
.long ." question_branch, L" gen-label dup . cr swap ;
: until ( dest -- )
.long ." question_branch, L" . cr ;
: repeat ( origin dest -- )
.long ." branch, L" . cr
." L" . [char] : emit cr ;
: if ( -- label )
.long ." question_branch, L" gen-label dup . cr ;
: then ( -- label )
." L" . [char] : emit cr ;
: else ( label -- label )
.long ." branch, L" gen-label dup . cr
swap
." L" . [char] : emit cr ;
: case ( -- 0 )
0 ;
: of ( -- <if> )
.long ." over, equals" cr
.long ." question_branch, L" gen-label dup . cr
.long ." drop" cr
;
: endof ( <if> -- <else> )
.long ." branch, L" gen-label dup . cr
swap
." L" . [char] : emit cr
;
: endcase ( 0 <if>*n -- )
.long ." drop" cr
begin
?dup
while
." L" . [char] : emit cr
repeat
;
: ['] ( -- \ word)
get-order
only postpone meta-words
bl word
find if
.long ." paren_lit_paren, "
suppress
execute
cr
else
." .error ***unknown***" cr
then
set-order
;
: postpone ( -- \ word)
get-order
only [compile] meta-words
bl word
find case
1 of
execute
endof
-1 of
.long ." paren_lit_paren, "
suppress
execute
." , compile_comma" cr
endof
." .error ****unknown***" cr
endcase
set-order
;
: ( ( -- \ comment )
[char] ) parse 2drop ;
: \ ( -- \ comment )
getline ;
: ." ( -- \ "<string>" )
.long ." paren_s_quote_paren" cr
.lstring
.long ." type" cr
;
: lcd-." ( -- \ "<string>" )
.long ." paren_s_quote_paren" cr
.lstring
.long ." lcd_type" cr
;
: s" ( "string" -- )
.long ." paren_s_quote_paren" cr
.lstring
;
: abort" ( -- \ "<string>" )
.long ." question_branch, L" gen-label dup . cr
.long ." paren_s_quote_paren" cr
.lstring
.long ." type, abort" cr
." L" . [char] : emit cr
;