crossj1.fs 10 KB

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