level1/64_voc_order.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;; shows current search order
   8 : ORDER  ( -- )
   9   ." CONTEXT:"
  10   context
  11   begin dup (forth-voc-stack) u>= while
  12     dup @ space vocid.
  13     cell-
  14   repeat
  15   drop
  16   space ." (ROOT)\nCURRENT: "
  17   current @ vocid.
  18   ."  (mode: "
  19    (CURRENT-CREATE-MODE) (WFLAG-HIDDEN) and if ." private" else ." public" endif
  20   ." )\n"
  21 ;
  22
  23 ;; makes all newly created words public
  24 : <public-words>  ( -- )
  25   (CURRENT-CREATE-MODE) (WFLAG-HIDDEN) ~and to (CURRENT-CREATE-MODE)
  26 ;
  27
  28 ;; makes all newly created words hidden
  29 : <hidden-words>  ( -- )
  30   (CURRENT-CREATE-MODE) (WFLAG-HIDDEN) or to (CURRENT-CREATE-MODE)
  31 ;
  32
  33 ;; sets top context vocabulary as the current one
  34 ;; resets current mode to public
  35 : DEFINITIONS  ( -- )
  36   context @ current ! <public-words>
  37 ;
  38
  39 ;; makes top context vocabulary as the only one, and makes it current too
  40 ;; resets current mode to public
  41 : ONLY  ( -- )
  42   (forth-voc-stack) to context
  43   ['] forth voc-cfa->vocid context !
  44   definitions
  45 ;
  46
  47 ;; duplicates top context vocabulary, so it could be replaced with another one
  48 ;; resets current mode to public
  49 : ALSO  ( -- )
  50   ;; check for vocstack overflow
  51   context cell+ dup (forth-voc-stack-end) u>= ERR-VOCABULARY-STACK-OVERFLOW ?error
  52   context @ over !
  53   to context
  54 ;
  55
  56 ;; drop topmost context vocabulary
  57 ;; resets current mode to public
  58 : PREVIOUS  ( -- )
  59   ;; check for vocstack underflow
  60   context (forth-voc-stack) u>= if
  61     context cell- to context
  62   endif
  63 ;
  64
  65
  66 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  67 : forth-wordlist  ( -- vocid )
  68   vocid: forth
  69 ;
  70
  71 ;; 1: immediate; -1: normal
  72 : search-wordlist  ( addr count vocid -- cfa 1 // cfa -1 // 0 )
  73   (wfind-flags>r)
  74   [ (wflag-smudge) (wflag-hidden) or ] literal voc-find-replace-mask
  75   voc-find-str
  76   (wfind-r>flags)
  77 ;
  78
  79 : get-order  ( -- vocids... vocid-count )
  80   (forth-voc-stack) begin dup context u<= while dup @ swap cell+ repeat drop
  81   context (forth-voc-stack) - 2 rshift 1+  ;; counter
  82 ;
  83
  84 : set-order  ( vocids... vocid-count -- )
  85   only dup +if
  86     dup >r  ;; save counter, so we will drop all arguments in any case
  87     (forth-voc-stack-end) (forth-voc-stack) - 2 rshift  ;; maximum
  88       \ endcr ." maxvocs: " dup . cr
  89     min
  90     ;; set context
  91     dup 1- cells (forth-voc-stack) + to context
  92     (forth-voc-stack) swap
  93     1 swap do i pick over ! cell+ -1 +loop
  94     drop
  95     ;; drop all args
  96     r> 0 do drop loop
  97   else
  98     drop
  99   endif
 100 ;
 101
 102
 103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 104 : (vocorder>r)  ( -- | vocids... vocid-count current )
 105   r>  (forth-voc-stack) begin dup context u<= while dup @ >r cell+ repeat drop
 106   context (forth-voc-stack) - 2 rshift 1+ >r  ;; counter
 107   current @ >r  >r
 108 ;
 109
 110 : (r>vocorder)  ( | vocids... vocid-count current -- )
 111   r>  r> current ! r@ if
 112     r@ 1- cells (forth-voc-stack) + dup to context
 113     r> begin dup while 1- swap r> over ! cell- swap repeat 2drop
 114   else
 115     rdrop only
 116   endif
 117   >r
 118 ;