home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / dmp.seq < prev    next >
Text File  |  1990-05-18  |  7KB  |  206 lines
  1. \ DMP.SEQ
  2.  
  3.    0 value dmp_seg      0 value dmp_end
  4. 6000 array sym_buf      0 value sym_len
  5.     handle afile
  6.  
  7. : @T            ( a1 -- n1 )
  8.                 dmp_seg swap @L ;
  9.  
  10. : C@T           ( a1 -- n1 )
  11.                 dmp_seg swap C@L ;
  12.  
  13. : read_fl       ( a1 n1 a2 n2 seg -- n3 )
  14.                 >r >r >r ">$ afile $>handle
  15.                 afile hopen abort" Couldn't open"
  16.                 r> r> afile r> exhread  ( -- n3 )       \ length returned
  17.                 afile hclose drop ;
  18.  
  19. : read_dmp      ( -- )
  20.                 dmp_seg 0=
  21.                 if      12500 paragraph alloc 8 = abort" Failed to allocate!"
  22.                         =: dmp_seg drop
  23.                 then
  24.                 dmp_seg 0 12500 0 LFILL
  25.                 " test.cpm"    $100 12000 dmp_seg read_fl $100 + =: dmp_end
  26.                 " test.sym" sym_buf  6000 ?ds:    read_fl        =: sym_len ;
  27.  
  28. 32 array nbuf
  29.  
  30. : >>name        ( a1 -- name )
  31.                 save> base hex
  32.                 >r
  33.                 sym_buf sym_len
  34.                 begin   over 4 here place here count + off
  35.                         here number? 2drop dup r@ <>
  36.                         2 pick 0> and
  37.                 while   drop $0A scan 1 /string
  38.                 repeat  r> =
  39.                 if      5 /string 2dup $0D scan nip - nbuf place
  40.                 else    2drop nbuf off
  41.                 then    nbuf
  42.                 restore> base ;
  43.  
  44. : >>find        ( a1 -- a2 )
  45.                 save> base hex
  46.                 >r
  47.                 sym_buf sym_len
  48.                 begin   2dup 5 /string
  49.                         2dup $0D scan nip - r@ count rot max caps-comp dup
  50.                         2 pick 0> and
  51.                 while   drop $0A scan 1 /string
  52.                 repeat  r>drop 0=
  53.                 if      drop 4 here place here count + off
  54.                         here number? 2drop
  55.                 else    2drop false
  56.                 then
  57.                 restore> base ;
  58.  
  59. 0 value sym_point
  60. 0 value rem_len
  61.  
  62. : next_sym      ( -- a1 n1 )            \ a1 = start n1 = len
  63.                 rem_len 0=
  64.                 if      sym_point 0 exit
  65.                 then
  66.                 save> base hex
  67.                 sym_point rem_len
  68.                 over 4 here place here count + off
  69.                 here number? 2drop >r
  70.                 $0A scan 1 /string =: rem_len dup =: sym_point
  71.                 4 here place here count + off
  72.                 r> here number? 2drop over -
  73.                 over dmp_end swap - umin
  74.                 restore> base ;
  75. \                CR 2DUP SWAP 3 .R 3 .R DEPTH 3 .R SPACE ;
  76.  
  77. : sym_reset     ( -- )
  78.                 sym_buf 2+      =: sym_point
  79.                 sym_len 2- 0max =: rem_len ;
  80.  
  81.  
  82. $100 CONSTANT ORIGIN
  83. $108 CONSTANT DPUSH
  84. $109 CONSTANT HPUSH
  85. $10A CONSTANT >NEXT
  86. $110 CONSTANT >NEXT1
  87. $115 CONSTANT NEST
  88. $126 CONSTANT DODOES
  89. $137 CONSTANT DOCREATE
  90. $13C CONSTANT DOCONSTANT
  91. $145 CONSTANT DODEFER
  92. $14E CONSTANT RP0
  93. $150 CONSTANT RP
  94. $152 CONSTANT SP0
  95. $154 CONSTANT VOC-INIT
  96.  
  97. 0 value |"
  98. 0 value |lit
  99. 0 value |do
  100. 0 value |?do
  101. 0 value |loop
  102. 0 value |+loop
  103. 0 value |?branch
  104. 0 value |branch
  105.  
  106. : inline_init   ( -- )
  107.                 " (x)" over '"' swap 1+ c!      \ fix "
  108.                                 ">$ >>find =: |"
  109.                 " (lit)"        ">$ >>find =: |lit
  110.                 " (do)"         ">$ >>find =: |do
  111.                 " (?do)"        ">$ >>find =: |do
  112.                 " (loop)"       ">$ >>find =: |loop
  113.                 " (+loop)"      ">$ >>find =: |+loop
  114.                 " ?branch"      ">$ >>find =: |?branch
  115.                 " branch"       ">$ >>find =: |branch ;
  116.  
  117. : h.2           ( n1 -- )
  118.                 save> base hex
  119.                 0 <# # # #> type space
  120.                 restore> base ;
  121.  
  122. : $dump         ( a1 -- n1 )
  123.                 dup c@T dup h.2 ." {" dup>r swap 1+ swap 0
  124.                 ?do     dup i + c@T emit
  125.                 loop    drop ." } " r> 3 + ;
  126.  
  127. : dumpT         ( a1 n1 -- )
  128.                 dup ." length = " u. rmargin @ ?line
  129.                 bounds
  130.                 ?do     ?cr i c@T h.2   ?keypause
  131.                 loop    ;
  132.  
  133. : ?inline       ( a1 n1 -- a1 n1 n2 )
  134.                 over @T
  135.                 case
  136.                 |"       of     over 2+ $dump           endof
  137.                 |lit     of     over 2+ @T h. 4         endof
  138.                 |do      of     over 2+ @T h. 4         endof
  139.                 |?do     of     over 2+ @T h. 4         endof
  140.                 |loop    of     over 2+ @T h. 4         endof
  141.                 |+loop   of     over 2+ @T h. 4         endof
  142.                 |?branch of     over 2+ @T h. 4         endof
  143.                 |branch  of     over 2+ @T h. 4         endof
  144.                                 drop          2
  145.                 endcase ;
  146.  
  147. : ||:           ( a1 n1 -- )
  148.                 2 /string
  149.                 begin   ?cr     over @T >>name dup c@ 0=
  150.                         if      drop over @T h. 2
  151.                         else    count dup 1+ ?line type space
  152.                                 ?inline
  153.                         then    /string ?dup 0= ?keypause
  154.                 until   drop ;
  155.  
  156. : ||create      ( a1 n1 -- )
  157.                 drop ." VARIABLE " 2+ @T h. ;
  158.  
  159. : ||defer       ( a1 n1 -- )
  160.                 drop ." DEFER " 2+ @T dup h. ?dup
  161.                 if      >>name count type
  162.                 then    ;
  163.  
  164. : ||constant    ( a1 n1 -- )
  165.                 drop ." CONSTANT " 2+ @T h. ;
  166.  
  167. : ||unknown     ( a1 n1 -- )
  168.                 ." UNKNOWN " dumpT ;
  169.  
  170. : ?.word        ( a1 n1 -- )
  171.                 over @T
  172.                 case
  173.                 nest       of   ||:             endof
  174.                 docreate   of   ||create        endof
  175.                 dodefer    of   ||defer         endof
  176.                 doconstant of   ||constant      endof
  177.                                 drop
  178.                                 ||unknown
  179.                 endcase         ;
  180.  
  181. : dmp           ( -- )
  182.                 decimal
  183.                 dosio_init
  184.                 caps on
  185.                 ?ds: sseg !
  186.                 $fff0 set_memory
  187.                 16 tabsize !
  188.                 16 lmargin !
  189.                 74 rmargin !
  190.                 read_dmp
  191.                 inline_init
  192.                 sym_reset
  193.         begin   next_sym        ?dup
  194.                 ?keypause
  195.         while   cr
  196.                 over h.
  197.                 over >>name count type tab
  198.                 over dup @T 2- =
  199.                 if      ." CODE  " dumpT
  200.                 else    ?.word
  201.                 then
  202.         repeat  drop cr ;
  203.  
  204.  
  205.  
  206.