From cf01b391440fc9de43597b907acfc22dba1aa15e Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Sun, 18 Jun 2017 14:38:03 +0200 Subject: Add j1 --- j1 | 1 - j1/toolchain/basewords.fs | 92 +++++++ j1/toolchain/cross.fs | 321 ++++++++++++++++++++++++ j1/toolchain/demo1.fs | 7 + j1/toolchain/dump.py | 36 +++ j1/toolchain/go | 3 + j1/toolchain/nuc.fs | 604 ++++++++++++++++++++++++++++++++++++++++++++++ j1/toolchain/strings.fs | 25 ++ 8 files changed, 1088 insertions(+), 1 deletion(-) delete mode 160000 j1 create mode 100644 j1/toolchain/basewords.fs create mode 100644 j1/toolchain/cross.fs create mode 100644 j1/toolchain/demo1.fs create mode 100644 j1/toolchain/dump.py create mode 100644 j1/toolchain/go create mode 100644 j1/toolchain/nuc.fs create mode 100644 j1/toolchain/strings.fs (limited to 'j1/toolchain') diff --git a/j1 b/j1 deleted file mode 160000 index 9114396..0000000 --- a/j1 +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 911439641c002a8f7a6e306ce1b1d3fd4b389fd6 diff --git a/j1/toolchain/basewords.fs b/j1/toolchain/basewords.fs new file mode 100644 index 0000000..6534d2b --- /dev/null +++ b/j1/toolchain/basewords.fs @@ -0,0 +1,92 @@ +( J1 base words implemented in assembler JCB 17:27 12/31/11) + +: 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# 0900 ; +: N<N h# 0010 or ; +: T->R h# 0020 or ; +: N->[T] h# 0030 or ; +: N->io[T] h# 0040 or ; +: RET h# 0080 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 ; + +: imm h# 8000 or tw, ; +: alu h# 6000 or tw, ; +: ubranch h# 0000 or tw, ; +: 0branch h# 2000 or tw, ; +: scall h# 4000 or tw, ; + + +:: noop T alu ; +:: + T+N d-1 alu ; +:: xor T^N d-1 alu ; +:: and T&N d-1 alu ; +:: or T|N d-1 alu ; +:: invert ~T alu ; +:: = N==T d-1 alu ; +:: < NN alu ; +:: dup T T->N d+1 alu ; +:: drop N d-1 alu ; +:: over N T->N d+1 alu ; +:: nip T d-1 alu ; +:: >r N T->R r+1 d-1 alu ; +:: r> rT T->N r-1 d+1 alu ; +:: r@ rT T->N d+1 alu ; +:: @ [T] alu ; +:: io@ io[T] alu ; +:: ! T N->[T] d-1 alu + N d-1 alu ; +:: io! T N->io[T] d-1 alu + N d-1 alu ; +:: rshift N>>T d-1 alu ; +:: lshift N<N d+1 alu ; +:: exit T RET r-1 alu ; + +\ Elided words +\ These words are supported by the hardware but are not +\ part of ANS Forth. They are named after the word-pair +\ that matches their effect +\ Using these elided words instead of +\ the pair saves one cycle and one instruction. + +:: 2dupand T&N T->N d+1 alu ; +:: 2dup< NN d+1 alu ; +:: 2dup= N==T T->N d+1 alu ; +:: 2dupor T|N T->N d+1 alu ; +:: 2duprshift N>>T T->N d+1 alu ; +:: 2dup+ T+N T->N d+1 alu ; +:: 2dupu< NuN d+1 alu ; +:: 2dupxor T^N T->N d+1 alu ; +:: dup>r T T->R r+1 alu ; +:: dup@ [T] T->N d+1 alu ; +:: overand T&N alu ; +:: over> N Nu[T] d-1 alu ; diff --git a/j1/toolchain/cross.fs b/j1/toolchain/cross.fs new file mode 100644 index 0000000..56c0025 --- /dev/null +++ b/j1/toolchain/cross.fs @@ -0,0 +1,321 @@ +( J1 Cross Compiler JCB 16:55 05/02/12) + +\ Usage gforth cross.fs +\ +\ Where machine.fs defines the target machine +\ and program.fs is the target program +\ + +variable lst \ .lst output file handle + +: h# + base @ >r 16 base ! + 0. bl parse >number throw 2drop postpone literal + r> base ! ; immediate + +: tcell 2 ; +: tcells tcell * ; +: tcell+ tcell + ; + +131072 allocate throw constant tflash \ bytes, target flash +131072 allocate throw constant _tbranches \ branch targets, cells +tflash 31072 0 fill +_tbranches 131072 0 fill +: tbranches cells _tbranches + ; + +variable tdp 0 tdp ! +: there tdp @ ; +: islegal ; +: tc! islegal tflash + c! ; +: tc@ islegal tflash + c@ ; +: tw! islegal tflash + w! ; +: t! islegal tflash + l! ; +: t@ islegal tflash + uw@ ; +: twalign tdp @ 1+ -2 and tdp ! ; +: talign tdp @ 3 + -4 and tdp ! ; +: tc, there tc! 1 tdp +! ; +: t, there t! 4 tdp +! ; +: tw, there tw! tcell tdp +! ; +: org tdp ! ; + +wordlist constant target-wordlist +: add-order ( wid -- ) >r get-order r> swap 1+ set-order ; +: :: get-current >r target-wordlist set-current : r> set-current ; + +next-arg included \ include the machine.fs + +( Language basics for target JCB 19:08 05/02/12) + +warnings off +:: ( postpone ( ; +:: \ postpone \ ; + +:: org org ; +:: include include ; +:: included included ; +:: marker marker ; +:: [if] postpone [if] ; +:: [else] postpone [else] ; +:: [then] postpone [then] ; + +: 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 tw, + then +; + +: literal + dup $80000000 and if + invert recurse + ~T alu + else + dup $ffff8000 and if + dup $F rshift recurse + $f recurse + N<in @ >r bl word count r> >in ! +; + +variable link 0 link ! + +:: header + twalign there + \ cr ." link is " link @ . + link @ tw, + link ! + bl parse + dup tc, + bounds do + i c@ tc, + loop + twalign +; + +:: : + hex + codeptr s>d + <# bl hold # # # # #> + lst @ write-file throw + wordstr lst @ write-line throw + + create codeptr , + does> @ scall +; + +:: :noname +; + +:: , + talign + t, +; + +:: allot + 0 ?do + 0 tc, + loop +; + +: shortcut ( orig -- f ) \ insn @orig precedes ;. Shortcut it. + \ call becomes jump + dup t@ h# e000 and h# 4000 = if + dup t@ h# 1fff and over tw! + true + else + dup t@ h# e00c and h# 6000 = if + dup t@ h# 0080 or r-1 over tw! + true + else + false + then + then + nip +; + +:: ; + there 2 - shortcut \ true if shortcut applied + there 0 do + i tbranches @ there = if + i tbranches @ shortcut and + then + loop + 0= if \ not all shortcuts worked + s" exit" evaluate + then +; +:: ;fallthru ; + +:: jmp + ' >body @ ubranch +; + +:: constant + create , + does> @ literal +; + +:: create + talign + create there , + does> @ literal +; + +( Switching between target and meta JCB 19:08 05/02/12) + +: target only target-wordlist add-order definitions ; +: ] target ; +:: meta forth definitions ; +:: [ forth definitions ; + +: t' bl parse target-wordlist search-wordlist 0= throw >body @ ; + +( eforth's way of handling constants JCB 13:12 09/03/10) + +: sign>number ( c-addr1 u1 -- ud2 c-addr2 u2 ) + 0. 2swap + over c@ [char] - = if + 1 /string + >number + 2swap dnegate 2swap + else + >number + then +; + +: base>number ( caddr u base -- ) + base @ >r base ! + sign>number + r> base ! + dup 0= if + 2drop drop literal + else + 1 = swap c@ [char] . = and if + drop dup literal 32 rshift literal + else + -1 abort" bad number" + then + then ; +warnings on + +:: d# bl parse 10 base>number ; +:: h# bl parse 16 base>number ; +:: ['] ' >body @ 2* literal ; +:: [char] char literal ; + +:: asm-0branch + ' >body @ + 0branch +; + +( Conditionals JCB 13:12 09/03/10) + +: resolve ( orig -- ) + there over tbranches ! \ forward reference from orig to this loc + dup t@ there 2/ or swap tw! +; + +:: if + there + 0 0branch +; + +:: then + resolve +; + +:: else + there + 0 ubranch + swap resolve +; + +:: begin there ; + +:: again ( dest -- ) + 2/ ubranch +; +:: until + 2/ 0branch +; +:: while + there + 0 0branch +; +:: repeat + swap 2/ ubranch + resolve +; + +4 org +: .trim ( a-addr u ) \ shorten string until it ends with '.' + begin + 2dup + 1- c@ [char] . <> + while + 1- + repeat +; +include strings.fs +next-arg 2dup .trim >str constant prefix. +: .suffix ( c-addr u -- c-addr u ) \ e.g. "bar" -> "foo.bar" + >str prefix. +str str@ +; +: create-output-file w/o create-file throw ; +: out-suffix ( s -- h ) \ Create an output file h with suffix s + >str + prefix. +str + s" ../build/firmware/" >str +str str@ + create-output-file +; +:noname + s" lst" out-suffix lst ! +; execute + + +target included \ include the program.fs + +[ tdp @ 0 org ] bootloader main [ org ] +meta + +decimal +0 value file +: dumpall.16 + s" hex" out-suffix to file + + hex + 1024 0 do + tflash i 2* + w@ + s>d <# # # # # #> file write-line throw + loop + file close-file +; +: dumpall.32 + s" hex" out-suffix to file + + hex + 4096 0 do + tflash i 4 * + @ + s>d <# # # # # # # # # #> file write-line throw + loop + file close-file +; + +dumpall.32 + +bye diff --git a/j1/toolchain/demo1.fs b/j1/toolchain/demo1.fs new file mode 100644 index 0000000..7c49af4 --- /dev/null +++ b/j1/toolchain/demo1.fs @@ -0,0 +1,7 @@ +: main + begin + h# 0 io@ + d# 1 + + h# 0 io! + again +; diff --git a/j1/toolchain/dump.py b/j1/toolchain/dump.py new file mode 100644 index 0000000..283916b --- /dev/null +++ b/j1/toolchain/dump.py @@ -0,0 +1,36 @@ +import sys +import array + +def hexdump(s): + def toprint(c): + if 32 <= ord(c) < 127: + return c + else: + return "." + def hexline(i, s): + return ("%04x: " % i + " ".join(["%02x" % ord(c) for c in s]).ljust(52) + + "|" + + "".join([toprint(c) for c in s]).ljust(16) + + "|") + return "\n".join([hexline(i, s[i:i+16]) for i in range(0, len(s), 16)]) + +pgm = array.array('H', [int(l, 16) for l in open(sys.argv[1])]) + +while pgm[-1] == 0: + pgm = pgm[:-1] +s = pgm.tostring() +print +print hexdump(s) + +link = [w for w in pgm[::-1] if w][0] +words = [] +while link: + name = s[link + 2:] + c = ord(name[0]) + name = name[1:1+c] + print "%04x %s" % (link, name) + assert not name in words + words.append(name) + link = pgm[link / 2] +print len(words), " ".join(words) +print "program size %d/%d" % (len(pgm), 1024) diff --git a/j1/toolchain/go b/j1/toolchain/go new file mode 100644 index 0000000..6570942 --- /dev/null +++ b/j1/toolchain/go @@ -0,0 +1,3 @@ +set -e +gforth cross.fs basewords.fs nuc.fs +# python dump.py ../build/firmware/demo0.hex diff --git a/j1/toolchain/nuc.fs b/j1/toolchain/nuc.fs new file mode 100644 index 0000000..846db05 --- /dev/null +++ b/j1/toolchain/nuc.fs @@ -0,0 +1,604 @@ +header 1+ : 1+ d# 1 + ; +header 1- : 1- d# -1 + ; +header 0= : 0= d# 0 = ; +header cell+ : cell+ d# 2 + ; + +header <> : <> = invert ; +header > : > swap < ; +header 0< : 0< d# 0 < ; +header 0> : 0> d# 0 > ; +header 0<> : 0<> d# 0 <> ; +header u> : u> swap u< ; + +: eol ( u -- u' false | true ) + d# -1 + + dup 0= dup if + ( 0 true -- ) + nip + then +; + +header ms +: ms + begin + d# 15000 begin + eol until + eol until +; + + +header key? +: key? + d# 0 io@ + d# 4 and + 0<> +; + +header key +: key + begin + key? + until + d# 0 io@ d# 8 rshift + d# 0 d# 2 io! +; + +: ready + d# 0 io@ + d# 2 and + 0= +; + +header emit +: emit + begin ready until + h# 0 io! +; + +header cr +: cr + d# 13 emit + d# 10 emit +; + +header space +: space + d# 32 emit +; + +header bl +: bl + d# 32 +; + +: hex1 + h# f and + dup d# 10 < if + [char] 0 + else + d# 55 + then + + + emit +; + +: hex2 + dup d# 4 rshift hex1 hex1 +; + +: hex4 + dup d# 8 rshift hex2 hex2 +; + +: hex8 + dup d# 16 rshift hex4 hex4 +; + +header . +: . hex8 space ; + +header false : false d# 0 ; +header true : true d# -1 ; +header rot : rot >r swap r> swap ; +header -rot : -rot swap >r swap r> ; +header tuck : tuck swap over ; +header 2drop : 2drop drop drop ; +header ?dup : ?dup dup if dup then ; + +header 2dup : 2dup over over ; +header +! : +! tuck @ + swap ! ; +header 2swap : 2swap rot >r rot r> ; + +header min : min 2dup< if drop else nip then ; +header max : max 2dup< if nip else drop then ; + +header c@ +: c@ + dup @ swap + d# 3 and d# 3 lshift rshift + d# 255 and +; + +: hi16 + d# 16 rshift d# 16 lshift +; + +: lo16 + d# 16 lshift d# 16 rshift +; + +header uw@ +: uw@ + dup @ swap + d# 2 and d# 3 lshift rshift + lo16 +; + +header w! +: w! ( u c-addr -- ) + dup>r d# 2 and if + d# 16 lshift + r@ @ lo16 + else + lo16 + r@ @ hi16 + then + or r> ! +; + +header c! +: c! ( u c-addr -- ) + dup>r d# 1 and if + d# 8 lshift + h# 00ff + else + h# 00ff and + h# ff00 + then + r@ uw@ and + or r> w! +; + +header count +: count + dup 1+ swap c@ +; + +: bounds ( a n -- a+n a ) + over + swap +; + +header type +: type + bounds + begin + 2dupxor + while + dup c@ emit + 1+ + repeat + 2drop +; + +create base $a , +create ll 0 , +create dp 0 , +create tib# 0 , +create >in 0 , +create tib 80 allot + +header words : words + ll uw@ + begin + dup + while + cr + dup . + dup cell+ + count type + space + uw@ + repeat + drop +; + +header dump : dump ( addr u -- ) + cr over hex4 + begin ( addr u ) + ?dup + while + over c@ space hex2 + 1- swap 1+ ( u' addr' ) + dup h# f and 0= if ( next line? ) + cr dup hex4 + then + swap + repeat + drop cr +; + +header negate : negate invert 1+ ; +header - : - negate + ; +header abs : abs dup 0< if negate then ; +header 2* : 2* d# 1 lshift ; +header 2/ : 2/ d# 1 rshift ; +header here : here dp @ ; +header depth : depth depths h# f and ; + +: /string + dup >r - swap r> + swap +; + +header aligned +: aligned + d# 3 + d# -4 and +; + +: d+ ( augend . addend . -- sum . ) + rot + >r ( augend addend) + over + ( augend sum) + dup rot ( sum sum augend) + u< if ( sum) + r> 1+ + else + r> + then ( sum . ) +; + +: d1+ d# 1. d+ ; + +: dnegate + invert swap invert swap + d1+ +; + +: dabs ( d -- ud ) + dup 0< if dnegate then +; + +: s>d dup 0< ; +: m+ + s>d d+ +; + +: snap + cr depth hex2 space + begin + depth + while + . + repeat + cr + [char] # emit + begin again +; + +create scratch 0 , + +header um* +: um* ( u1 u2 -- ud ) + scratch ! + d# 0. + d# 32 begin + >r + 2dup d+ + rot dup 0< if + 2* -rot + scratch @ d# 0 d+ + else + 2* -rot + then + r> eol + until + rot drop +; +: * + um* drop +; + +header accept +: accept + d# 30 emit + drop dup + begin + key + dup h# 0d xor + while + dup h# 0a = if + drop + else + over c! 1+ + then + repeat + drop swap - +; + +: 3rd >r over r> swap ; +: 3dup 3rd 3rd 3rd ; + +: sameword ( c-addr u wp -- c-addr u wp flag ) + 2dup d# 2 + c@ = if + 3dup + d# 3 + >r + bounds + begin + 2dupxor + while + dup c@ r@ c@ <> if + 2drop rdrop false exit + then + 1+ + r> 1+ >r + repeat + 2drop rdrop true + else + false + then +; + +\ lsb 0 means non-immediate, return -1 +\ 1 means immediate, return 1 +: isimmediate ( wp -- -1 | 1 ) + uw@ d# 1 and 2* 1- +; + +: sfind + ll uw@ + begin + dup + while + sameword + if + nip nip + dup + d# 2 + + count + + d# 1 + d# -2 and + swap isimmediate + exit + then + uw@ + repeat +; + +: digit? ( c -- u f ) + dup h# 39 > h# 100 and + + dup h# 140 > h# 107 and - h# 30 - + dup base @ u< +; + +: ud* ( ud1 u -- ud2 ) \ ud2 is the product of ud1 and u + tuck * >r + um* r> + +; + +: >number ( ud1 c-addr1 u1 -- ud2 c-addr2 u2 ) + begin + dup + while + over c@ digit? + 0= if drop exit then + >r 2swap base @ ud* + r> m+ 2swap + d# 1 /string + repeat +; + +header fill +: fill ( c-addr u char -- ) ( 6.1.1540 ) + >r bounds + begin + 2dupxor + while + r@ over c! 1+ + repeat + r> drop 2drop +; + +header erase +: erase + d# 0 fill +; + +header execute +: execute + >r +; + +header source +: source + tib tib# @ +; + +\ From Forth200x - public domain + +: isspace? ( c -- f ) + bl 1+ u< ; + +: isnotspace? ( c -- f ) + isspace? 0= ; + +: xt-skip ( addr1 n1 xt -- addr2 n2 ) \ gforth + \ skip all characters satisfying xt ( c -- f ) + >r + BEGIN + over c@ r@ execute + over 0<> and + WHILE + d# 1 /string + REPEAT + r> drop ; + +: parse-name ( "name" -- c-addr u ) + source >in @ /string + ['] isspace? xt-skip over >r + ['] isnotspace? xt-skip ( end-word restlen r: start-word ) + 2dup d# 1 min + source drop - >in ! + drop r> tuck - ; + +header ! :noname ! ; +header + :noname + ; +header xor :noname xor ; +header and :noname and ; +header or :noname or ; +header invert :noname invert ; +header = :noname = ; +header < :noname < ; +header u< :noname u< ; +header swap :noname swap ; +header dup :noname dup ; +header drop :noname drop ; +header over :noname over ; +header nip :noname nip ; +header @ :noname @ ; +header io! :noname io! ; +header rshift :noname rshift ; +header lshift :noname lshift ; +\ +\ \ >r +\ \ r> +\ \ r@ +\ \ exit +\ + +: xmain + cr d# 1 ms cr + d# 60 begin + [char] - emit + eol until + begin key? while key drop repeat + + cr h# ffff hex8 + + d# 0 d# 100 dump + words cr cr + + begin again + + begin + cr + tib d# 30 accept >r + d# 0. tib r> >number + 2drop hex4 space hex4 + again + + snap +; + +: route + r> + >r ; + +\ (doubleAlso) ( c-addr u -- x 1 | x x 2 ) +\ If the string is legal, leave a single or double cell number +\ and size of the number. + +: isvoid ( caddr u -- ) \ any char remains, throw -13 + nip 0<> + if [char] x emit snap then +; + +: consume1 ( caddr u ch -- caddr' u' f ) + >r over c@ r> = + over 0<> and + dup>r d# 1 and /string r> +; + +: (doubleAlso) + h# 0. 2swap + [char] - consume1 >r + >number + [char] . consume1 if + isvoid \ double number + r> if dnegate then + d# 2 exit + then + \ single number + isvoid drop + r> if negate then + d# 1 +; + +: doubleAlso + (doubleAlso) drop +; + + +: dispatch + route ;fallthru + jmp execute \ -1 0 non-immediate + jmp doubleAlso \ 0 0 number + jmp execute \ 1 0 immediate + +\ jmp compile_comma \ -1 2 non-immediate +\ jmp doubleAlso_comma \ 0 2 number +\ jmp execute \ 1 2 immediate + +: interpret + begin + parse-name dup + while + sfind + 1+ 2* dispatch + repeat + 2drop +; + +: main + 2drop + begin + tib d# 80 accept + tib# ! + \ h# 40 emit + d# 0 >in ! + source dump + \ cr parse-name sfind + \ if + \ execute + \ then + interpret + again +; + +meta + $3f80 org +target + +: b.key + begin + d# 0 io@ + d# 4 and + until + d# 0 io@ d# 8 rshift + d# 0 d# 2 io! +; + +: b.32 + b.key + b.key d# 8 lshift or + b.key d# 16 lshift or + b.key d# 24 lshift or +; + +meta + $3fc0 org +target + +: bootloader + begin + b.key d# 27 = + until + + b.32 d# 0 + begin + 2dupxor + while + b.32 over ! + d# 4 + + repeat +; + +meta + link @ t, + link @ t' ll tw! + there t' dp tw! +target diff --git a/j1/toolchain/strings.fs b/j1/toolchain/strings.fs new file mode 100644 index 0000000..cbd9b0e --- /dev/null +++ b/j1/toolchain/strings.fs @@ -0,0 +1,25 @@ +( Strings JCB 11:57 05/18/12) + +: >str ( c-addr u -- str ) \ a new u char string from c-addr + dup cell+ allocate throw dup >r + 2dup ! cell+ \ write size into first cell + ( c-addr u saddr ) + swap cmove r> +; +: str@ dup cell+ swap @ ; +: str! ( str c-addr -- c-addr' ) \ copy str to c-addr + >r str@ r> + 2dup + >r swap + cmove r> +; +: +str ( str2 str1 -- str3 ) + over @ over @ + cell+ allocate throw >r + over @ over @ + r@ ! + r@ cell+ str! str! drop r> +; + +: example + s" sailor" >str + s" hello" >str + +str str@ type +; -- cgit v1.2.3