qemu/roms/SLOF/slof/fs/fcode/1275.fs

   1 \ *****************************************************************************
   2 \ * Copyright (c) 2004, 2011 IBM Corporation
   3 \ * All rights reserved.
   4 \ * This program and the accompanying materials
   5 \ * are made available under the terms of the BSD License
   6 \ * which accompanies this distribution, and is available at
   7 \ * http://www.opensource.org/licenses/bsd-license.php
   8 \ *
   9 \ * Contributors:
  10 \ *     IBM Corporation - initial implementation
  11 \ ****************************************************************************/
  12
  13
  14 : fcode-revision ( -- n )
  15   00030000 \ major * 65536 + minor
  16   ;
  17
  18 : b(lit) ( -- n )
  19   next-ip read-fcode-num32
  20   ?compile-mode IF literal, THEN
  21   ;
  22
  23 : b(")
  24   next-ip read-fcode-string
  25   ?compile-mode IF fc-string, align postpone count THEN
  26   ;
  27
  28 : b(')
  29   next-ip read-fcode# get-token drop ?compile-mode IF literal, THEN
  30   ;
  31
  32 : ?jump-direction ( n -- )
  33    dup 8000 >= IF
  34       10000 -           \ Create cell-sized negative value
  35    THEN
  36    fcode-offset -       \ IP is already behind offset, so subtract offset size
  37 ;
  38
  39 : ?negative
  40   8000 and
  41   ;
  42
  43 : dest-on-top
  44   0 >r BEGIN dup @ 0= WHILE >r REPEAT
  45        BEGIN r> dup WHILE swap REPEAT
  46   drop
  47   ;
  48
  49 : read-fcode-offset
  50    next-ip
  51    ?offset16 IF
  52       read-fcode-num16
  53    ELSE
  54       read-byte
  55       dup 80 and IF FF00 or THEN       \ Fake 16-bit signed offset
  56    THEN
  57 ;
  58
  59 : b?branch ( flag -- )
  60    ?compile-mode IF
  61       read-fcode-offset ?negative IF
  62          dest-on-top postpone until
  63       ELSE
  64          postpone if
  65       THEN
  66    ELSE
  67       ( flag ) IF
  68          fcode-offset jump-n-ip       \ Skip over offset value
  69       ELSE
  70          read-fcode-offset
  71          ?jump-direction jump-n-ip
  72       THEN
  73    THEN
  74 ; immediate
  75
  76 : bbranch ( -- )
  77    ?compile-mode IF
  78       read-fcode-offset
  79       ?negative IF
  80          dest-on-top postpone again
  81       ELSE
  82          postpone else
  83          get-ip next-ip fcode@ B2 = IF
  84             drop
  85          ELSE
  86             set-ip
  87          THEN
  88       THEN
  89    ELSE
  90       read-fcode-offset ?jump-direction jump-n-ip
  91    THEN
  92 ; immediate
  93
  94 : b(<mark) ( -- )
  95   ?compile-mode IF postpone begin THEN
  96   ; immediate
  97
  98 : b(>resolve) ( -- )
  99   ?compile-mode IF postpone then THEN
 100   ; immediate
 101
 102 : b(;)
 103    <semicolon> compile, reveal
 104    postpone [
 105 ; immediate
 106
 107 : b(:) ( -- )
 108   <colon> compile, ]
 109   ; immediate
 110
 111 : b(case) ( sel -- sel )
 112   postpone case
 113   ; immediate
 114
 115 : b(endcase)
 116   postpone endcase
 117   ; immediate
 118
 119 : b(of)
 120   postpone of
 121   read-fcode-offset drop   \ read and discard offset
 122   ; immediate
 123
 124 : b(endof)
 125   postpone endof
 126   read-fcode-offset drop
 127   ; immediate
 128
 129 : b(do)
 130   postpone do
 131   read-fcode-offset drop
 132   ; immediate
 133
 134 : b(?do)
 135   postpone ?do
 136   read-fcode-offset drop
 137   ; immediate
 138
 139 : b(loop)
 140   postpone loop
 141   read-fcode-offset drop
 142   ; immediate
 143
 144 : b(+loop)
 145   postpone +loop
 146   read-fcode-offset drop
 147   ; immediate
 148
 149 : b(leave)
 150   postpone leave
 151   ; immediate
 152
 153
 154 0 VALUE fc-instance?
 155 : fc-instance  ( -- )   \ Mark next defining word as instance-specific.
 156    TRUE TO fc-instance?
 157 ;
 158
 159 : new-token  \ unnamed local fcode function
 160   align here next-ip read-fcode# 0 swap set-token
 161   ;
 162
 163 : external-token ( -- )  \ named local fcode function
 164   next-ip read-fcode-string
 165   \ fc-instance? IF cr ." ext instance token: " 2dup type ."  in " pwd cr THEN
 166   header         ( str len -- )  \ create a header in the current dictionary entry
 167   new-token
 168   ;
 169
 170 : new-token
 171    eva-debug? IF
 172       s" x" get-ip >r next-ip read-fcode# r> set-ip (u.) $cat strdup
 173       header
 174    THEN
 175    new-token
 176 ;
 177
 178 \ decide wether or not to give a new token an own name in the dictionary
 179 : named-token
 180    fcode-debug? IF
 181       external-token
 182    ELSE
 183       next-ip read-fcode-string 2drop       \ Forget about the name
 184       new-token
 185    THEN
 186 ;
 187
 188 : b(to) ( val -- )
 189    next-ip read-fcode#
 190    get-token drop                           ( val xt )
 191    dup @                                    ( val xt @xt )
 192    dup <value> =  over <defer> = OR IF
 193       \ Destination is value or defer
 194       drop
 195       >body cell -
 196       ( val addr )
 197       ?compile-mode IF
 198          literal, postpone !
 199       ELSE
 200          !
 201       THEN
 202    ELSE
 203       <create> <> IF                         ( val xt )
 204          TRUE ABORT" Invalid destination for FCODE b(to)"
 205       THEN
 206       dup cell+ @                           ( val xt @xt+1cell )
 207       dup <instancevalue> <>  swap <instancedefer> <> AND IF
 208          TRUE ABORT" Invalid destination for FCODE b(to)"
 209       THEN
 210       \ Destination is instance-value or instance-defer
 211       >body @                               ( val instance-offset )
 212       ?compile-mode IF
 213          literal,  postpone >instance  postpone !
 214       ELSE
 215          >instance !
 216       THEN
 217       ELSE
 218    THEN
 219 ; immediate
 220
 221 : b(value)
 222    fc-instance? IF
 223       <create> ,                \ Needed for "(instance?)" for example
 224       <instancevalue> ,
 225       (create-instance-var)
 226       FALSE TO fc-instance?
 227    ELSE
 228       <value> , ,
 229    THEN
 230    reveal
 231 ;
 232
 233 : b(variable)
 234    fc-instance? IF
 235       <create> ,                \ Needed for "(instance?)"
 236       <instancevariable> ,
 237       0 (create-instance-var)
 238       FALSE TO fc-instance?
 239    ELSE
 240       <variable> , 0 ,
 241    THEN
 242    reveal
 243 ;
 244
 245 : b(constant)
 246   <constant> , , reveal
 247   ;
 248
 249 : undefined-defer
 250   cr cr ." Uninitialized defer word has been executed!" cr cr
 251   true fcode-end !
 252   ;
 253
 254 : b(defer)
 255    fc-instance? IF
 256       <create> ,                \ Needed for "(instance?)"
 257       <instancedefer> ,
 258       ['] undefined-defer (create-instance-var)
 259       reveal
 260       FALSE TO fc-instance?
 261    ELSE
 262       <defer> , reveal
 263       postpone undefined-defer
 264    THEN
 265 ;
 266
 267 : b(create)
 268   <variable> ,
 269   postpone noop reveal
 270   ;
 271
 272 : b(field) ( E: addr -- addr+offset ) ( F: offset size -- offset+size )
 273    <colon> , over literal,
 274    postpone +
 275    <semicolon> compile,
 276    reveal
 277    +
 278 ;
 279
 280 : b(buffer:) ( E: -- a-addr) ( F: size -- )
 281    fc-instance? IF
 282       <create> ,                \ Needed for "(instance?)"
 283       <instancebuffer> ,
 284       (create-instance-buf)
 285       FALSE TO fc-instance?
 286    ELSE
 287       <buffer:> , allot
 288    THEN
 289    reveal
 290 ;
 291
 292 : suspend-fcode ( -- )
 293   noop        \ has to be implemented more efficiently ;-)
 294   ;
 295
 296 : offset16 ( -- )
 297   2 to fcode-offset
 298   ;
 299
 300 : version1 ( -- )
 301   1 to fcode-spread
 302   1 to fcode-offset
 303   read-header
 304   ;
 305
 306 : start0 ( -- )
 307   0 to fcode-spread
 308   offset16
 309   read-header
 310   ;
 311
 312 : start1 ( -- )
 313   1 to fcode-spread
 314   offset16
 315   read-header
 316   ;
 317
 318 : start2 ( -- )
 319   2 to fcode-spread
 320   offset16
 321   read-header
 322   ;
 323
 324 : start4 ( -- )
 325   4 to fcode-spread
 326   offset16
 327   read-header
 328   ;
 329
 330 : end0 ( -- )
 331   true fcode-end !
 332   ;
 333
 334 : end1 ( -- )
 335   end0
 336   ;
 337
 338 : ferror ( -- )
 339   clear end0
 340   cr ." FCode# " fcode-num @ . ." not assigned!"
 341   cr ." FCode evaluation aborted." cr
 342   ." ( -- S:" depth . ." R:" rdepth . ." ) " .s cr
 343   abort
 344   ;
 345
 346 : reset-local-fcodes
 347   FFF 800 DO ['] ferror 0 i set-token LOOP
 348   ;
 349
 350 : byte-load ( addr xt -- )
 351   >r >r
 352   save-evaluator-state
 353   r> r>
 354   reset-fcode-end
 355   1 to fcode-spread
 356   dup 1 = IF drop ['] rb@ THEN to fcode-rb@
 357   set-ip
 358   reset-local-fcodes
 359   depth >r
 360   evaluate-fcode
 361   r> depth 1- <> IF
 362       clear end0
 363       cr ." Ambiguous stack depth after byte-load!"
 364       cr ." FCode evaluation aborted." cr cr
 365   ELSE
 366       restore-evaluator-state
 367   THEN
 368   ['] c@ to fcode-rb@
 369 ;
 370
 371 \ Functions for accessing memory ... since some FCODE programs use the normal
 372 \ memory access functions for accessing MMIO memory, too, we got to use a little
 373 \ hack to support them: When address is bigger than MIN-RAM-SIZE, assume the
 374 \ FCODE is trying to access MMIO memory and use the register based access
 375 \ functions instead!
 376 : fc-c@   ( addr -- byte )   dup MIN-RAM-SIZE > IF rb@ ELSE c@ THEN ;
 377 : fc-w@   ( addr -- word )   dup MIN-RAM-SIZE > IF rw@ ELSE w@ THEN ;
 378 : fc-<w@  ( addr -- word )   fc-w@ dup 8000 >= IF 10000 - THEN ;
 379 : fc-l@   ( addr -- long )   dup MIN-RAM-SIZE > IF rl@ ELSE l@ THEN ;
 380 : fc-<l@  ( addr -- long )   fc-l@ signed ;
 381 : fc-x@   ( addr -- dlong )  dup MIN-RAM-SIZE > IF rx@ ELSE x@ THEN ;
 382 : fc-c!   ( byte addr -- )   dup MIN-RAM-SIZE > IF rb! ELSE c! THEN ;
 383 : fc-w!   ( word addr -- )   dup MIN-RAM-SIZE > IF rw! ELSE w! THEN ;
 384 : fc-l!   ( long addr -- )   dup MIN-RAM-SIZE > IF rl! ELSE l! THEN ;
 385 : fc-x!   ( dlong addr -- )  dup MIN-RAM-SIZE > IF rx! ELSE x! THEN ;
 386
 387 : fc-fill ( add len byte -- )  2 pick MIN-RAM-SIZE > IF rfill ELSE fill THEN ;
 388 : fc-move ( src dst len -- )
 389    2 pick MIN-RAM-SIZE >        \ Check src
 390    2 pick MIN-RAM-SIZE >        \ Check dst
 391    OR IF rmove ELSE move THEN
 392 ;
 393
 394 \ Destroy virtual mapping (should maybe also update "address" property here?)
 395 : free-virtual  ( virt size -- )
 396    s" map-out" $call-parent
 397 ;
 398
 399 \ Map the specified region, return virtual address
 400 : map-low  ( phys.lo ... size -- virt )
 401     my-space swap s" map-in" $call-parent
 402 ;
 403
 404 \ Get MAC address
 405 : mac-address  ( -- mac-str mac-len )
 406    s" local-mac-address" get-my-property IF
 407       0 0
 408    THEN
 409 ;
 410
 411 \ Output line and column number - not used yet
 412 VARIABLE #line
 413 0 #line !
 414 VARIABLE #out
 415 0 #out !
 416
 417 \ Display device status
 418 : display-status  ( n -- )
 419    ." Device status: " . cr
 420 ;
 421
 422 \ Obsolete variables:
 423 VARIABLE group-code
 424 0 group-code !
 425
 426 \ Obsolete: Allocate memory for DMA
 427 : dma-alloc  ( byte -- virtual )
 428    s" dma-alloc" $call-parent
 429 ;
 430
 431 \ Obsolete: Get params property
 432 : my-params  ( -- addr len )
 433    s" params" get-my-property IF
 434       0 0
 435    THEN
 436 ;
 437
 438 \ Obsolete: Convert SBus interrupt level to CPU interrupt level
 439 : sbus-intr>cpu  ( sbus-intr# -- cpu-intr# )
 440 ;
 441
 442 \ Obsolete: Set "intr" property
 443 : intr  ( interrupt# vector -- )
 444    >r sbus-intr>cpu encode-int r> encode-int+ s" intr" property
 445 ;
 446
 447 \ Obsolete: Create the "name" property
 448 : driver  ( addr len -- )
 449    encode-string s" name" property
 450 ;
 451
 452 \ Obsolete: Return type of CPU
 453 : processor-type  ( -- cpu-type )
 454    0
 455 ;
 456
 457 \ Obsolete: Return firmware version
 458 : firmware-version  ( -- n )
 459    10000                          \ Just a dummy value
 460 ;
 461
 462 \ Obsolete: Return fcode-version
 463 : fcode-version  ( -- n )
 464    fcode-revision
 465 ;