home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.7z / ftp.whtech.com / emulators / v9t9 / linux / sources / V9t9 / tools / Forth / 99build.fs < prev    next >
Encoding:
FORTH Source  |  2006-10-19  |  12.8 KB  |  733 lines
  1. \    set level of self-diagnostics to perform on boot.
  2. 1 constant init-test-level
  3.  
  4. variable startmem here startmem !
  5.  
  6. \    get-rom-addr defined in command line as a constant
  7. get-rom-addr constant ROM-start-addr
  8.  
  9. create mach-file ," 99config.fs" 
  10. include cross.fs
  11.  
  12. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\
  13.  
  14. Warnings on
  15.  
  16. unlock
  17.  
  18. 0000 10000 region address-space
  19. ROM-start-addr 8000 over - region rom-dictionary 
  20. A000 6000 region ram-dictionary
  21.  
  22. 10000 makekernel
  23.  
  24. only forth also definitions
  25.  
  26. \ \\\\\\\\\\\\\\\\\\\\\\\\\
  27.  
  28. \ also environment also forth
  29. also cross also target also forth
  30. : env-has?
  31.     name T environment? H
  32.         IF      \ environment variable is present, return its value
  33.         ELSE    \ environment variable is not present, return false
  34.                 \ !! JAW abort is just for testing
  35.                 false true ABORT" arg"
  36.         THEN
  37. ;    immediate
  38. previous previous previous
  39. \ previous
  40.  
  41. \ \\\\\\\\\\\\\\\\\\\\\\\\\\
  42.  
  43. \ only forth also definitions
  44.  
  45. \    Machine definitions
  46.  
  47. \ also minimal definitions
  48. \ only forth 
  49. \ also minimal 
  50. \ also definitions
  51. >target
  52. include 99asm.fs
  53. include 99equs.fs
  54.  
  55. only forth also definitions
  56.  
  57. \ : Asm
  58. \ also assembler also asm-hidden 
  59. \ ;
  60.  
  61. \ Asm
  62.  
  63. variable out-fileid     stdout out-fileid !
  64. variable copy-to-scrn copy-to-scrn off
  65.  
  66. : my-emit
  67.     dup
  68.     out-fileid @ emit-file drop
  69.     \ write to screen only if it's not the current output
  70.     \ and we want to copy to screen
  71.     stdout out-fileid @ over <> 
  72.     copy-to-scrn @ and if 
  73.         emit-file drop 
  74.     else 
  75.         2drop 
  76.     then
  77. ;
  78.  
  79. ' my-emit IS emit
  80.  
  81. : my-type
  82.     2dup
  83.     out-fileid @ write-file drop
  84.     stdout out-fileid @ over <> 
  85.     copy-to-scrn @ and if
  86.         write-file drop 
  87.     else 
  88.         2drop drop 
  89.     then
  90. ;
  91.  
  92. ' my-type IS type
  93.  
  94. : stdout>file ( caddr u -- )
  95.     r/w create-file throw out-fileid !
  96.     copy-to-scrn off
  97. ;
  98.  
  99. : >stdout
  100.     out-fileid @ close-file
  101.     stdout out-fileid !
  102. ;
  103.  
  104.  
  105. \ \\\\\\\\\\\\
  106.  
  107. >minimal also cross also minimal also forth
  108.  
  109. : -visible
  110.     copy-to-scrn off
  111. ;
  112.  
  113. : visible
  114.     copy-to-scrn on
  115. ;
  116.  
  117. : error"
  118.     copy-to-scrn @
  119.     s" ERROR: " type
  120.     visible $22 parse type
  121.     cr
  122.     copy-to-scrn !
  123. ;
  124.  
  125. \ \\\\\\\\\\\\\\\\\\\
  126.  
  127. \    Testing words.
  128. \    Using:        test" word ... "
  129. \    will define a test for "word" that consists of "...".
  130. \    At runtime, the test will be executed, and leaving "0" on the stack
  131. \    indicates failure, "1" indicates success.  If fails, the name
  132. \    is printed.
  133.  
  134. variable test-fileid
  135. variable test-level init-test-level test-level !
  136.  
  137. : write"
  138.     test-fileid @ write-file drop
  139. ;
  140.  
  141. : cr"
  142.     $a pad c! pad 1 write"
  143. ;
  144.  
  145. : write-test-header
  146.     \ init code
  147.     s" : [name. ( xt -- caddr u ) xt>nfa dup 1+ swap c@ $1f and ; " write" cr"
  148.     \ test run:  xt is :noname def, txt is word to blame ;)
  149.     s" : (runtest sp0 @ sp! ; " write" cr"
  150.     s" : runtest) ( txt t/f -- ) " write" cr"
  151.     s"        swap if ( 2a emit [name. type 2b emit ) drop else ( 5b emit ) [name. type ( 5d emit ) then  2e emit ; " write" cr"
  152.     \ header for test runner
  153.     s" : runtests 5b emit " write" cr"
  154. ;
  155.  
  156. : create-test-file
  157.     test-fileid @ 0= if
  158.         s" 99tests.fth" r/w create-file throw test-fileid !
  159.         write-test-header
  160.     then
  161. ;
  162.  
  163. \    Add test to tests list.
  164. : #test"    ( level "word test" -- )
  165.     create-test-file
  166.     test-level @ < if
  167.         $20 parse \ write"    
  168.         \ clean stack
  169.         s"  (runtest " write"
  170.         \ then it's the test
  171.         $22 parse write"
  172.         \ token for blame if error
  173.         s"  ['] " write" write"
  174.         \ execute
  175.         s"  runtest) " write" cr"
  176.     else
  177.         $20 parse 2drop $22 parse 2drop
  178.     then
  179. ;
  180.  
  181. \    force test
  182. : test"  0 #test" ;
  183.  
  184. \    various test levels
  185. : 1test" 1 #test" ;
  186. : 2test" 2 #test" ;
  187. : 3test" 3 #test" ;
  188.  
  189. : close-test-file
  190.     test-fileid @ if
  191.         s"  5d emit ; " write" cr"
  192.         test-fileid @ close-file
  193.     else
  194.         create-test-file
  195.         s" " write"
  196.         recurse
  197.     then
  198. ;
  199.  
  200. >minimal
  201. \ also minimal definitions previous
  202.  
  203. : append-test-file
  204.     close-test-file
  205.     s" 99tests.fth" included    
  206. ;
  207.  
  208. previous previous
  209.  
  210. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\
  211. >cross
  212. variable tram 
  213. >target
  214. $2000 tram !
  215.  
  216. >cross
  217. \ also cross \ definitions also target
  218. \ definitions
  219.  
  220. env-has? standard-threading
  221. 0= [if]
  222.  
  223. \    go direct threading!
  224. \    Overrides for dictionary creating words.
  225. \    We want a direct threading model instead of
  226. \    the indirect threading model, for better 
  227. \    performance.
  228.  
  229. \    for direct threading, the code field contains actual
  230. \    code, not a pointer to it.
  231. \    for primitives, assembly starts here.
  232. \    for colon defs, a BL *DODOES starts here.
  233. \    for constants, a BL @>DOCON starts here.
  234. \    for variables, a BL @>DOVAR starts here.
  235.  
  236. 0 include common.fs
  237.  
  238. :noname    ( tcfa -- )        \ compiles call to tcfa at current position
  239. \    !!! ugly hack: defer/is words
  240. \    appear to point to the wrong CFA.
  241.     T dup 1 cells - @ $06A0 = if 1 cells - then H
  242.     T , H                        \ tcfa -> code
  243. ;    IS colon,
  244.  
  245. \  for constant/variable references
  246. :noname
  247.   >tempdp ]comp 
  248.     T , H comp[ tempdp>
  249. ;     IS colon-resolve
  250.  
  251. :noname 
  252.     BL-DODOES T , H
  253.     addr,
  254. ;    IS dodoes,
  255.  
  256. :noname  ( -- ) 
  257.     BL-DOCOL T , H
  258. ;     IS docol,
  259.  
  260. :noname ( -- )
  261. ;     IS doprim,
  262.  
  263. \    for dodefer, etc?
  264. :noname ( ghost -- ) 
  265.     ." doer," cr
  266.      BL-@ tdp @ T 1 cells - H T ! H addr,
  267. \    BL-@ , addr,
  268.     $80 flag!
  269. \     BL-DODOES , addr, 
  270. ;    IS doer,
  271.  
  272.  
  273.  
  274. \ \ EJS 001130 GF0.5.0
  275. >target
  276.  
  277. \    DeferROMs MUST BE 'ROMIS'ed at startup!
  278. BuildSmart:  ( -- ) tram @ dup T 1 cells + H tram ! T A, H ; \ [T'] noop swap T ! H ;
  279. by: :dordefer ( ghost -- ) ABORT" CROSS: Don't execute" ;DO
  280. Builder DeferROM
  281.  
  282. : IS
  283.     T ' cell+ ! H
  284. ;
  285.  
  286. : ROMIS
  287.     T ' cell+ @ ! H
  288. ;
  289. >cross
  290.  
  291. ." !!! 99doeshandler, is still weird" cr
  292. :noname
  293.     \ case of "create foo <allot> does> <code> ;"
  294.     \ we have | BL *DODOES | <variable info> | <doesjump> | <code>
  295.     T cfalign H 
  296.     \ there tcell - t@ tcell - there tcell - t! 
  297.     BL-DOCOL ,
  298. ;    IS doeshandler,
  299.  
  300. \    don't stick unloop in here -- saves 2 bytes per do/loop
  301. :noname 1to compile (loop)  loop] skiploop] ;
  302.   IS loop, ( target-addr -- )
  303. :noname 1to compile (+loop)  loop]  skiploop] ;
  304.   IS +loop, ( target-addr -- )
  305.  
  306.  
  307. \ also cross definitions
  308.  
  309. \    Note: don't change this, even though
  310. \    we don't have the "blank gap" for all
  311. \    words.  Two cells is indeed the gap for
  312. \    CREATEd words, which is what the Ghost
  313. \    routines need (to execute a CONSTANT defined
  314. \    in the ROM, for instance)
  315. \ cr order
  316. \ :noname
  317. \     2 +
  318. \ ; T IS >body H
  319. \ 4 TO xt>body
  320.  
  321. [else]
  322. \ abort
  323. [then]
  324.  
  325. \ \\\\\\\\\\\\\\\\\\\\
  326.  
  327. \    Dictionary and hash table maintenance.
  328.  
  329. \    too damn slow and memory hogging
  330. 0 [if]
  331.  
  332. >cross
  333.  
  334. variable FORTH-wordlis
  335. \ right circular shift
  336. \ x n cshift == ( x>>n | x << 16-n )
  337. : cshift
  338.     >r
  339.     $ffff and 
  340.     dup r@ \ .s 
  341.     rshift swap $10 r> - \ .s 
  342.     lshift 
  343.     \ .s 
  344.     OR $ffff and
  345. ;
  346.  
  347. ." cshift: "
  348. $000a 5 cshift . cr
  349.  
  350. 0 include commonhash.fs
  351.  
  352. \    preallocate buckets for hash table
  353.  
  354. T here
  355. hash-buckets hash-bucket-size * cells dup allot
  356. over swap erase
  357. dup ." hash buckets start at " . cr
  358.  
  359. \ .s
  360. \ save target ptr
  361.  FORTH-wordlis H !
  362.  
  363. previous
  364.  
  365. >minimal
  366. also cross definitions 
  367.  
  368. >cross
  369.  
  370. create newname $20 allot
  371.  
  372. \    Our own header routine.
  373. \    We need to possibly allocate dict
  374. \    space for hash table expansion --
  375. \    so, we get the entry for the new name first,
  376. \    then lay down the header.
  377.  
  378. \    Read name from  input stream and
  379. \    add it to hash table.  Return tptr to
  380. \    the place we should store the NFA.
  381.  
  382. variable newcfa
  383. : add-hash-entry ( "name" -- addr )
  384.     ." add-hash-entry" cr
  385.     forth-wordlis @
  386.      bl word count 
  387.  
  388. T    hash>new H                 \ leaves new entry addr
  389.  
  390. ;
  391.  
  392. :noname    ( "name" -- )
  393.     >in @
  394.     add-hash-entry
  395.     >r >in ! r>
  396.  
  397.     T align H view,
  398.     tlast @ dup 0> IF  T 1 cells - H THEN T A, H  there tlast !
  399.  
  400.     \ write NFA to hash table
  401.     T here cfaligned swap ! H
  402.  
  403.     >in @ T name, H  >in !
  404.  
  405. ; IS header,
  406.  
  407. \ see name,
  408.  
  409. [then]        \ hash table stuff
  410.  
  411. \ \\\\\\\\\\\\\\\\\\\\
  412.  
  413.  
  414. T has? profiling H [if]
  415.  
  416. \ expect maximum 1024 words (for profiling)
  417. $a800 constant high-ram-start
  418.  
  419. \    Statistics:  we add a field to each word which
  420. \    points into RAM.  Increment this pointer for each
  421. \    execution of the word.
  422.  
  423. :noname    ( "name" -- )
  424.     T align H view,
  425.     tlast @ dup 0> IF  T cell - H THEN T A, H  there tlast !
  426.     >in @ T name, H  >in !
  427.  
  428.     \ write the address of the profiling word
  429.     tram @ start-grom-image >= if
  430.         abort" out of profiling space, adjust start-grom-image"
  431.     then
  432.     tram @ T A, cell H tram +!
  433. ; IS header,
  434.  
  435. [else]
  436.  
  437. $a000 constant high-ram-start
  438.  
  439. [then]
  440.  
  441. \ \\\\\\\\\\\\\\\\\\\\
  442.  
  443. >cross
  444. order
  445.  
  446. $2800 constant low-ram-start
  447.  
  448. \    move 'there' to module area
  449. \    if out of CPU ROM space
  450. \    not too bright -- literal strings make big definitions
  451.  
  452. \    eat up 0...$2000, then $6000...$7fff, then high-ram-start...$ffff
  453. \    
  454. \
  455. : checkmemory ( delta -- )
  456.     >r
  457.     there $0000 $2002 within if
  458.         there $2000 r@ - >=  if
  459.             ." Switching to module ROM bank..." cr
  460.             $6000 tdp !
  461.             $aa55  T  , H 
  462.         then
  463.     else there $6000 $8002 within if
  464.         there $8000 r@ - >=  if
  465.             ." Switching to high memory bank..." cr
  466.             high-ram-start 3 cells + tdp !
  467.         then
  468.     else there $10000 >= if
  469.             abort" All ROMable dictionaries full!" cr
  470.     then
  471.     then
  472.     then
  473.     rdrop
  474. ;
  475.  
  476. \    These routines are called from the cross compiler
  477. \    at locations where it's useful to dump a disassembly
  478. \    or a dictionary header.  They assume that the dictionary
  479. \    is linearly organized (i.e., names are inline with code)
  480. \    and that 'there' increments linearly.
  481.  
  482. variable code-start        ROM-start-addr code-start !
  483. variable ended-code        1 ended-code !
  484.  
  485. \    print all data accumulated since last time
  486. \    if ended-code, then it's data, else ignore, since it's code
  487. \
  488. : (print-data)
  489.     ended-code @ if
  490.         code-start @        \ start
  491.         dup
  492.         there swap -
  493.         dup 4000 > if         \ changed banks
  494.             code-start @ dup 1fff or 1+ over - T tdump H cr
  495.             2drop there e000 and dup there swap -
  496.         then
  497.          T tdump H cr
  498.     then
  499.     $40 checkmemory
  500. ;
  501.  
  502. : (doc-code)
  503.     also cross also assembler \ also asm-hidden
  504.     (print-data)
  505.     ended-code @ if
  506.         ." Assembling at @>" there dup code-start ! . cr
  507.         0 ended-code !
  508.     then
  509. ;
  510.  
  511. : (print-code)
  512.     cr code-start @ there over - T dis H cr
  513.     there code-start ! 
  514. ;
  515.  
  516. : (doc-end-code)
  517.     previous previous \ previous
  518.     $40 checkmemory
  519.     (print-code)
  520.     1 ended-code !
  521. ;
  522.  
  523.  
  524.  
  525. ' (doc-code) IS (code)
  526. ' (doc-end-code) IS (end-code)
  527.  
  528. : (doc-end-colon)
  529.     (fini,)
  530.     $40 checkmemory
  531.  
  532.     (print-data)
  533.     1 ended-code !
  534.     there code-start !
  535. ;                                 
  536.  
  537. ' (doc-end-colon) IS fini,
  538.  
  539. \ only forth also cross
  540. previous previous    \ no more asm
  541.  
  542. s" list.lst" stdout>file 
  543.  
  544.  
  545. \ \\\\\\\\\\\\\\\\\\\\\\\\\\
  546.  
  547. 0 [if]
  548.  
  549. \ only forth
  550. \ also target
  551. \ also cross 
  552. \ also ghosts 
  553. \ >target  H
  554. \ order
  555. \ also target
  556.  
  557. only forth also target definitions also forth also cross definitions
  558.  
  559. \    A word to prevent redefintions
  560. \    (i.e., we define a primitive, and only load the high-
  561. \    level version if not found)
  562.  
  563. \ ." LOOK:" 
  564. \ order cr 
  565. \    ???  what the hell is wrong with the vocabularies?
  566.  
  567. \ : old; compile ; ; immediate
  568.  
  569. \ : ; .S compile ; old; immediate
  570. here .
  571. H : :
  572. \    .S
  573. \    order
  574.     >in @        \ store original
  575.     20 word        \ parse the name
  576.     swap >in !    \ restore pointer
  577.  
  578.     dup >r 1+ r> c@        \ convert C" to S"
  579.     2dup \ .S
  580.     context @ search-wordlist
  581.     if
  582.         drop cr ." Note: " type ."  is already defined, ignoring new definition" cr
  583.      else
  584.         cr ." Defining new word " type cr
  585.     then
  586.     T :  H
  587.     \ .S
  588. ;    \ IS created?
  589.  
  590. \ : old: : ;
  591. \ : old; compile ; ;
  592.  
  593. \ : ; [compile] dup; old; immediate
  594. \ : dup: old;
  595.  
  596.  
  597. \ >target 
  598. \ ' dup-created? IS created?
  599. \ ' dup; IS ;
  600.  
  601. [then]
  602.  
  603. \ \\\\\\\\\\\
  604.  
  605. include 99memory.fs
  606.  
  607. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\
  608.  
  609. lock
  610.  
  611. >rom
  612.  
  613. [[ NoHeaderFlag on ]]
  614. \ \EJS 001130 GF0.5.0
  615. : T ; immediate
  616. [[ NoHeaderFlag on ]]
  617. \ \ EJS 001130 GF0.5.0
  618. : H ; immediate
  619.  
  620. \ include defer.fs
  621.  
  622. include user.fs
  623.  
  624. include 99prims.fs
  625.  
  626. unlock
  627.  
  628. \ [[ $6000 tdp ! ]]
  629. \ $6000 tdp !
  630.  
  631. lock
  632.  
  633. \ $aa55 ,
  634.  
  635. include constant.fs
  636. include kernel.fs
  637. include interp.fs
  638. include dict.fs
  639. include compile.fs
  640. include files.fs
  641. include init.fs
  642.  
  643. \ \\\\\\\\\\\\\\\\\
  644.  
  645. User >latest        \ latest definition
  646.  
  647. \    Return latest definition's nfa
  648. : latest
  649.     >latest @
  650. ;
  651.  
  652.  
  653. \ [[ there $7e00 > [if] $c000 tdp ! [then] ]]
  654.  
  655. append-test-file
  656.  
  657. \    The RAM dictionary is copied from GROM to $a000.
  658. \    We use 'tram' to keep track of whatever stuff
  659. \    is chosen to reside in RAM.
  660.  
  661. 0 [if]
  662.  
  663. [[ tram @ ]] constant dp0                    \ start of first user dict
  664. dp0 constant (dp0
  665. StartRAM    constant dp0)                    \ end of first user dict
  666.  
  667. \ $20: reserve space for defns for (dp1 and fence!
  668. [[ high-ram-start  there $20 +  max ]] constant (dp1            \ start of second user dict
  669.  
  670. [else]
  671.  
  672. [[ high-ram-start there $20 + max ]] constant dp0
  673.  
  674. [then]
  675.  
  676. here constant fence
  677.  
  678. unlock
  679.  
  680. \ \\\\\\\\\\\\\\\\\\\\\\
  681.  
  682. \ finish off memory dump
  683.  
  684. (print-data)
  685.  
  686. visible
  687.  
  688. .regions
  689.  
  690. turnkey
  691.  
  692.  
  693. .stats
  694. .unresolved
  695.  
  696. unlock
  697.  
  698.  
  699. \    Write module ROM to disk...
  700. \ rom-dictionary extent save-region nforthc.bin
  701.  
  702. \    Write end of ROM to end of nforth.rom
  703. ROM-start-addr $2000 over - save-region nforth.prm
  704. $6000 $2000 save-region nforthc.bin
  705.  
  706. \     Write high RAM dictionary...
  707. \    in GROM, the memory is stored as repeating <$aa55> <start> <stop> <data...>
  708. \    where <start>/<stop> are the ranges of RAM to copy the following data to.
  709.  
  710. there high-ram-start $10000 within
  711. [if]
  712.     $aa55 high-ram-start T ! H                    \ magic
  713.     high-ram-start dup T cell+ ! H    \ start addr in RAM
  714.     there high-ram-start T cell+ cell+ ! H        \ last addr in RAM
  715.     high-ram-start  
  716.         there high-ram-start - \ 1fff or
  717.         save-region nforthg.bin
  718. [else]
  719.         high-ram-start 0 save-region nforthg.bin
  720. [then]
  721.  
  722. there ." HERE is " . cr
  723. tram @ $a000 - ." Used " . ." bytes of high RAM space for storage" cr
  724.  
  725. >stdout
  726.  
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.