home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / MISC / FPC355_2.ZIP / FPCSRC.ZIP / SIZES.SEQ < prev    next >
Encoding:
Text File  |  1991-03-06  |  2.8 KB  |  71 lines
  1. \ SIZES.SEQ     Get the size of any Forth words CFA     by Tom Zimmer
  2.  
  3.  
  4. handle sizehndl
  5. 0 value size-seg
  6. defer sfind             ' find is sfind
  7.  
  8. : getsize       ( --- )
  9.                 size-seg ?exit
  10.                 " KERNEL.SIZ" sizehndl ">handle
  11.                 sizehndl hopen
  12.                 if      cr ." Failed to open KERNEL.SIZ"
  13.                 else    cr ." Reading 64k image of cfa sizes.."
  14.                         $1000 alloc 8 = memchk nip =: size-seg
  15.                         0 $ff00 sizehndl size-seg exhread $ff00 -
  16.                         if      cr ." Read error from SIZE file"
  17.                         then    sizehndl hclose drop cr
  18.                 then    ;
  19.  
  20. getsize
  21.  
  22. : size-save     ( --- )                 \ save the cfa sizes file
  23.                 size-seg 0= ?exit
  24.                 cr ." Saving 64k image of cfa sizes.."
  25.                 sizehndl hcreate
  26.                 if      cr ." could not create size file"
  27.                 else    0 $ff00 sizehndl size-seg exhwrite $ff00 -
  28.                         if      cr ." write error to size file"
  29.                         then    sizehndl hclose drop
  30.                         off> size-seg
  31.                 then    cr ;
  32.  
  33. : size-set      ( --- )
  34.                 size-seg 0= ?exit               \ must be initialized
  35.                 size-seg dup>r 0 @L             \ if non-zero then
  36.                 if      here r@ 0 @L -          \ calculate actual length
  37.                         r@ dup 0 @L !L          \ fill in code length WORD
  38.                         xdp @                   \ length of list
  39.                         r@ dup 0 @L 2+ !L       \ fill in list length WORD
  40.                         xhere paragraph + xdpseg !
  41.                         xdp off                 \ round up list
  42.                 then    here r> 0 !L ;
  43.  
  44. : s-header      ( | <name> --- )
  45.                 size-set
  46.                 ( defers header )       \ DEFERS is not defined yet
  47.                 <header> ;              \ so must explicitly specify
  48.  
  49. ' s-header is header                    \ link into header for future headers
  50.  
  51. here size-seg 0 !L
  52. xhere paragraph + xdpseg ! xdp off      \ round up list
  53.  
  54. : size          ( | <name> --- )
  55.                 getsize size-seg 0=
  56.                 abort" Could not read KERNEL.SIZ"
  57.                 bl word ?uppercase sfind 0= ?missing       ( --- cfa )
  58.                 ." CFA = "  dup h.
  59.                 size-seg over @L ?dup
  60.                 if      ." Size of CODE = " dup u.
  61.                         ."  LIST = "
  62.                         4 <
  63.                         if      0 u.
  64.                         else    size-seg swap 2+ @L u.
  65.                         then
  66.                 else    ." SIZE is not available"
  67.                         drop
  68.                 then    ;
  69.  
  70.  
  71.