preForth/simpleForth-i386-backend.pre

   1 \ simpleForth i386 backend
   2
   3 \ alter substitutes non-letter characters by upper case letters (to aid assemblers to deal with labels).
   4 : replace ( c1 -- c2 c3 2 | c2 1 )
   5     >r
   6     'A' 1 r> ''' case? ?exit >r 2drop
   7     'B' 1 r> '\' case? ?exit >r 2drop
   8     'C' 1 r> ':' case? ?exit >r 2drop
   9     'D' 1 r> '.' case? ?exit >r 2drop
  10     'E' 1 r> '=' case? ?exit >r 2drop
  11     'F' 1 r> '[' case? ?exit >r 2drop
  12     'G' 1 r> '>' case? ?exit >r 2drop
  13     'H' 1 r> ']' case? ?exit >r 2drop
  14     'I' 1 r> '1' case? ?exit >r 2drop
  15     'J' 1 r> '2' case? ?exit >r 2drop
  16     'K' 1 r> '/' case? ?exit >r 2drop
  17     'L' 1 r> '<' case? ?exit >r 2drop
  18     'M' 1 r> '-' case? ?exit >r 2drop
  19     'N' 1 r> '#' case? ?exit >r 2drop
  20     'O' 1 r> '0' case? ?exit >r 2drop
  21     'P' 1 r> '+' case? ?exit >r 2drop
  22     'Q' 1 r> '?' case? ?exit >r 2drop
  23     'R' 1 r> '"' case? ?exit >r 2drop
  24     'S' 1 r> '!' case? ?exit >r 2drop
  25     'T' 1 r> '*' case? ?exit >r 2drop
  26     'U' 1 r> '(' case? ?exit >r 2drop
  27     'V' 1 r> '|' case? ?exit >r 2drop
  28     'W' 1 r> ',' case? ?exit >r 2drop
  29     \ also 'X' for machine code
  30     'Y' 1 r> ')' case? ?exit >r 2drop
  31     'Z' 1 r> ';' case? ?exit >r 2drop
  32     'U' 'T' 2 r> '{' case? ?exit >r drop 2drop
  33     'T' 'Y' 2 r> '}' case? ?exit >r drop 2drop
  34     r> 1
  35 ;
  36
  37 \ alter substitutes all non-letter characters by upper case letters.
  38 : alter ( S1 -- S2 )
  39     '_' 1 rot ?dup 0= ?exit nip nip
  40     \ dup 0= ?exit
  41     swap >r 1- alter  r> swap >r replace r> + ;
  42
  43 \ ------------
  44 \ output words
  45 \ ------------
  46 \ Output is done by emit.
  47 \ We define convenience words of the form ."xxx" to output xxx and >"xxx" to output xxx on a new line indented by a tab.
  48
  49 : ."dd" ( -- )
  50     'D' emit 'D' emit space ;
  51
  52 : >"dd" ( -- )
  53     cr tab ."dd" ;
  54
  55 : ."db" ( -- )
  56     'D' emit 'B' emit space ;
  57
  58 : >"db" ( -- )
  59     cr tab ."db" ;
  60
  61 : ."dup" ( -- )
  62     'd' emit 'u' emit 'p' emit ;
  63
  64 : ."nest" ( -- )
  65     'n' 'e' 's' 't' 4 alter show ;
  66
  67 : ."unnest" ( -- )
  68     'u' 'n' 'n' 'e' 's' 't' 6 alter show ;
  69
  70 : ."lit" ( -- )
  71     'l' 'i' 't' 3 alter show ;
  72
  73 \ ------------
  74 \ Compiling words
  75 \ ------------
  76
  77 : escaped ( S1 -- S2 )
  78     dup 0= ?exit
  79     swap >r 1- escaped  r> swap 1+ over '"' - ?exit  '"' swap 1+ ;
  80
  81 \ ,string compiles the topmost string as a sequence of numeric DB values.
  82 : ,string ( S -- )
  83     >"db"  '"' emit  escaped show  '"' emit ;
  84     \ ?dup 0= ?exit
  85     \ dup roll >"db" u.  \ 1st char
  86     \ 1- ,string ;
  87
  88 \ reproduce a verbatim line
  89 : ,line ( S -- )
  90     show ;
  91
  92 \ compile a reference to an invoked word
  93 : ,word ( S -- )
  94    ."dd" alter show ;
  95
  96 \ compile a reference to an invoked word on a new line
  97 : ,>word ( S -- )
  98     >"dd" alter show ;
  99
 100 \ compile reference to nest primitive
 101 : ,nest ( -- )
 102     ."dd" ."nest" ;
 103
 104
 105 \ compile reference to unnest primitive
 106 : ,unnest ( -- )
 107     >"dd" ."unnest"
 108     cr ;
 109
 110 \ reserve space
 111 : ,allot ( u -- )
 112     >"db" u. space ."dup" '(' emit '0' emit ')' emit ;
 113
 114 \ compile byte
 115 : ,byte ( u -- )
 116    >"db" space u. ;
 117
 118 \ compile signed number
 119 : ,n ( n -- )
 120     >"dd" . ;
 121
 122 \ compile unsigned number
 123 : ,u ( u -- )
 124     >"dd" u. ;
 125
 126 \ compile literal
 127 : ,_lit ( S -- )
 128     >"dd" ."lit"  ,>word ;
 129
 130 \ compile literal
 131 : ,lit ( x -- )
 132     >"dd" ."lit"  ,n ;
 133
 134 \ output string as comment
 135 : ,comment ( S -- )
 136     cr tab ';' emit  space show ;
 137
 138 : ,label ( L -- )
 139     cr show ':' emit tab ;
 140
 141 \ create a new symbolic label
 142 : label ( S -- )
 143     alter ,label ;
 144
 145 \ body calculates the name of the body from a token
 146 : body ( S1 -- S2 )
 147    'X' swap 1+ ;
 148
 149 \ ,codefield compiles the code field of primitive
 150 : ,codefield ( S -- )
 151    body _dup ,word label ;
 152
 153 : ,code ( S -- )
 154     _dup label
 155     ,codefield ;
 156
 157 : ,end-code ( -- )
 158   cr ;
 159
 160 \ -----------------------------------
 161 \ tail call optimization    tail word ;  ->  [ ' word >body ] literal >r ;
 162
 163 : bodylabel ( S --  )
 164    body label ;
 165
 166 \ ,tail compiles a tail call
 167 : ,tail  ( S -- )
 168    body ,_lit
 169    '>' 'r' 2 ,>word ;
 170
 171 \ Handle conditionals
 172
 173 \ initialize local labels
 174 : (label ( S1 -- S1 S2 0 )
 175     alter '_' swap 1+  '_' swap 1+  0 ;
 176
 177 \ deinitialize local labels
 178 : label) ( S m -- )
 179     drop _drop ;
 180
 181 : +label ( L1 i -- L1 L2 i+1 )
 182     >r _dup   nip r> dup >r '0' + swap r> 1+ ;
 183
 184 : ."branch" ( -- )
 185     'b' 'r' 'a' 'n' 'c' 'h' 6 alter show ;
 186
 187 : ."?branch" ( -- )
 188     '?' 'b' 'r' 'a' 'n' 'c' 'h' 7 alter show ;
 189
 190 : ,branch ( L -- )
 191     >"dd" ."branch"   >"dd" show ;
 192
 193 : ,?branch ( L -- )
 194     >"dd" ."?branch"  >"dd" show ;
 195
 196 \ codefields
 197
 198 : ."dovar" ( -- )
 199     'd' 'o' 'v' 'a' 'r' 5 alter show ;
 200
 201 : ."doconst" ( -- )
 202     'd' 'o' 'c' 'o' 'n' 's' 't' 7 alter show ;
 203
 204 : ,dovar ( -- )
 205     ."dd" ."dovar" ;
 206
 207 : ,doconst ( -- )
 208     ."dd" ."doconst" ;
 209
 210
 211 \ prologue and epilogue
 212
 213 : ,opening  ( -- )
 214 ;
 215
 216 : ."done" ( -- )
 217     ';' emit space 'd' emit 'o' emit 'n' emit 'e' emit ;
 218
 219 : ."last:" ( -- )
 220     ';' emit space 'l' emit 'a' emit 's' emit 't' emit ':' emit space ;
 221
 222 : ,ending ( S -- )
 223     'l' 'a' 's' 't' 4  0 header cr tab _dup label ,dovar bodylabel _dup ."dd" alter show
 224     100000 ,allot
 225     'm' 'e' 'm' 't' 'o' 'p' 6 ,label  0 ,u
 226     cr ."last:" alter show
 227     cr ."done" cr ;
 228
 229 \ --------------
 230 \ Create headers
 231 \ --------------
 232 \ preForth can optionally also create word headers with a very simple layout.
 233 \
 234 \ Word creation is split into parts
 235 \    - header     creates a dictionary header from a string on the stack.
 236 \    - label      creates the assembler label (with symbol substitution)
 237 \    - body       defined later by code (assembly code) or : (threaded code)
 238 \
 239 \ Headers are linked in a single linked list ending in 0.
 240 \ The link-label name of the latest definition is always as a string on top of stack.
 241 \ Creating a new header puts this in the link field of the new definition and
 242 \ replaces the link-label with the current one.
 243
 244
 245 \ link to previous header c. d is new header.
 246 : ,link ( S1 S2 -- S3 S2 )
 247     '_' swap 1+ _dup label  \  d_:
 248     _swap  ,word  _dup
 249     1- nip ;
 250
 251 \ create a new header with given name S2 and flags, S1 is the last link label
 252 : header ( S1 S2 flags -- S3 S2 )
 253     >r
 254     ,link        \ link
 255     r>  ,u       \ flags
 256     dup ,u       \ len
 257     _dup ,string \ name
 258 ;
 259