aboutsummaryrefslogtreecommitdiff
path: root/j1demo/firmware/crossj1.fs
diff options
context:
space:
mode:
authorDimitri Sokolyuk <demon@dim13.org>2019-10-30 20:04:56 +0100
committerDimitri Sokolyuk <demon@dim13.org>2019-10-30 20:04:56 +0100
commita76977af62010a392c16010c367185e61e856ffe (patch)
tree56cf4177d5bc0e3ead781d1c60818c13b1df0f3c /j1demo/firmware/crossj1.fs
parentc0165d167d7cb40d80028bcf7a4a6b160b5a7e83 (diff)
mv to docs
Diffstat (limited to 'j1demo/firmware/crossj1.fs')
-rw-r--r--j1demo/firmware/crossj1.fs527
1 files changed, 0 insertions, 527 deletions
diff --git a/j1demo/firmware/crossj1.fs b/j1demo/firmware/crossj1.fs
deleted file mode 100644
index d034611..0000000
--- a/j1demo/firmware/crossj1.fs
+++ /dev/null
@@ -1,527 +0,0 @@
-( Cross-compiler for the J1 JCB 13:12 08/24/10)
-decimal
-
-( outfile is fileid or zero JCB 12:30 11/27/10)
-
-0 value outfile
-
-: type ( c-addr u )
- outfile if
- outfile write-file throw
- else
- type
- then
-;
-: emit ( u )
- outfile if
- pad c! pad 1 outfile write-file throw
- else
- emit
- then
-;
-: cr ( u )
- outfile if
- s" " outfile write-line throw
- else
- cr
- then
-;
-: space bl emit ;
-: spaces dup 0> if 0 do space loop then ;
-
-vocabulary j1assembler \ assembly storage and instructions
-vocabulary metacompiler \ the cross-compiling words
-vocabulary j1target \ actual target words
-
-: j1asm
- only
- metacompiler
- also j1assembler definitions
- also forth ;
-: meta
- only
- j1target also
- j1assembler also
- metacompiler definitions also
- forth ;
-: target
- only
- metacompiler also
- j1target definitions ;
-
-\ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
-
-j1asm
-
-: tcell 2 ;
-: tcells tcell * ;
-: tcell+ tcell + ;
-65536 allocate throw constant tflash
-
-: h#
- base @ >r 16 base !
- 0. bl parse >number throw 2drop postpone literal
- r> base ! ; immediate
-
-variable tdp
-: there tdp @ ;
-: islegal dup h# 7fff u> abort" illegal address" ;
-: tc! islegal tflash + c! ;
-: tc@ islegal tflash + c@ ;
-: t! islegal over h# ff and over tc! swap 8 rshift swap 1+ tc! ;
-: t@ islegal dup tc@ swap 1+ tc@ 8 lshift or ;
-: talign tdp @ 1 + h# fffe and tdp ! ;
-: tc, there tc! 1 tdp +! ;
-: t, there t! tcell tdp +! ;
-: org tdp ! ;
-
-tflash 65536 255 fill
-
-65536 cells allocate throw constant references
-: referenced cells references + 1 swap +! ;
-
-65536 cells allocate throw constant labels
-labels 65536 cells 0 fill
-: atlabel? ( -- f = are we at a label )
- labels there cells + @ 0<>
-;
-
-: preserve ( c-addr1 u -- c-addr )
- dup 1+ allocate throw dup >r
- 2dup c! 1+
- swap cmove r> ;
-
-: setlabel ( c-addr u -- )
- atlabel? if 2drop else preserve labels there cells + ! then ;
-
-j1asm
-
-: hex-literal ( u -- c-addr u ) s>d <# bl hold #s [char] $ hold #> ;
-
-: imm h# 8000 or t, ;
-
-: T h# 0000 ;
-: N h# 0100 ;
-: T+N h# 0200 ;
-: T&N h# 0300 ;
-: T|N h# 0400 ;
-: T^N h# 0500 ;
-: ~T h# 0600 ;
-: N==T h# 0700 ;
-: N<T h# 0800 ;
-: N>>T h# 0900 ;
-: T-1 h# 0a00 ;
-: rT h# 0b00 ;
-: [T] h# 0c00 ;
-: N<<T h# 0d00 ;
-: dsp h# 0e00 ;
-: Nu<T h# 0f00 ;
-
-: T->N h# 0080 or ;
-: T->R h# 0040 or ;
-: N->[T] h# 0020 or ;
-: d-1 h# 0003 or ;
-: d+1 h# 0001 or ;
-: r-1 h# 000c or ;
-: r-2 h# 0008 or ;
-: r+1 h# 0004 or ;
-
-: alu h# 6000 or t, ;
-
-: return T h# 1000 or r-1 alu ;
-: ubranch 2/ h# 0000 or t, ;
-: 0branch 2/ h# 2000 or t, ;
-: scall 2/ h# 4000 or t, ;
-
-: dump-words ( c-addr n -- ) \ Write n/2 words from c-addr
- dup 6 > abort" invalid byte count"
- 2/ dup >r
- 0 do
- dup t@ s>d <# # # # # #> type space
- 2 +
- loop drop
- 3 r> - 5 * spaces
-;
-
-variable padc
-: pad+ ( c-addr u -- ) \ append to pad
- dup >r
- pad padc @ + swap cmove
- r> padc +! ;
-
-: pad+loc ( addr -- )
- dup cells labels + @ ?dup if
- nip count pad+
- else
- s>d <# #s [char] $ hold #> pad+
- then
- s" " pad+
-;
-
-
-: disassemble-j
- 0 padc !
- dup t@ h# 8000 and if
- s" LIT " pad+
- dup t@ h# 7fff and hex-literal pad+ exit
- else
- dup t@ h# e000 and h# 6000 = if
- s" ALU " pad+
- dup t@ pad+loc exit
- else
- dup t@ h# e000 and h# 4000 = if
- s" CALL "
- else
- dup t@ h# 2000 and if
- s" 0BRANCH "
- else
- s" BRANCH "
- then
- then
- pad+
- dup t@ h# 1fff and 2* pad+loc
- then
- then
-;
-
-: disassemble-line ( offset -- offset' )
- dup cells labels + @ ?dup if s" \ " type count type cr then
- dup s>d <# # # # # #> type space
- dup 2 dump-words
- disassemble-j
- pad padc @ type
- 2 +
- cr
-;
-
-: disassemble-block
- 0 do
- disassemble-line
- loop
- drop
-;
-
-j1asm
-
-\ tcompile is like "STATE": it is true when compiling
-
-variable tcompile
-: tcompile? tcompile @ ;
-: +tcompile tcompile? abort" Already in compilation mode" 1 tcompile ! ;
-: -tcompile 0 tcompile ! ;
-
-: (literal)
- \ dup $f rshift over $e rshift xor 1 and throw
- dup h# 8000 and if
- h# ffff xor recurse
- ~T alu
- else
- h# 8000 or t,
- then
-
-;
-: (t-constant)
- tcompile? if
- (literal)
- then
-;
-
-meta
-
-\ Find name - without consuming it - and return a counted string
-: wordstr ( "name" -- c-addr u )
- >in @ >r bl word count r> >in !
-;
-
-
-: literal (literal) ; immediate
-: 2literal swap (literal) (literal) ; immediate
-: call,
- dup referenced
- scall
-;
-
-: t:
- talign
- wordstr setlabel
- create
- there ,
- +tcompile
- 947947
- does>
- @
- tcompile? if
- call,
- then
-;
-
-: lookback ( offset -- v ) there swap - t@ ;
-: prevcall? 2 lookback h# e000 and h# 4000 = ;
-: call>goto dup t@ h# 1fff and swap t! ;
-: prevsafe?
- 2 lookback h# e000 and h# 6000 = \ is an ALU
- 2 lookback h# 004c and 0= and ; \ does not touch RStack
-: alu>return dup t@ h# 1000 or r-1 swap t! ;
-
-: t; 947947 <> if abort" Unstructured" then
- true if
- atlabel? invert prevcall? and if
- there 2 - call>goto
- else
- atlabel? invert prevsafe? and if
- there 2 - alu>return
- else
- return
- then
- then
- else
- return
- then
- -tcompile
-;
-
-: t;fallthru 947947 <> if abort" Unstructured" then
- -tcompile
-;
-
-variable shadow-tcompile
-wordlist constant escape]-wordlist
-escape]-wordlist set-current
-: ] shadow-tcompile @ tcompile ! previous previous ;
-
-meta
-
-: [
- tcompile @ shadow-tcompile !
- -tcompile get-order forth-wordlist escape]-wordlist rot 2 + set-order
-;
-
-: : t: ;
-: ; t; ;
-: ;fallthru t;fallthru ;
-: , t, ;
-: c, tc, ;
-
-: constant ( n "name" -- ) create , immediate does> @ (t-constant) ;
-
-: ]asm
- -tcompile also forth also j1target also j1assembler ;
-: asm[ +tcompile previous previous previous ;
-: code t: ]asm ;
-
-j1asm
-
-: end-code
- 947947 <> if abort" Unstructured" then
- previous previous previous ;
-
-meta
-
-\ Some Forth words are safe to use in target mode, so import them
-
-: ( postpone ( ;
-: \ postpone \ ;
-
-: import ( "name" -- )
- >in @ ' swap >in !
- create , does> @ execute ;
-
-import meta
-import org
-import include
-import [if]
-import [else]
-import [then]
-
-: do-number ( n -- |n )
- state @ if
- postpone literal
- else
- tcompile? if
- (literal)
- then
- then
-;
-
-decimal
-
-: [char] ( "name" -- ) ( run: -- ascii) char (literal) ;
-
-: ['] ( "name" -- ) ( run: -- xt )
- ' tcompile @ >r -tcompile execute r> tcompile !
- dup referenced
- (literal)
-;
-
-: (sliteral--h) ( addr n -- ptr ) ( run: -- eeaddr n )
- s" sliteral" evaluate
- there >r
- dup tc,
- 0 do count tc, loop
- drop
- talign
- r>
-;
-
-: (sliteral) (sliteral--h) drop ;
-: s" ( "ccc<quote>" -- ) ( run: -- eaddr n ) [char] " parse (sliteral) ;
-: s' ( "ccc<quote>" -- ) ( run: -- eaddr n ) [char] ' parse (sliteral) ;
-
-: create
- wordstr setlabel
- create there ,
- does> @ do-number
-;
-
-: allot tdp +! ;
-
-: variable wordstr setlabel create there , 0 t,
- does> @ do-number ;
-: 2variable wordstr setlabel create there , 0 t, 0 t,
- does> @ do-number ;
-
-: createdoes
- wordstr setlabel
- create there , ' ,
- does> dup @ dup referenced (literal) cell+ @ execute
-;
-
-: jumptable
- wordstr setlabel
- create there ,
- does> s" 2*" evaluate @ dup referenced (literal) s" + @" evaluate
-;
-
-: | ' execute dup referenced t, ;
-
-: ', ' execute t, ;
-
-( DEFER JCB 11:18 11/12/10)
-
-: defer
- wordstr setlabel
- create there , 0 t,
- does> @ tcompile? if do-number s" @ execute" evaluate then ;
-
-: is ( xt "name" -- )
- tcompile? if
- ' >body @ do-number
- s" ! " evaluate
- else
- ' execute t!
- then ;
-
-: ' ' execute ;
-
-( VALUE JCB 13:06 11/12/10)
-
-: value
- wordstr setlabel
- create there , t,
- does> @ do-number s" @" evaluate ;
-
-: to ( u "name" -- )
- ' >body @ do-number s" !" evaluate ;
-
-( ARRAY JCB 13:34 11/12/10)
-
-: array
- wordstr setlabel
- create there , 0 do 0 t, loop
- does> s" cells" evaluate @ do-number s" +" evaluate ;
-: 2array
- wordstr setlabel
- create there , 2* 0 do 0 t, loop
- does> s" 2* cells" evaluate @ do-number s" +" evaluate ;
-
-( eforth's way of handling constants JCB 13:12 09/03/10)
-
-: sign>number
- over c@ [char] - = if
- 1- swap 1+ swap
- >number
- 2swap dnegate 2swap
- else
- >number
- then
-;
-
-: base>number ( caddr u base -- )
- base @ >r base !
- sign>number
- r> base !
- dup 0= if
- 2drop drop do-number
- else
- 1 = swap c@ [char] . = and if
- drop dup do-number 16 rshift do-number
- else
- -1 abort" bad number"
- then
- then ;
-
-: d# 0. bl parse 10 base>number ;
-: h# 0. bl parse 16 base>number ;
-
-( Conditionals JCB 13:12 09/03/10)
-: if
- there
- 0 0branch
-;
-
-: resolve
- dup t@ there 2/ or swap t!
-;
-
-: then
- resolve
- s" (then)" setlabel
-;
-
-: else
- there
- 0 ubranch
- swap resolve
- s" (else)" setlabel
-;
-
-
-: begin s" (begin)" setlabel there ;
-: again
- ubranch
-;
-: until
- 0branch
-;
-: while
- there
- 0 0branch
-;
-: repeat
- swap ubranch
- resolve
- s" (repeat)" setlabel
-;
-
-: 0do s" >r d# 0 >r" evaluate there s" (do)" setlabel ;
-: do s" 2>r" evaluate there s" (do)" setlabel ;
-: loop
- s" looptest" evaluate 0branch
-;
-: i s" r@" evaluate ;
-
-77 constant sourceline#
-s" none" 2constant sourcefilename
-
-: line# sourceline# (literal) ;
-create currfilename 1 cells 80 + allot
-variable currfilename#
-: savestr ( c-addr u dst -- ) 2dup c! 1+ swap cmove ;
-: getfilename sourcefilename currfilename count compare 0<>
- if
- sourcefilename 2dup currfilename savestr (sliteral--h) currfilename# !
- else
- currfilename# @ dup 1+ (literal) tc@ (literal)
- then ;
-: snap line# getfilename s" (snap)" evaluate ; immediate
-: assert 0= if line# sourcefilename (sliteral) s" (assert)" evaluate then ; immediate