home *** CD-ROM | disk | FTP | other *** search
/ ftp.whtech.com / ftp.whtech.com.tar / ftp.whtech.com / Geneve / 9640news / CAT17 / TREE.ARK < prev    next >
Text File  |  2006-10-19  |  3KB  |  79 lines
  1. ?
  2.  ( STRUCTURE TREE UTILITY       831 BYTES )
  3.  ( To load:  90 LOAD )
  4.  ( TREE Usage: To list Structure Tree of word XYZ: )
  5.  ( TREE XYZ )
  6.  0 VARIABLE LEVEL              ( Current level of TREE branch )
  7.  10 VARIABLE MAX-LEVEL         ( Maximum TREE branch level )
  8.  : NULL ;                      ( Dummy def to get : cfa value )
  9.  ' NULL CFA @ CONSTANT COLON   ( Pointer to code of : word )
  10.  ' ;S   CFA CONSTANT SEMICOLON ( Terminating CFA of : word )
  11.  ' 0BRANCH CFA CONSTANT '0BRANCH ( Words compiling arguments )
  12.  ' BRANCH  CFA CONSTANT 'BRANCH
  13.  ' LIT     CFA CONSTANT 'LIT
  14.  ' (LOOP)  CFA CONSTANT 'LOOP
  15.  ' (+LOOP) CFA CONSTANT '+LOOP
  16.  ' (.")    CFA CONSTANT '"
  17.  -->
  18.  ( STRUCTURE TREE UTILITY cont.  PAGE-2 )
  19.  ( DRAW BAR FOR CURRENT LEVEL )
  20.  : BAR  -DUP IF 0 DO 95 EMIT LOOP ENDIF ;
  21.  ( CASE STATEMENT BY DR. C. E. EAKER )
  22.  : DOCASE  ?COMP CSP @ !CSP 4 ; IMMEDIATE
  23.  : <<  4 ?PAIRS COMPILE OVER COMPILE = COMPILE 0BRANCH
  24.        HERE 0 , COMPILE DROP 5 ; IMMEDIATE
  25.  : >>  5 ?PAIRS COMPILE BRANCH HERE 0 ,
  26.        SWAP 2 [COMPILE] ENDIF 4 ; IMMEDIATE
  27.  : ENDCASES  4 ?PAIRS COMPILE DROP
  28.              BEGIN SP@ CSP @ = 0= WHILE
  29.                2 [COMPILE] ENDIF REPEAT CSP ! ; IMMEDIATE
  30.  -->
  31.  ( STRUCTURE TREE UTILITY cont.  PAGE-3 )
  32.  ( PRINT THE ARGUMENT )
  33.  : PRINT-ARG  DOCASE
  34.      1 << 2 + DUP C@ . 1 + >>       ( Skip/print 1 byte )
  35.      2 << 2 + DUP  @ . 2 + >>       ( Skip/print 2 bytes )
  36.      3 << 2 + DUP C@ SWAP 1+ SWAP   ( Skip/print n bytes )
  37.        0 DO DUP C@ EMIT 1+ LOOP >>  ( Print string )
  38.      ENDCASES ;
  39.  ( MOVE PFA ON STACK TO NEXT WORD,  addr --- addr+offset )
  40.  : MOVE-WORD  DUP @ DOCASE  ( Get cfa compiled at ptr, check: )
  41.      '0BRANCH << 2 PRINT-ARG >>    'BRANCH << 2 PRINT-ARG >>
  42.      'LIT     << 2 PRINT-ARG >>
  43.      'LOOP    << 2 PRINT-ARG >>    '+LOOP  << 2 PRINT-ARG >>
  44.      '"       << 3 PRINT-ARG >>    ( Skip string till " )
  45.         SWAP 2 + SWAP  ENDCASES ;  ( Skip only the ptr itself )
  46.  -->
  47.  ( STRUCTURE TREE UTILITY cont.  PAGE-4 )
  48.  ( PRINT THE NAME WHOSE CFA IS POINTED TO BY STACK ADDR )
  49.  : PRINT-NAME         ( addr--- )
  50.      CR  LEVEL @ 3 .R  LEVEL @ 3 * BAR ( Print level # & bar )
  51.      @ 2 + NFA ID.            ( get cfa>pfa>nfa & print name )
  52.    ?KEY IF KEY DROP ENDIF ;
  53.  ( PRINT WORD TREE )
  54.  : DO-TREE            ( pfa--- )
  55.      1 LEVEL !  BEGIN       ( Init level, do till stack empty )
  56.      ?TERMINAL IF ABORT ENDIF    ( Abort if key is pressed )
  57.      DUP @ SEMICOLON = 0= IF     ( If not at an ;S word )
  58.      DUP PRINT-NAME DUP @ @ COLON = ( Print if lower word is )
  59.      LEVEL @ MAX-LEVEL @ < AND   ( a : def & < MAX-LEVEL )
  60.      OVER @ FENCE @ > AND IF     ( & > fence )
  61.       1 LEVEL +! DUP @ 2 +       ( Get pfa of next level down )
  62.  -->
  63.  ( STRUCTURE TREE UTILITY cont.  PAGE-5 )
  64.  ( PRINT WORD TREE cont. )
  65.        ELSE MOVE-WORD ENDIF   ( Not a colon, move to next )
  66.        ELSE -1 LEVEL +!  ( End of colon def, pop up next lvl )
  67.        DROP MOVE-WORD ENDIF   ( Drop addr pointer & move over )
  68.      LEVEL @ 0= UNTIL ;       ( Until stack is empty )
  69.  ( USER ENTRY FOR TREE )
  70.  : TREE  CR [COMPILE] '       ( Get pfa of next input word )
  71.      DUP NFA ID.              ( Print word to be TREEd )
  72.      DO-TREE CR ;             ( Print Structure Tree of pfa )
  73.  ;S
  74.  
  75.  
  76. Download complete.  Turn off Capture File.
  77.  
  78.  
  79.