crossj1.fs 11 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535
  1. ( Cross-compiler for the J1 JCB 13:12 08/24/10)
  2. decimal
  3. ( outfile is fileid or zero JCB 12:30 11/27/10)
  4. 0 value outfile
  5. : type ( c-addr u )
  6. outfile if
  7. outfile write-file throw
  8. else
  9. type
  10. then
  11. ;
  12. : emit ( u )
  13. outfile if
  14. pad c! pad 1 outfile write-file throw
  15. else
  16. emit
  17. then
  18. ;
  19. : cr ( u )
  20. outfile if
  21. s" " outfile write-line throw
  22. else
  23. cr
  24. then
  25. ;
  26. : space bl emit ;
  27. : spaces dup 0> if 0 do space loop then ;
  28. vocabulary j1assembler \ assembly storage and instructions
  29. vocabulary metacompiler \ the cross-compiling words
  30. vocabulary j1target \ actual target words
  31. : j1asm
  32. only
  33. metacompiler
  34. also j1assembler definitions
  35. also forth ;
  36. : meta
  37. only
  38. j1target also
  39. j1assembler also
  40. metacompiler definitions also
  41. forth ;
  42. : target
  43. only
  44. metacompiler also
  45. j1target definitions ;
  46. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  47. j1asm
  48. : tcell 2 ;
  49. : tcells tcell * ;
  50. : tcell+ tcell + ;
  51. 65536 allocate throw constant tflash
  52. : h#
  53. base @ >r 16 base !
  54. 0. bl parse >number throw 2drop postpone literal
  55. r> base ! ; immediate
  56. variable tdp
  57. : there tdp @ ;
  58. : islegal dup h# 7fff u> abort" illegal address" ;
  59. : tc! islegal tflash + c! ;
  60. : tc@ islegal tflash + c@ ;
  61. : t! islegal over h# ff and over tc! swap 8 rshift swap 1+ tc! ;
  62. : t@ islegal dup tc@ swap 1+ tc@ 8 lshift or ;
  63. : talign tdp @ 1 + h# fffe and tdp ! ;
  64. : tc, there tc! 1 tdp +! ;
  65. : t, there t! tcell tdp +! ;
  66. : org tdp ! ;
  67. 65536 cells allocate throw constant references
  68. : referenced cells references + 1 swap +! ;
  69. 65536 cells allocate throw constant labels
  70. : atlabel? ( -- f = are we at a label )
  71. labels there cells + @ 0<>
  72. ;
  73. : coldcross
  74. tflash 65536 255 fill
  75. labels 65536 cells 0 fill
  76. ;
  77. coldcross
  78. : preserve ( c-addr1 u -- c-addr )
  79. dup 1+ allocate throw dup >r
  80. 2dup c! 1+
  81. swap cmove r> ;
  82. : setlabel ( c-addr u -- )
  83. atlabel? if 2drop else preserve labels there cells + ! then ;
  84. j1asm
  85. : hex-literal ( u -- c-addr u ) s>d <# bl hold #s [char] $ hold #> ;
  86. : imm h# 8000 or t, ;
  87. : T h# 0000 ;
  88. : N h# 0100 ;
  89. : T+N h# 0200 ;
  90. : T&N h# 0300 ;
  91. : T|N h# 0400 ;
  92. : T^N h# 0500 ;
  93. : ~T h# 0600 ;
  94. : N==T h# 0700 ;
  95. : N<T h# 0800 ;
  96. : N>>T h# 0900 ;
  97. : T-1 h# 0a00 ;
  98. : rT h# 0b00 ;
  99. : [T] h# 0c00 ;
  100. : N*T h# 0d00 ;
  101. : swabT h# 0e00 ;
  102. : Nu<T h# 0f00 ;
  103. : T->N h# 0080 or ;
  104. : T->R h# 0040 or ;
  105. : N->[T] h# 0020 or ;
  106. : d-1 h# 0003 or ;
  107. : d+1 h# 0001 or ;
  108. : r-1 h# 000c or ;
  109. : r-2 h# 0008 or ;
  110. : r+1 h# 0004 or ;
  111. : alu h# 6000 or t, ;
  112. : return T h# 1000 or r-1 alu ;
  113. : ubranch 2/ h# 0000 or t, ;
  114. : 0branch 2/ h# 2000 or t, ;
  115. : scall 2/ h# 4000 or t, ;
  116. : dump-words ( c-addr n -- ) \ Write n/2 words from c-addr
  117. dup 6 > abort" invalid byte count"
  118. 2/ dup >r
  119. 0 do
  120. dup t@ s>d <# # # # # #> type space
  121. 2 +
  122. loop drop
  123. 3 r> - 5 * spaces
  124. ;
  125. variable padc
  126. : pad+ ( c-addr u -- ) \ append to pad
  127. dup >r
  128. pad padc @ + swap cmove
  129. r> padc +! ;
  130. : pad+loc ( addr -- )
  131. dup cells labels + @ ?dup if
  132. nip count pad+
  133. else
  134. s>d <# #s [char] $ hold #> pad+
  135. then
  136. s" " pad+
  137. ;
  138. : disassemble-j
  139. 0 padc !
  140. dup t@ h# 8000 and if
  141. s" LIT " pad+
  142. dup t@ h# 7fff and hex-literal pad+ exit
  143. else
  144. dup t@ h# e000 and h# 6000 = if
  145. s" ALU " pad+
  146. dup t@ pad+loc exit
  147. else
  148. dup t@ h# e000 and h# 4000 = if
  149. s" CALL "
  150. else
  151. dup t@ h# 2000 and if
  152. s" 0BRANCH "
  153. else
  154. s" BRANCH "
  155. then
  156. then
  157. pad+
  158. dup t@ h# 1fff and 2* pad+loc
  159. then
  160. then
  161. ;
  162. : disassemble-line ( offset -- offset' )
  163. dup cells labels + @ ?dup if s" \ " type count type cr then
  164. dup s>d <# # # # # #> type space
  165. dup 2 dump-words
  166. disassemble-j
  167. pad padc @ type
  168. 2 +
  169. cr
  170. ;
  171. : disassemble-block
  172. 0 do
  173. disassemble-line
  174. loop
  175. drop
  176. ;
  177. j1asm
  178. \ tcompile is like "STATE": it is true when compiling
  179. variable tcompile
  180. : tcompile? tcompile @ ;
  181. : +tcompile tcompile? abort" Already in compilation mode" 1 tcompile ! ;
  182. : -tcompile 0 tcompile ! ;
  183. : (literal)
  184. \ dup $f rshift over $e rshift xor 1 and throw
  185. dup h# 8000 and if
  186. h# ffff xor recurse
  187. ~T alu
  188. else
  189. h# 8000 or t,
  190. then
  191. ;
  192. : (t-constant)
  193. tcompile? if
  194. (literal)
  195. then
  196. ;
  197. meta
  198. \ Find name - without consuming it - and return a counted string
  199. : wordstr ( "name" -- c-addr u )
  200. >in @ >r bl word count r> >in !
  201. ;
  202. : literal (literal) ; immediate
  203. : 2literal swap (literal) (literal) ; immediate
  204. : call,
  205. dup referenced
  206. scall
  207. ;
  208. : t:
  209. talign
  210. wordstr setlabel
  211. create
  212. there ,
  213. +tcompile
  214. 947947
  215. does>
  216. @
  217. tcompile? if
  218. call,
  219. then
  220. ;
  221. : lookback ( offset -- v ) there swap - t@ ;
  222. : prevcall? 2 lookback h# e000 and h# 4000 = ;
  223. : call>goto dup t@ h# 1fff and swap t! ;
  224. : prevsafe?
  225. 2 lookback h# e000 and h# 6000 = \ is an ALU
  226. 2 lookback h# 004c and 0= and ; \ does not touch RStack
  227. : alu>return dup t@ h# 1000 or r-1 swap t! ;
  228. : t; 947947 <> if abort" Unstructured" then
  229. true if
  230. atlabel? invert prevcall? and if
  231. there 2 - call>goto
  232. else
  233. atlabel? invert prevsafe? and if
  234. there 2 - alu>return
  235. else
  236. return
  237. then
  238. then
  239. else
  240. return
  241. then
  242. -tcompile
  243. ;
  244. : t;fallthru 947947 <> if abort" Unstructured" then
  245. -tcompile
  246. ;
  247. variable shadow-tcompile
  248. wordlist constant escape]-wordlist
  249. escape]-wordlist set-current
  250. : ] shadow-tcompile @ tcompile ! previous previous ;
  251. meta
  252. : [
  253. tcompile @ shadow-tcompile !
  254. -tcompile get-order forth-wordlist escape]-wordlist rot 2 + set-order
  255. ;
  256. : : t: ;
  257. : ; t; ;
  258. : ;fallthru t;fallthru ;
  259. : , t, ;
  260. : c, tc, ;
  261. : constant ( n "name" -- ) create , immediate does> @ (t-constant) ;
  262. : ]asm
  263. -tcompile also forth also j1target also j1assembler ;
  264. : asm[ +tcompile previous previous previous ;
  265. : code t: ]asm ;
  266. j1asm
  267. : end-code
  268. 947947 <> if abort" Unstructured" then
  269. previous previous previous ;
  270. meta
  271. \ Some Forth words are safe to use in target mode, so import them
  272. : ( postpone ( ;
  273. : \ postpone \ ;
  274. : import ( "name" -- )
  275. >in @ ' swap >in !
  276. create , does> @ execute ;
  277. import meta
  278. import org
  279. import include
  280. import included
  281. import marker
  282. import [if]
  283. import [else]
  284. import [then]
  285. : do-number ( n -- |n )
  286. state @ if
  287. postpone literal
  288. else
  289. tcompile? if
  290. (literal)
  291. then
  292. then
  293. ;
  294. decimal
  295. : [char] ( "name" -- ) ( run: -- ascii) char (literal) ;
  296. : ['] ( "name" -- ) ( run: -- xt )
  297. ' tcompile @ >r -tcompile execute r> tcompile !
  298. dup referenced
  299. (literal)
  300. ;
  301. : (sliteral--h) ( addr n -- ptr ) ( run: -- eeaddr n )
  302. s" sliteral" evaluate
  303. there >r
  304. dup tc,
  305. 0 do count tc, loop
  306. drop
  307. talign
  308. r>
  309. ;
  310. : (sliteral) (sliteral--h) drop ;
  311. : s" ( "ccc<quote>" -- ) ( run: -- eaddr n ) [char] " parse (sliteral) ;
  312. : s' ( "ccc<quote>" -- ) ( run: -- eaddr n ) [char] ' parse (sliteral) ;
  313. : create
  314. wordstr setlabel
  315. create there ,
  316. does> @ do-number
  317. ;
  318. : allot tdp +! ;
  319. : variable wordstr setlabel create there , 0 t,
  320. does> @ do-number ;
  321. : 2variable wordstr setlabel create there , 0 t, 0 t,
  322. does> @ do-number ;
  323. : createdoes
  324. wordstr setlabel
  325. create there , ' ,
  326. does> dup @ dup referenced (literal) cell+ @ execute
  327. ;
  328. : jumptable
  329. wordstr setlabel
  330. create there ,
  331. does> s" 2*" evaluate @ dup referenced (literal) s" + @" evaluate
  332. ;
  333. : | ' execute dup referenced t, ;
  334. : ', ' execute t, ;
  335. ( DEFER JCB 11:18 11/12/10)
  336. : defer
  337. wordstr setlabel
  338. create there , 0 t,
  339. does> @ tcompile? if do-number s" @ execute" evaluate then ;
  340. : is ( xt "name" -- )
  341. tcompile? if
  342. ' >body @ do-number
  343. s" ! " evaluate
  344. else
  345. ' execute t!
  346. then ;
  347. : ' ' execute ;
  348. ( VALUE JCB 13:06 11/12/10)
  349. : value
  350. wordstr setlabel
  351. create there , t,
  352. does> @ do-number s" @" evaluate ;
  353. : to ( u "name" -- )
  354. ' >body @ do-number s" !" evaluate ;
  355. ( ARRAY JCB 13:34 11/12/10)
  356. : array
  357. wordstr setlabel
  358. create there , 0 do 0 t, loop
  359. does> s" cells" evaluate @ do-number s" +" evaluate ;
  360. : 2array
  361. wordstr setlabel
  362. create there , 2* 0 do 0 t, loop
  363. does> s" 2* cells" evaluate @ do-number s" +" evaluate ;
  364. ( eforth's way of handling constants JCB 13:12 09/03/10)
  365. : label: ( "name" -- ) create there , immediate does> @ (t-constant) ;
  366. : sign>number
  367. over c@ [char] - = if
  368. 1- swap 1+ swap
  369. >number
  370. 2swap dnegate 2swap
  371. else
  372. >number
  373. then
  374. ;
  375. : base>number ( caddr u base -- )
  376. base @ >r base !
  377. sign>number
  378. r> base !
  379. dup 0= if
  380. 2drop drop do-number
  381. else
  382. 1 = swap c@ [char] . = and if
  383. drop dup do-number 16 rshift do-number
  384. else
  385. -1 abort" bad number"
  386. then
  387. then ;
  388. : d# 0. bl parse 10 base>number ;
  389. : h# 0. bl parse 16 base>number ;
  390. ( Conditionals JCB 13:12 09/03/10)
  391. : if
  392. there
  393. 0 0branch
  394. ;
  395. : resolve
  396. dup t@ there 2/ or swap t!
  397. ;
  398. : then
  399. resolve
  400. s" (then)" setlabel
  401. ;
  402. : else
  403. there
  404. 0 ubranch
  405. swap resolve
  406. s" (else)" setlabel
  407. ;
  408. : begin s" (begin)" setlabel there ;
  409. : again
  410. ubranch
  411. ;
  412. : until
  413. 0branch
  414. ;
  415. : while
  416. there
  417. 0 0branch
  418. ;
  419. : repeat
  420. swap ubranch
  421. resolve
  422. s" (repeat)" setlabel
  423. ;
  424. : 0do s" >r d# 0 >r" evaluate there s" (do)" setlabel ;
  425. : do s" 2>r" evaluate there s" (do)" setlabel ;
  426. : loop
  427. s" looptest" evaluate 0branch
  428. ;
  429. : i s" r@" evaluate ;
  430. 77 constant sourceline#
  431. s" none" 2constant sourcefilename
  432. : line# sourceline# (literal) ;
  433. create currfilename 1 cells 80 + allot
  434. variable currfilename#
  435. : savestr ( c-addr u dst -- ) 2dup c! 1+ swap cmove ;
  436. : getfilename sourcefilename currfilename count compare 0<>
  437. if
  438. sourcefilename 2dup currfilename savestr (sliteral--h) currfilename# !
  439. else
  440. currfilename# @ dup 1+ (literal) tc@ (literal)
  441. then ;
  442. : snap line# getfilename s" (snap)" evaluate ; immediate
  443. : assert 0= if line# sourcefilename (sliteral) s" (assert)" evaluate then ; immediate