home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Base < prev    next >
Encoding:
Text File  |  1995-07-16  |  13.1 KB  |  484 lines  |  [TEXT/YERK]
  1. ( base  ==============================  June 12 84 )
  2. (  6/12/84  NDI Added DISK.SCR to front )
  3. (  8/15/84  CBD Added Select{ indexed case structure )
  4. ( 10/03/84  CBD Scon and other stuff )
  5. ( 10/08/84  CBD Added .h, .d, etc. )
  6. ( 10/12/84  CBD Added class error handling )
  7. ( 10/12/84  CBD Converted Variables to Values )
  8. ( 12/29/84  cbd Added resource string handling )
  9. ( 11/12/85  cdn Fixed nullOSstr; Msg# end with a CR )
  10. ( 12/20/85  cdn Made ascii sensitive to case )
  11. ( 12/12/85  cdn Corrected rDepth )
  12. (  2/21/86  cdn Changed file rewind to set EOF=0 in (save)
  13. (  6/18/86  cdn Added GetRes )
  14. (  6/26/86  cdn Added token )
  15. ( 10/09/86  cdn Modified next, for 2.0 nucleus )
  16. (  8/31/88    rfl changed extend to make it faster AND fixed >uc trap a054)
  17. (  7/10/90    rfl    modified getstring to return 0 0 if not found
  18. ( 12/24/90    rfl    changed the word BE to BI so that $be is valid.
  19. (  6/08/91  rfl    'type now works for upper and lower case
  20. ( 12/09/92    rfl    added switch to ?rdepth so that proc words don't have a problem if stack is
  21. (                  moved somewhere else in memory due to context switching
  22. (                  Actualy ?rdepth word moved to source Class
  23. (  5/01/93    rfl    added gestalt
  24. (  5/07/93    rfl    added asc>bin and bin>asc
  25. (  5/14/93    rfl    modified getstring to not open yerk.rsrc...error message if not found
  26. ( 11/29/93    rfl    modified patch word to understand colon defs with arguments and :code
  27. (                 definitions. Note that there is still no forward for :code defs., but
  28. (                 forward does work for named input parameters and local variables.
  29. (  1/01/94    rfl moved file related words to file source: file-install etc
  30. (  3/10/94    rfl    added patchL
  31. (  6/06/94  rfl added dictionary space check for 'reserve'
  32. ( 10/31/94    rfl string is put into pad+64 to free up low pad
  33. (  7/16/95    rfl added PatchLL
  34.  
  35. Decimal
  36.  
  37. ( Ignore rest-of-line; a comment )
  38. : \  R> Drop ;    \ Exits to word that called Interpret
  39. Immediate
  40.  
  41. \ Display contents of return stack
  42. : trace r0 rp@ (.stack) ;
  43.  
  44. \ Mac File/Record Interface
  45. 4 constant cLen    \ length of a CFA
  46.  
  47. 0 constant nullVal
  48. : nullOSstr ' nullVal +base ;
  49.  
  50. \ ( -- ^wordstring )  retrieve next word from input stream
  51. : @word BL word here ;
  52.  
  53. Create not ' 0= here 4- !
  54.  
  55. : 0,  0 , ;    \ compile an empty cell
  56.  
  57. \ ( -- n )  parse a number from the input stream
  58. : @val  @word number drop ;
  59.  
  60. \ state-smart single cfa compiler
  61. : 'c @pfa cfa  state IF Compile lit , THEN ; Immediate
  62.  
  63. \ Leave code address on stack of word in input stream
  64. : 'Code     @pfa cfa @ [Compile] Literal ; Immediate
  65. 'code quit constant colCode
  66.  
  67. \ make latest word unfindable
  68. : smudge latest 32 toggle ; Immediate
  69.  
  70. \ ( -- 4bytestring )  OS type literal; both upper and lowercase
  71. : 'type
  72.     pad 4 bl fill  tib in + bl enclose (lcWord) here count 4 min
  73.     pad swap cmove  pad @ [Compile] literal
  74. ; Immediate
  75.  
  76. \ true if error; false if no error
  77. : gestalt ( -- response 0 or negativeErr ) [compile] 'type
  78.         state
  79.         IF  compile (gestalt)
  80.         ELSE (gestalt)
  81.         THEN ; immediate
  82.  
  83. \ some Forth83 compatible words
  84. Create >Link '  4- here 4- !    \ ( cfa -- lfa )
  85. Create Link> '  4+ here 4- !    \ ( lfa -- cfa )
  86. Create >Body '  4+ here 4- !    \ ( cfa -- pfa )
  87. Create Body> ' cfa here 4- !    \ ( pfa -- cfa )
  88. : Name>  pfa cfa ;                \ ( nfa -- cfa )
  89. : >Name  4+ nfa ;                \ ( cfa -- nfa )
  90.  
  91. \ Compile an inline string at addr
  92. : str,   c@ 1+ align allot  ;
  93.  
  94. 0 variable buf255 252 allot    \ buffer for string operations
  95.  
  96. \ Convert a string to a Str255 at buf leaving its absolute addr
  97. \ ( addr len addr -- abs:str255 )
  98. : >str255    >R dup R c! R 1+ swap cmove R> +base ;
  99. : Str255     buf255 >str255 ;
  100.  
  101. \ ( b -- )
  102. : Abort"  ?Comp  Compile (Ab")  word"  Str, ;  Immediate
  103.  
  104. \ State-smart HEX literal word - $ 30
  105. : $ Base   >R hex  @val
  106.     [Compile] literal   R> Put base ; Immediate
  107.  
  108. : w @val state
  109.     IF Compile wLitw w, ELSE makeInt THEN ; Immediate
  110.  
  111. hex 
  112. create extend 2017 w, 48c0 w, 2e80 w, $ 4EEB w,  next w,
  113. decimal
  114.  
  115. \ Define state-smart inline string literal
  116. : (lit")  R> count 2dup + align >R ;    \ runTime handler
  117.  
  118. \ ( -- addr len )
  119. : " state
  120.     IF Compile (lit")  word" str,
  121.     ELSE  word" buf255 over c@ 1+ cmove
  122.         buf255 count
  123.     THEN
  124. ; Immediate
  125.  
  126. \ Multiple code field support - see JFAR V1 #1, p.55
  127. \ 10/18/84  CBD  Version 1
  128.  
  129. ( #cfas seq# [prefix] -- addr #cfas nuseq# )
  130. : DO..
  131.     dup 8 > IF  , THEN    \ compile pfa of prefix
  132.     1- 2dup - 4* w,  Here  rot rot        \ (CODEFIELD)
  133.     'code dojmp Here 10 allot 10 cmove    \ DODO,
  134.     [Compile]  ]>  ;
  135.  
  136. \ end a DO.. construct
  137. : ..End Compile ;s  [Compile] <[ ; Immediate
  138.  
  139. \ Get inline code and compile it
  140. : (,code)
  141.     R> dup w@ swap 2+ swap
  142.     2dup + >R  Here swap dup allot cmove ;
  143.  
  144. \ ( addr len -- )  open resource file for name
  145. : OpenResFile
  146.     >R >R word0 R> R> str255
  147.     $ a997 trap  i->l    \ call OpenResFile
  148.     -1 = abort" resource file open failed" ;
  149.  
  150. \ open the yerk system resource file
  151. : openNR  " yerk.rsrc" OpenResFile ;
  152.  
  153. openNR
  154.  
  155. \ ( -- ascii )  Leave ascii val of next char in stream
  156. : Ascii
  157.     tib in + bl enclose (LCword)
  158.     here 1+ c@ [Compile] literal
  159. ; Immediate
  160.  
  161. \ ( resID -- addr len) get the string with resource ID
  162. : getString
  163.     0 swap makeint $ a9ba trap    \ call getString
  164.     dup 0= IF ." GetString Failed" type abort THEN
  165.     >ptr count ;
  166.  
  167. \ ( strID -- )  print string and abort
  168. : die
  169.     ." Error# " dup . ascii : emit
  170.     getString type 5 beep abort ;
  171.  
  172. \ ( nfa -- )  print a name field, filter out garbage
  173. : .name
  174.     count $ 5f and dup 16 >
  175.     IF 2drop ." ??? "
  176.     ELSE type space
  177.     THEN ." ::" ;
  178.  
  179. \ ( b -- ) abort with string whose resID is at IP
  180. : (.rAbort)
  181.     w@(IP) swap
  182.     IF cr ." In " R> drop R cLen - @ >name .name die
  183.     ELSE drop
  184.     THEN ;
  185.  
  186. \ ( b -- ) abort and print resource string if true. use: ?error str#
  187. : ?Error  Compile (.rAbort) @val w, ; Immediate
  188.  
  189. \ ( -- )  print string whose resID is at IP
  190. : (.tStr)  w@(IP) getString type ;
  191.  
  192. \ ( -- )  print string for id# in stream
  193. : type#  Compile (.tStr) @val w, ; Immediate
  194.  
  195. \ ( -- )  print string whose resID is at IP
  196. : (.rStr)  w@(IP) ." Msg# " dup . ascii : emit getString type cr ;
  197.  
  198. \ ( -- )  print " Msg#" & string for id# in stream
  199. : msg#  Compile (.rStr) @val w, ; Immediate
  200.  
  201. \ build a dictionary header without a cfa
  202. : header   create -4 allot ;
  203.  
  204. : Build
  205.     ?error 169    \ not enough codefields
  206.     Compile header  Compile (,code)
  207.     dup 4* W,  0 DO , LOOP
  208. ; Immediate
  209.  
  210. : CodeFields dup ;
  211.  
  212. \  ================ Resources ===========
  213.  
  214. \ ( resID type -- handle )  GetRes support word
  215. : (GetRes)  0 swap rot makeInt $ a9a0 trap ;    \ call GetResource
  216.  
  217. \ ( resID : type -- handle )  Load the resource from the resource file chain
  218. : GetRes
  219.     [Compile] 'type
  220.     state IF Compile (GetRes)
  221.         ELSE (GetRes) THEN
  222. ; Immediate
  223.  
  224. \ Resource support - use: 'type TYPE 1 rsrc sam
  225. 1 codefields
  226.  
  227. \ ( -- ^res ) get the resource into memory
  228.     Do..  dup 4+ w@ swap @ (GetRes)
  229.         dup 0= ?error 170    \ getResource Failed
  230.         >ptr  ..End
  231.  
  232. : rsrc  Build  swap , w,  ..End
  233.  
  234. \ Force printing in hex or decimal
  235. ( n -- )
  236. : .H  base >R  hex     . R> Put base ;
  237. : .D  base >R  decimal . R> Put base ;
  238.  
  239. \ ( -- )  Goto threaded code  whose addr in next dict cell
  240. : (Jmp)  R> @ >R ;
  241.  
  242. \ Patch pfa at old  to exec new
  243. \  takes care of both colon code, local parameters, and code defs
  244. : (patch) \ { pfaOld pfaNew \ colNew -- } \ keep pfaOld and pfaNew on stack and use pick
  245.                                           \ colNew is temporarily put on return stack
  246.     dup cfa @ over =
  247.     IF dup 3 pick cfa !                         \ new word is a code definition, -1
  248.     ELSE dup cfa @ ' colp <> >r                \ be careful...there  may be other ids here
  249.         r                                    \ if new word is colon, set old as too
  250.         IF colCode  ELSE ' colp THEN 3 pick cfa !    \ else store colp def
  251.         'c (jmp) 3 pick r not IF 2+ THEN !        \ put (jmp) in right place
  252.         r not                                \ if new word has local parms
  253.         IF dup w@ 3 pick w! THEN                \ then set number of parms in old
  254.         dup r> not                        \ if new word has local parms
  255.         IF 2+ 3 pick  2+                        \   then store new pfa into old parm field
  256.         ELSE 3 pick                                \   else put it into normal position
  257.         THEN clen + !
  258.     THEN 2drop ;
  259.  
  260.  
  261. \ Patch a word to a newly defined word
  262. \ Use:  Patch oldWord newWord
  263. : Patch  @pfa @pfa (patch) ; Immediate
  264.  
  265. \ patch the named word with the latest definition
  266. : patchL [compile] smudge @pfa latest pfa (patch) ; Immediate
  267.  
  268. \ find the previous word in the dictionary whose name is the same as the
  269. \ latest definition, and patch the previous word to the latest. NOT SMUDGED!!
  270. : patchLL latest n>count str255 -base latest name> >link @ (find)
  271.     0= abort" not found"
  272.     drop latest pfa (patch) ; Immediate
  273.  
  274. \  Forward referencing support
  275. \ ( -- )  declare a new forward reference
  276. : Forward
  277.     <Builds  0, 0,
  278.     Does> cr  msg# 109   cLen -
  279.         nfa  .name  R .h  abort ;
  280.  
  281. : :F  @pfa Here [Compile] ]> ;
  282.  
  283. : ;F (patch) Compile ;s  [Compile]  <[  ; Immediate
  284.  
  285. \ define a Value - a multiple-cfa structure that responds to
  286. \ Put, ++ and its default action is a fetch
  287. : Value
  288.     Header  here 12 allot 'c base
  289.     swap 12 cmove , ;
  290.  
  291. \ a vect responds to Put, Get, and default action is execute
  292. : Vect
  293.     Header here 12 allot 'c vModel swap
  294.     12 cmove  , ;
  295.  
  296. \ ( -- #cells)
  297. : mDepth  m0  mp@ - 4 / ;
  298. : rDepth  r0  rp@ - 4 / 2- ;    \ 2- accounts for threading of rDepth & rp@
  299.  
  300. : errBeep  5 beep ;
  301.  
  302. \ ( ^obj -- )
  303. : .ClassName  cfa @ nfa .name ;
  304.  
  305. \ Error routine for objects prints class name first
  306. \ Only valid inside of a method.
  307. : (classErr")
  308.     w@(IP) swap
  309.     IF  cr  msg# 104
  310.         copym .className  copym .h space die
  311.     ELSE  drop  THEN ;
  312.  
  313. : classErr"  Compile (classerr") @val w, ; Immediate
  314.  
  315. -39 Constant EOF
  316.  
  317. \ pseudo-assembler macros
  318. : popD0        $ 201F w, ; Immediate    \ MOVE.L (A7)+,D0
  319. : popA0        $ 205F w, ; Immediate    \ MOVE.L (A7)+,A0
  320. : pushD0    $ 2F00 w, ; Immediate    \ MOVE.L D0,-(A7)
  321. : pushA0    $ 2F08 w, ; Immediate    \ MOVE.L A0,-(A7)
  322. : next,        $ 4EEB w,  next w, ; Immediate
  323.  
  324. \ Define these code words above the nucleus
  325. \ this allows getMtxt to Find them at run time on a sealed nucleus
  326. Create null next,
  327. Create bye $ a9f4 w,
  328.  
  329. \ ( abs:addr len -- )  map string to upper case
  330. Create >uc
  331.     popD0
  332.     popA0
  333.     $ a054 w,    \ call uprString
  334.     next,
  335.  
  336. \ primitive ascii to binary conversion
  337. hex
  338. create (asc>bin)    ( str255 -- n)
  339.     2057    w,        \ movea.l    (sp),a0
  340.     3f3c0001 ,        \ move.w    #1,-(sp)
  341.     7001     w,        \ moveq        #1,d0
  342.     a9ee     w,        \ call pack7
  343.     2e80     w,        \ move.l    d0,(sp)
  344. next,
  345.  
  346. : asc>bin ( addr len -- n) str255 (asc>bin) ;
  347.  
  348. \ string is put into pad+64
  349. hex
  350. create bin>asc        ( n -- addr len )
  351.     201f      w,            \ move.l    (sp)+,d0
  352.     207c w, pad ,        \ movea.l    YERK[pad],a0
  353.     d1cb     w,            \ adda.l    a3,a0
  354.     d1fc w, 00000040 ,    \ adda.l    #64,a0
  355.     4267     w,            \ clr.w        -(sp)
  356.     a9ee      w,            \ _numToString
  357.     4280      w,            \ clr.l        d0
  358.     1018      w,            \ move.b    (a0)+,d0
  359.     91cb      w,            \ suba.l    a3,a0
  360.     2f08      w,            \ move.l    a0,-(sp)
  361.     2f00     w,            \ move.l    d0,-(sp)
  362. next,
  363. decimal
  364.  
  365. \ ==========  Various utility words needed  later
  366.  
  367. \ Become allows restarting at a given word, assuring that all stacks
  368. \ are empty.  This is necessary in menu handlers and other areas
  369. \ that could create indefinite nesting situations.
  370. 'c quit Vect becomeCFA
  371.  
  372. : Bi  sp! rp! mp!  becomeCfa quit ;
  373.  
  374. : (be)  R> @ put becomeCfa bi ;
  375.  
  376. \ use: Become newWord - compiles code to Be at runtime
  377. : Become
  378.     @pfa cfa State
  379.     IF  Compile (be) , ELSE put becomeCfa bi THEN
  380. ; Immediate
  381.  
  382. cLen CONSTANT CFALEN
  383. \ stack compiled list of values starting at IP
  384. : (lits)
  385.     R> dup w@  4* swap 2+ swap over +
  386.     dup   >R  swap
  387.     DO i@ 4 +LOOP ;
  388.  
  389. \ ( #lits -- #lits )  Compile header for list of literals if compile state
  390. : ,(lits)   state IF 'c (Lits) , dup W, THEN  ;
  391.  
  392. \ state-smart word to compile or stack a list of cfas
  393. \ ( #cfas -- )  pull words from stream and compile cfas
  394. : 'cfas
  395.     ,(lits) 0
  396.     DO  @pfa cfa  State IF , THEN LOOP
  397. ; Immediate
  398.  
  399. \ ( len -- )  Clear and allocate at here; check for room
  400. : Reserve  dup room 32 - > ?error 189
  401.      Here over erase allot ;
  402.  
  403. \ String constant leaves Addr Len at runtime
  404. : Scon
  405.     <Builds  word" Str,
  406.     Does>  Count ;
  407.  
  408. \ ( addr1 len1 addr2 len2 -- b )  String compare
  409. : S=
  410.     >R  Swap R>  Over =
  411.     IF  (s=)  ELSE 2drop drop 0 THEN ;
  412.  
  413. \ ( adr chr -- adrnext adr len )  Parser
  414. : parse
  415.     enclose
  416.     4 pick + 2swap >R R + rot R> -
  417. ;
  418.  
  419. \ CASE should be used for non-contiguous values.
  420. \ this is a modified  Eaker/Duncan model.
  421. \ ofBr takes branch at IP 1 nest back, and preserves val if
  422. \ branch taken, else it is dropped.
  423. : Case   ?Comp  csp !Csp  4 ; Immediate
  424.  
  425. \ ( val tst -- )  ofBr will take branch if 0 is on stack
  426. : (of) over = ofBr ;
  427.  
  428. \ ( val loTst hiTst -- )  Branch if not within inclusive range
  429. : (rof)   rot >R R >= swap R <= And R> swap  ofBr ;
  430.  
  431. : Of     4 ?Pairs Compile (of) Here 0, 5 ; Immediate
  432.  
  433. : rangeOf  4 ?Pairs Compile (rof) Here 0, 5 ; Immediate
  434.  
  435. : EndOf  5 ?Pairs Compile Branch Here 0,
  436.      swap 2 [Compile] THEN 4 ; Immediate
  437.  
  438. : EndCase  4 ?Pairs Compile drop
  439.     BEGIN  sp@  csp  = not
  440.     WHILE  2 [Compile] THEN
  441.     REPEAT   Put csp  ; Immediate
  442.  
  443. \ the Select structure should be used when dispatching execution
  444. \ on contiguous indices starting at 0.  It is smaller and faster
  445. \ than the equivalent CASE construct.
  446. \ An indexed CASE construct for compact, fast execution
  447. \ Runtime word for indexed case execution
  448.  
  449.  -1 Value CaseIndex
  450.  
  451. : (Select)
  452.     Abs R>  @ Dup 4+ >R  Swap  1+
  453.     4* Over Swap - Swap @ Max  @  >R ;
  454.  
  455. \ Begin an indexed case structure - see Forth Dimensions vII p.51
  456. : Select{
  457.     Compile (Select)  Here 0, 0  0 Put CaseIndex
  458.     [Compile]  <[
  459. ; Immediate
  460.  
  461. : Is{
  462.     ?Exec CaseIndex -
  463.     ?error 102
  464.     CaseIndex  1+ put caseIndex
  465.     240  [Compile] ]>
  466. ; Immediate
  467.  
  468. : }End
  469.     240 ?Pairs
  470.     Compile  ;S [Compile] <[  Here
  471. ; Immediate
  472.  
  473. : Default{
  474.     [Compile]  ]>
  475. ; Immediate
  476.  
  477. : }Select
  478.     [Compile] ]>   Compile  ;S  ,  Here  Pushm
  479.     BEGIN  Dup   WHILE  ,  REPEAT  Drop
  480.     Dup 4+ ,  Here Swap !  PopM  4-  ,
  481. ; Immediate
  482.  
  483. <" Args
  484.