home *** CD-ROM | disk | FTP | other *** search
/ Dream 52 / Amiga_Dream_52.iso / RiscOS / APP / DEVS / FORTH / WIMPFO.ZIP / !WimpForth / order < prev    next >
Text File  |  1996-03-21  |  5KB  |  150 lines
  1. \ Vocabulary search order specification
  2.  
  3. cr .( Loading Vocabulary support...)
  4.  
  5. \ provides WORDLIST
  6. \          VOCABULARY name
  7. \          ONLY
  8. \          ALSO
  9. \          PREVIOUS
  10. \          ORDER
  11. \          VOCS
  12. \          FORTH
  13.  
  14. : #WORDLIST     ( #threads -- wid )
  15.                 1 16 0 do 2dup <= ?leave 2* loop nip
  16.                 2 MAX DUP , VOC-LINK LINK,
  17.                 HERE DUP>R OVER CELLS ALLOT
  18.                            SWAP CELLS ERASE R> ;
  19.  
  20. : WORDLIST      ( -- wid )
  21.                 #THREADS #WORDLIST ;
  22.  
  23. warning off
  24.  
  25. : #VOCABULARY   ( #threads -<name>- )
  26.                 CREATE  #WORDLIST DROP
  27.                 DOES>   BODY> VCFA>VOC CONTEXT ! VOC-ALSO ;
  28.  
  29. : VOCABULARY    ( -- )
  30.                 #THREADS #VOCABULARY ;
  31.  
  32. warning on
  33.  
  34. VOCABULARY ROOT 
  35.  
  36. ' ROOT call@ ' FORTH call! \ Patch the FORTH vocabulary to be like other vocabularies
  37.  
  38. : ALSO          ( -- )
  39.                 CONTEXT DUP CELL+  #VOCS 1- CELLS MOVE  ;
  40.  
  41. : ONLY          ( -- )
  42.                 CONTEXT #VOCS CELLS ERASE  ROOT ALSO VOC-ALSO ;
  43.  
  44. : PREVIOUS      ( -- )
  45.                 CONTEXT DUP CELL+ SWAP  #VOCS 1- CELLS MOVE
  46.                 CONTEXT @ 0=
  47.                 IF      ROOT
  48.                 THEN    VOC-ALSO ;
  49.  
  50. : FORTH-WORDLIST ( -- wid )
  51.                 ['] FORTH VCFA>VOC ;
  52.  
  53. : GET-CURRENT   ( -- wid )
  54.                 CURRENT @ ;
  55.  
  56. : SET-CURRENT   ( wid -- )
  57.                 CURRENT ! ;
  58.  
  59. : GET-ORDER     ( -- widn .. wid1 n )
  60.                 DEPTH >R
  61.                 0 #VOCS 1-
  62.                 DO      CONTEXT I CELLS+ @
  63.                         DUP 0=
  64.                         IF      DROP
  65.                         THEN
  66.             -1 +LOOP    DEPTH R> - ;
  67.  
  68. : SET-ORDER     ( widn .. wid1 n -- )
  69.                 DUP 0<
  70.                 IF      DROP ONLY
  71.                 ELSE    CONTEXT #VOCS CELLS ERASE
  72.                         0
  73.                         ?DO     CONTEXT I CELLS+ !
  74.                         LOOP    VOC-ALSO
  75.                 THEN    ;
  76.  
  77. : ORDER         ( -- )
  78.                 CR ." Context: " CONTEXT
  79.                 #VOCS 0
  80.                 DO      DUP @ ?DUP
  81.                         IF      voc>vcfa >NAME .ID 14 ?CR
  82.                         THEN    CELL+
  83.                 LOOP    DROP
  84.                 CR ." Current: " CURRENT @  voc>vcfa >NAME .ID    ;
  85.  
  86. : VOCS          ( -- )
  87.                 cr ." Vocabularies    #Threads  #Words  #Average"
  88.                 cols 59 >
  89.                 if ."     #Headerbytes"
  90.                 then
  91.                 cr VOC-LINK @
  92.                 BEGIN   DUP VLINK>VOC
  93.                         dup voc>vcfa call@
  94.                         dup  doClass  =
  95.                         swap do|Class = or 0=
  96.                         IF      dup voc>vcfa >NAME .ID  18 #tab
  97.                                 dup voc#threads         dup>r 4 .r
  98.                                         0 to words-cnt
  99.                                         0 to header-cnt
  100.                                     count-voc words-cnt dup   9 .r
  101.                                                     10 * r> / 8 .r.1 
  102.                                 cols 59 >
  103.                                 if      header-cnt           15 .r
  104.                                 then
  105.                                 cr
  106.                         ELSE    DROP
  107.                         THEN    @ DUP 0=
  108.                 UNTIL   DROP
  109.                    ." ----------------------------------------"
  110.                 cols 59 >
  111.                 if ." --------------"
  112.                 then
  113.                 cr ." Total System Words: " count-words 11 .r 
  114.                 cols 59 >
  115.                 if ."   Header bytes:"      header-cnt   8 .r
  116.                 then    cr ;
  117.  
  118. ROOT DEFINITIONS
  119.  
  120. : FORTH             FORTH ;
  121. : FORTH-WORDLIST    FORTH-WORDLIST ;
  122. : SET-ORDER         SET-ORDER ;
  123.  
  124. ONLY FORTH ALSO DEFINITIONS
  125.  
  126. : anyfind       ( a1 -- a2 f1 )         \ find a word in any vocabulary
  127.                 dup c@ 0=
  128.                 if      0 exit
  129.                 then
  130.                 ?uppercase find ?dup 0=
  131.                 if      context @ >r
  132.                         voc-link
  133.                         begin   @ ?dup
  134.                         while   dup vlink>voc ( #threads cells - )
  135.                                 dup voc>vcfa @
  136.                                 dup   doClass =
  137.                                 swap do|Class = or 0=
  138.                                 if      context !  \ set voc
  139.                                         over find ?dup
  140.                                         if      2swap 2drop
  141.                                                 r> context !
  142.                                                 EXIT      \ *** EXITS HERE ****
  143.                                         then
  144.                                 then    drop
  145.                         repeat  0
  146.                         r> context !
  147.                 then    ;
  148.  
  149.  
  150.