libs/ufe/stdlib.f

   1 ;; ////////////////////////////////////////////////////////////////////////// //
   2 ;; ZX forth word types
   3
   4  0 CONSTANT FWT-OTHER
   5  1 CONSTANT FWT-CODE
   6  2 CONSTANT FWT-FORTH
   7  3 CONSTANT FWT-VAR
   8  4 CONSTANT FWT-DVAR
   9  5 CONSTANT FWT-CONST
  10  6 CONSTANT FWT-VALUE
  11  7 CONSTANT FWT-DCONST
  12  8 CONSTANT FWT-DEFER
  13  9 CONSTANT FWT-DOES
  14
  15
  16 ;; ////////////////////////////////////////////////////////////////////////// //
  17 ;; ZX forth flag bits
  18
  19 0x0001 CONSTANT FWF-BRANCH
  20 0x0002 CONSTANT FWF-NUMLIT
  21 0x0004 CONSTANT FWF-STRLIT
  22 0x0008 CONSTANT FWF-NORETURN
  23 0x0010 CONSTANT FWF-NOTURNKEY
  24 0x0020 CONSTANT FWF-IMMEDIATE
  25 0x0040 CONSTANT FWF-UNCONDITIONAL  ;; unconditional branch
  26 0x0080 CONSTANT FWF-USED-MARK
  27 0x0100 CONSTANT FWF-CODEBLOCK
  28 0x0200 CONSTANT FWF-COMPILE
  29
  30
  31 ;; ////////////////////////////////////////////////////////////////////////// //
  32 \ : 1+!  ( addr -- )  DUP @ 1+ SWAP !  ;
  33
  34 32 CONSTANT BL
  35
  36 \ : SPACES  ( n -- )
  37 \   DUP 0> IF 0 DO SPACE LOOP ELSE DROP ENDIF
  38 \ ;
  39
  40 : [CHAR]  ( -- )
  41   BL WORD COUNT
  42   1 = IFNOT ." [CHAR] expects a char" UFE-FATAL ENDIF
  43   C@ LITERAL
  44 ; IMMEDIATE
  45
  46
  47 : ZX-BCOUNT  ( addr -- zxaddr+1 bytecount )
  48   TOZX
  49   DUP C@
  50   SWAP 1+ SWAP
  51 ;
  52
  53
  54 : ABS  ( n -- n )  DUP 0< IF NEGATE ENDIF ;
  55
  56
  57 ;; ////////////////////////////////////////////////////////////////////////// //
  58 : STR-CAT-CHAR  ( addr count char -- addr count+ )
  59   >R 2DUP + R> SWAP C!
  60   1+
  61 ;
  62
  63 : STR-CAT  ( addr count addr1 count1 -- addr count+count1 )
  64   ?DUP IF
  65     OVER + SWAP DO
  66       I C@ STR-CAT-CHAR
  67     LOOP
  68   ELSE
  69     DROP
  70   ENDIF
  71 ;
  72
  73 ;; copy string to PAD (count is not set)
  74 : STR-TO-PAD  ( addr count -- pad+1 count )
  75   PAD 1+ 0 2SWAP STR-CAT
  76 ;
  77
  78
  79 ;; ////////////////////////////////////////////////////////////////////////// //
  80 0 VARIABLE (#BUF-CURR-OFS)
  81 312 VALUE (#BUF-PAD-OFS)
  82
  83 : (#BUF)  ( -- addr ) PAD (#BUF-PAD-OFS) + ;
  84
  85 : HOLD  ( ch -- )
  86   (#BUF) (#BUF-CURR-OFS) @ -
  87   DUP HERE <= IF " number too long" UFE-FATAL ENDIF
  88   C!
  89   (#BUF-CURR-OFS) 1+!
  90 ;
  91
  92 : <#  ( n -- n )
  93   0 (#BUF-CURR-OFS) !
  94 ;
  95
  96 : <#n  ( n -- n )  \ exactly the same as "<#", but different for ZX
  97   <#
  98 ;
  99
 100 : #>  ( n -- addr count )
 101   DROP
 102   (#BUF) (#BUF-CURR-OFS) @ - 1+
 103   (#BUF-CURR-OFS) @
 104 ;
 105
 106 : #  ( n -- n )
 107   DUP BASE @ UMOD 48 +    ;; ( n ch )
 108   DUP 57 > IF 7 + ENDIF   ;; ( n ch )
 109   HOLD                    ;; ( n )
 110   BASE @ U/               ;; ( n/base )
 111 ;
 112
 113 : #S  ( n -- n )
 114   BEGIN
 115     #
 116   DUP NOT UNTIL
 117 ;