Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

541 lines (446 sloc) 10.537 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
;
Jump to Line
Something went wrong with that request. Please try again.