Benutzer-Werkzeuge

Webseiten-Werkzeuge


projects:sample9.blk

Examples for lecture number nine

Screen 0 not modified     
 0 \ Examples for lecture number eight.           11:22JWB11/23/85 
 1 \ Last change:   Screen  065                   14:42JWB03/12/86 
 2                                                                 
 3                                                                 
 4         Extending the compiler.                                 
 5                                                                 
 6         Line backup buffer for Line editor.                     
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 1 not modified     
 0 \ Load screen                                  10:04JWB11/24/85 
 1 \ Typing  OK   always loads screen 1!                           
 2   6 VIEWS  LEDIT.BLK      \ Identify LEDIT.BLK as file # 6      
 3   6 VIEW#  !              \ Set current view number.            
 4   FROM LEDIT.BLK  OK      \ load the line editor                
 5   NEW-EXP                 \ activate the new line editor.       
 6   7 VIEWS SAMPLE8.BLK     \ Identify sample8.blk as file # 7    
 7   7 VIEW# !               \ Set current view number to 7        
 8 FROM SAMPLE8.BLK  7 LOAD  \ Number Format examples & Verify.    
 9 FROM SAMPLE8.BLK  8 LOAD  FROM SAMPLE8.BLK  9 LOAD              
10 FROM SAMPLE8.BLK 16 LOAD  \ Load SPY                            
11 FROM SAMPLE8.BLK 17 LOAD  FROM SAMPLE8.BLK 18 LOAD              
12   8 VIEWS SAMPLE9.BLK                                           
13   8 VIEW# ! 7   LOAD   8 LOAD       \  Sound  words.            
14 ONLY EDITOR ALSO SOUND ALSO FORTH DEFINITIONS                   
15 \ MARK EMPTY HERE FENCE !   SAVE-SYSTEM JFORTH.COM              


Screen 2 not modified     
 0 \ Review-1 Dictionary Vocabularies             21:32JWB11/19/85 
 1  HIDE      ( --  -- )  Unlink most latest word from dictionary. 
 2  REVEAL    ( --  -- )  Link the latest word into the dictionary.
 3  IMMEDIATE ( --  -- )  Set precedence bit so latest word is     
 4          executed during compilation instead of being compiled. 
 5                                                                 
 6  ['] {word} This is an IMMEDIATE word used within a definition. 
 7       It used to compile the cfa of the following word as a     
 8       LITERAL or number.  It is equivalent to the sequence      
 9                                                                 
10  [ ' {word} ] LITERAL                                           
11                                                                 
12 DP      ( --  adr )  Variable containing next dict loacation.   
13 HERE    ( --  adr )  Returns next available dictionary location.
14 #VOCS   ( --  n   )  Constant, max vocabularies in search order.
15 VOCS    ( --   -- )  List all vocabularies in this FORTH system.


Screen 3 not modified     
 0 \ Review-2  Vocabularies                       21:31JWB11/19/85 
 1 CURRENT ( --  adr )  Points to compilation vocabulary.          
 2 CONTEXT ( --  adr )  Points the the vocabulary search order aray
 3                      First vocabulary in the list is called the 
 4                      transient vocabulary, the remainder are    
 5                      called the resident vocabularies.          
 6 DEFINITIONS ( --  -- )  Select the transient vocabulary ( first 
 7                         in the context array) as the compilation
 8                         vocabulary into which all subsequent    
 9                         new word definitions will be added.     
10 ORDER   ( --  -- ) Display current vocabulary search order.     
11                                                                 
12 ALSO    ( --  -- ) Push transient vocabulary making it the first
13                    resident vocabulary in the search order.     
14 PREVIOUS ( --  -- ) The inverse of ALSO, removes the most       
15            recently referenced vocabulary from the search order.


Screen 4 not modified     
 0 \ Review-3  Vocabularies                       21:31JWB11/19/85 
 1                                                                 
 2 VOCABULARY  {name}  ( --  -- )                                  
 3  A dictionary entry for {name} is created which specifies a     
 4  new list of word definitions.  Subsequent execution of {name}  
 5  replaces the first vocabulary in the current search order      
 6  with {name}.  When name becomes the compilation vocabulary     
 7  new definitions will be appended to {name}'s word list.        
 8                                                                 
 9 ROOT  ( --  -- ) A small vocabulary for controlling search order
10                                                                 
11 ONLY  ( --  -- ) Erases the search order and forces the ROOT    
12                  vocabulary to be the first and last.           
13                                                                 
14                                                                 
15                                                                 


Screen 5 not modified     
 0 \ Structure of a FORTH word definition.        21:33JWB11/19/85 
 1                                                                 
 2                   4-bits    12-bits                             
 3        vfa ->   | File # |   Block # |  View Field              
 4        lfa ->   | Link address       |  Link Field              
 5        nfa ->              |1PScount |  Name Field  count=5bits 
 6                            |0  char  |                          
 7                            |0  char  |   char=7bits             
 8                            |0  char  |                          
 9                            |1  char  |                          
10        cfa ->   | Addr Inner Interpr.|  Code field              
11        pfa ->   | Parameter List     |  Parameter Field         
12                 |    . .     . .     |  Also called the         
13                 |    . .     . .     |  BODY  of the word       
14                 |    . .     . .     |  definition.             
15                                                                 


Screen 6 not modified     
 0 \ Making a new vocabulary                      22:13JWB11/19/85 
 1 \   RECURSE    Compile the cfa of the current definition.       
 2 \ : RECURSE  LAST @ NAME>  ,  ;  IMMEDIATE                      
 3                                                                 
 4 : FACT        ( n  n! )                                         
 5   DUP 0> IF    DUP 1-  RECURSE    *                             
 6          ELSE  DROP 1                                           
 7          THEN  ;                                                
 8                                                                 
 9 \ RECURSIVE    Links the current definition so it can be found. 
10 \ RECURSIVE    Allow current definition to be self referencing. 
11                                                                 
12 : FACTORIAL   ( n  n! ) RECURSIVE                               
13   DUP 0> IF    DUP 1-  FACTORIAL  *                             
14          ELSE  DROP 1                                           
15          THEN   ;                                               


Screen 7 not modified     
 0 \ Making a new vocabulary                      21:38JWB11/19/85 
 1 ONLY FORTH ALSO DEFINITIONS           CR ORDER                  
 2 VOCABULARY SOUND                      CR .( VOCS ) VOCS  CR     
 3 ROOT DEFINITIONS   : SOUND   SOUND ;  CR ORDER                  
 4 SOUND DEFINITIONS                     CR ORDER                  
 5                                                                 
 6 \  PC!  ( byte  n   --  )  Output byte to port number n.        
 7 \  PC@  ( n        byte )  Input  byte from port number n.      
 8 HEX                                                             
 9 :   S.ON  ( --  -- )      \  Turn speaker on.                   
10         61 PC@                                                  
11         3  OR   61 PC! ;                                        
12                                                                 
13 :   S.OFF ( --  -- )       \ Turn speaker off.                  
14         61 PC@                                                  
15         FFFC AND  61 PC! ; DECIMAL                              


Screen 8 not modified     
 0 \ Vocabularies                                 22:14JWB11/19/85 
 1                                                                 
 2                                                                 
 3 : TONE  ( freq  -- )       \ Make tone of specified frequency.  
 4     21 MAX                 \ Lowest frequency.                  
 5     1.190000  ROT          \ Get divisor for timer.             
 6     MU/MOD                 \ 16bit.rem   32bit.quot             
 7     DROP NIP  [ HEX ]      \ Keep 16-bit quotient only.         
 8     0B6   043 PC!          \ Write to timer mode register.      
 9     100  /MOD SWAP         \ Split into hi and low byte.        
10     42 PC! 42 PC!          \ Store low and high byte in timer.  
11       S.ON ;  DECIMAL      \ turn speaker on.                   
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 9 not modified     
 0 \ Vocabularies.                                23:18JWB11/19/85 
 1                                                                 
 2 : C 131 TONE ;                                                  
 3 : D 147 TONE ;                                                  
 4 : E 165 TONE ;                                                  
 5 : F 175 TONE ;                                                  
 6 : G 196 TONE ;                                                  
 7 : A 220 TONE ;                                                  
 8 : B 247 TONE ;                                                  
 9 : CC 262 TONE ;                                                 
10                                                                 
11 : BEAT  20000 0 DO LOOP ;                                       
12                                                                 
13 : SCALE  C BEAT D BEAT E BEAT F BEAT G BEAT                     
14          A BEAT B BEAT CC BEAT BEAT BEAT S.OFF ;                
15                                                                 


Screen 10 not modified     
 0 \ Vectored execution, Brodie  Ch 9 p 215       08:52JWB11/24/85 
 1                                                                 
 2 \  EXECUTE  ( cfa    -- ) Execute the word whose cfa is on stack
 3                                                                 
 4 : F.HELLO  ." Hello,  I speak FORTH " ;                         
 5 : B.HELLO  ." Hello,  I speak BASIC " ;                         
 6 : P.HELLO  ." Hello,  I speak PASCAL" ;                         
 7                                                                 
 8   VARIABLE  INTRO                                               
 9                                                                 
10 : GREETING  INTRO @ EXECUTE ;                                   
11                                                                 
12 \ Try  ' F.HELLO EXECUTE                                        
13 \      ' F.HELLO INTRO !   GREETING                             
14 \      ' P.HELLO INTRO !   GREETING                             
15                                                                 


Screen 11 not modified     
 0 \ PERFORM  IS  DEFER                           09:32JWB11/24/85 
 1 \                                                               
 2 \  PERFORM  ( adr   -- )   Equivalent to   @ EXECUTE            
 3                                                                 
 4 : GREETING1  INTRO  PERFORM  ;                                  
 5                                                                 
 6 \  IS {word}  ( adr  -- )  Store adr  in pfa of  {word}         
 7 \  Sample usage:   ' F.HELLO IS INTRO   etc                     
 8                                                                 
 9 : GREETING2  NOOP  ;                                            
10                                                                 
11 \ DEFER {word}  ( --  -- )  Like a variable except that it      
12 \               fetches its contents and executes them.         
13                                                                 
14 DEFER  GREETING3                                                
15                                                                 


Screen 12 not modified     
 0 \ Extending the compilers!!!                   09:46JWB11/24/85 
 1 \ Template for creating new compilers:                          
 2 \ : {compiler name}                                             
 3 \       CREATE  {compile time code}                             
 4 \       DOES>   {run time code}  ;                              
 5                                                                 
 6 : BYTE-CON                                                      
 7         CREATE C,            \  Compile time procedure.         
 8         DOES>  C@ ;          \  Run time procedure.             
 9                                                                 
10 : BYTE-VAR                                                      
11         CREATE 0 C,          \  Compile time procedure.         
12         DOES>   ;            \  Run time procedure.             
13                                                                 
14 11 BYTE-CON AA    22  BYTE-CON BB                               
15    BYTE-VAR XX        BYTE-VAR YY                               


Screen 13 not modified     
 0 \                                              10:01JWB11/24/85 
 1   VARIABLE  STORE?                                              
 2                                                                 
 3 : =>  STORE? ON   ;                                             
 4                                                                 
 5 : SMART-BYTE-VAR                                                
 6         CREATE 0 C,                                             
 7         DOES> STORE? @  STORE? OFF                              
 8               IF    OVER 255 >                                  
 9                     ABORT" Range exceeded."                     
10                     C!                                          
11               ELSE  C@                                          
12               THEN  ;                                           
13                                                                 
14   SMART-BYTE-VAR  ZZ                                            
15   SMART-BYTE-VAR  WW                                            


Screen 14 not modified     
 0 \ The MUSIC compiler.                          11:43JWB11/24/85 
 1 ONLY FORTH ALSO SOUND DEFINITIONS                               
 2         VARIABLE OCTAVE         \ Octave to play                
 3         VARIABLE BEAT           \ Number of beats for this note 
 4    5000 CONSTANT SPEED          \ Alter to change 1/4 note time.
 5 : DELAY  SPEED 0 ?DO I DROP LOOP ;      \ Aprox .5 sec delay.   
 6 \ Make it easy to change the beat and octave.                   
 7 : 1/1  4 BEAT   ! ;  : 1/2   2 BEAT   ! ;  : 1/4  1 BEAT   ! ;  
 8 : 1ST  1 OCTAVE ! ;  : 2ND   2 OCTAVE ! ;  : 3RD  4 OCTAVE ! ;  
 9 \ Rest for current number of beats.                             
10 : REST ( --  -- )                                               
11        BEAT @ 0 ?DO DELAY LOOP  ;      : R   REST ;             
12 \ The note compiler.                                            
13 : NOTE   CREATE   ,                                             
14          DOES>  @  OCTAVE @ *  5 + 10 /    \ Compute frequency. 
15                 TONE  REST S.OFF ;         \ Play the note.     


Screen 15 not modified     
 0 \ Create Notes                                 11:42JWB11/24/85 
 1 \ Create the notes with the note compiler.                      
 2                                                                 
 3 1308 NOTE C     1386 NOTE C#    1468 NOTE D     1556 NOTE D#    
 4 1648 NOTE E     1746 NOTE F     1850 NOTE F#    1960 NOTE G     
 5 2077 NOTE G#    2200 NOTE A     2331 NOTE A#    2469 NOTE B     
 6                                                                 
 7                                                                 
 8 : SCALE  1ST 1/4  C D E F G A B 2ND 1/2 C R                     
 9              1/4  C D E F G A B 3RD 1/2 C R ;                   
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 16 not modified     
 0 \ Music Music??                                11:32JWB11/24/85 
 1 : PART1  1/4  2ND F# E D C D E D                                
 2               1ST A F# G A B A F#  1/2 A 1/4  2ND D E ;         
 3 : PART2  1/2  2ND F# F# 1/4 F# E D E F# E D F# 1/2 E ;          
 4                                                                 
 5 : PART3  1/4  2ND F# E F# G A F# D E F# D E 1ST A 1/2 2ND D R ; 
 6                                                                 
 7 : PART4  1/4  1ST F# E F# G A G F# E F# E F# G ;                
 8                                                                 
 9 : PART5  1/4  2ND D E F# D 1ST B 2ND C# D 1ST A F# G A F#       
10          1/2  E 1/4 D E ;                                       
11 : PART6  1/4  1ST F# E F# G A F# D E F# D E C# 1/2 D R ;        
12                                                                 
13 : TURKEY  PART1 PART2 PART1 PART3 PART4 1/2 1ST A R             
14           PART4 1/2 1ST B 1/4 B  2ND C# PART5 PART6 ;           
15   2000  IS SPEED                                                


Screen 17 not modified     
 0 \ Multi-diminsional arrays for F83             12:04JWB11/24/85 
 1 : ACHECK ( {n items} n   {n items}  n )  \ Check parameters.    
 2   DUP 1 < OVER 255 > OR                                         
 3   ABORT" Illegal dimension in array definition."                
 4   DUP 1+ ?ENOUGH ;                                              
 5 : *ARRAY  ACHECK                                                
 6   CREATE                                                        
 7     DUP C,              ( save # of dimensions )                
 8     1 SWAP              ( initialize total size )               
 9     0 DO                ( loop on # of dimensions )             
10       OVER ,            ( save dimension )                      
11       *                 ( increase total size )                 
12       LOOP                                                      
13     1 ,                 ( save dummy dimension )                
14     2 * ALLOT           ( allocate space for words )            
15                                                         -->     


Screen 18 not modified     
 0 \ Multi-dimensional array definition, cont     12:05JWB11/24/85 
 1   DOES>                                                         
 2     COUNT               ( get # of dimensions )                 
 3     0 SWAP              ( initialize offset )                   
 4     0 DO                ( loop on # of dimensions )             
 5       >R                ( save offset )                         
 6       OVER DUP 0< ABORT" Negative array index."                 
 7       OVER @ < 0= ABORT" Array index too large."                
 8       2+ DUP @          ( advance to next dimension )           
 9       ROT R> + *        ( calculate offset so far )             
10       LOOP                                                      
11     2 *                 ( double offset for words )             
12     + 2+ ;              ( calculate element address )           
13                                                                 
14                                                                 
15                                                                 


Screen 19 not modified     
 0 \ Multi-dimensional array definition, cont     12:09JWB11/24/85 
 1 EXIT                                                            
 2 To define an array, the vector size for each dimension          
 3 must be on the stack followed by the total # of dimensions      
 4  Example: to define a 3D array name MATRIX with a               
 5  vector length of 5 in each dimension (i.e. x, y, z = 0...4)    
 6  you would execute:                                             
 7         5 5 5 3 *ARRAY MATRIX                                   
 8                                                                 
 9 To get an indexed address into the array, put the coordinates   
10 on the stack followed by the name of the array.                 
11  Example: to retrieve the value stored in (x,y,z) = (1,2,3)     
12  for the array above, you would execute:                        
13         1 2 3 MATRIX @                                          
14  to store (x,y,z) = 5 at 3D space x=2,y=3,z=5 do:               
15         5 2 3 5 MATRIX !                                        


Screen 20 not modified     
 0 \ Homework                                     12:14JWB11/24/85 
 1                                                                 
 2 EXIT                                                            
 3 Homework   Read Brodie chapter 11 p289-p299                     
 4            Do problems 1, 2, & 3  p315   Answers are in the back
 5                                                                 
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 21 not modified     
 0 \ VECTOR                                       21:34JWB11/19/85 
 1 \ Create a one dimensional vector n storage cells               
 2 \ Usage:         VECTOR  {name}   ( n     -- )                  
 3 \ Later:         {name}           ( index  adr )                
 4                                                                 
 5 : VECTOR   ( n  -- )                                            
 6         CREATE                \ This is the compile time routine
 7         DUP ,                 \ Compile n, maximum subscript.   
 8         0 DO 0 , LOOP         \ Initialize vector to zeros.     
 9         DOES>                  \ index adr                      
10         TUCK @  OVER           \ adr index n index              
11         <= OVER 0< OR          \ adr index flag                 
12         ABORT" Subscript out of range."  \ Error message        
13         1 + 2* + ;              \ Compute address of ith element
14                                                                 
15                                                                 


Screen 22 not modified     
 0 \ ANY-SIGN?  SKIP-BLANKS                       15:20JWB11/25/85 
 1 \ Leave a true flag if string begins with a -ve sign.           
 2 \ Note we assume a counted string!!  adr is 1 less than the     
 3 \ the first string character.                                   
 4 : ANY-SIGN? ( adr   adr' flag )                                 
 5         DUP 1+ C@ DUP ASCII - =    \ Increment adr , check for -
 6         IF    DROP 1+ TRUE         \ Leave true flag if found.  
 7         ELSE  ASCII + =            \ Allow a +sign if desired.  
 8               IF    1+  THEN       \ Increment past + sign      
 9               FALSE                 \ and leave false flag.     
10         THEN ;                                                  
11 \ Move up to first non blank of string.  Actually adr' points   
12 \ to position before first non blank!!                          
13 : SKIP-BLANKS ( adr  adr' )                                     
14         BEGIN 1+ DUP C@ BL <> UNTIL  1-  ;                      
15                                                                 


Screen 23 not modified     
 0 \ FETCH/CONVERT                                15:20JWB11/25/85 
 1 \ This routine fetches a string and converts to double number.  
 2 : FETCH/CONVERT  ( adr n cur   cur adr n dn )                   
 3         BEGIN DUP CUR!          \ a n c  Position cursor.       
 4           -ROT 2DUP <LEDIT      \ c a n  Input string.          
 5           OVER 1- SKIP-BLANKS   \ c a n  Move up to non-blank   
 6           ANY-SIGN?             \ c a n a' flg                  
 7           >R 0 0 ROT -1         \ c a n dn a' -1                
 8           BEGIN  DPL !  CONVERT \ c a n dn a"                   
 9             DUP C@  ASCII . =   \ c a n dn a" flg               
10             WHILE 0 REPEAT      \ c a n dn a" 0                 
11             C@ BL <>            \ c a n dn flag                 
12         WHILE 2DROP R> DROP BEEP      \ c a n                   
13               ASCII ? 2 PICK C! ROT   \ a n c                   
14         REPEAT R> ?DNEGATE            \ c a n dn                
15         DPL @ 0< IF DPL OFF THEN ;    \ DPL=0 if .pt not entered


Screen 24 not modified     
 0 \ (#IN)                                        15:20JWB11/25/85 
 1 \ Fetch a double number using field with of n  using adr  for   
 2 \ and input buffer.  Invalid input is marked by ?  and user is  
 3 \ required to repeat until he makes a valid number.             
 4 : (#IN)  ( adr n   dn )                                         
 5         CUR@ -ROT                     \ cur adr n Save cursor   
 6         2DUP 2+ BLANK                 \ cur adr n Blank buffer  
 7         DUP 0 ?DO 95 (CONSOLE) LOOP   \ cur adr n Out underscore
 8         ROT FETCH/CONVERT             \ cur adr n dn            
 9         >R >R                         \ Save double number.     
10         1+ ROT + CUR!                 \ Restore cursor.         
11         DROP R> R> ;                  \ Recover our number.     
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 25 not modified     
 0 \ D#IN  WD#IN  XYWD#IN                         15:20JWB11/25/85 
 1 \ Input double number a current cursor position using default   
 2 \ field with of 6.   Input buffer is at PAD                     
 3 : D#IN   ( --   dn )                                            
 4         PAD     12 (#IN) ;                                      
 5                                                                 
 6 \ As above but field width is specified on the stack.           
 7 : WD#IN  ( n  dn )                                              
 8         PAD  SWAP  (#IN) ;                                      
 9                                                                 
10 \ As above but cursor position is also specified on the stack.  
11 : XYWD#IN ( x y n  dn )                                         
12         -ROT AT WD#IN    ;                                      
13                                                                 
14                                                                 
15                                                                 


Screen 26 not modified     
 0 \ S#IN  WS#IN  XYS#IN                          15:20JWB11/25/85 
 1 \ Input single number a current cursor position using default   
 2 \ field with of 6.   Input buffer is at PAD                     
 3 : S#IN   ( --   dn )                                            
 4         PAD      6 (#IN) DROP  ;                                
 5                                                                 
 6 \ As above but field width is specified on the stack.           
 7 : WS#IN  ( n  dn )                                              
 8         PAD  SWAP  (#IN) DROP ;                                 
 9                                                                 
10 \ As above but cursor position is also specified on the stack.  
11 : XYS#IN ( x y n  dn )                                          
12         -ROT AT WS#IN    ;                                      
13                                                                 
14                                                                 
15                                                                 


Screen 27 not modified     
 0 \ Read screen location.  SC@                   18:06JWB11/25/85 
 1 ONLY EDITOR ALSO FORTH ALSO DEFINITIONS                         
 2                                                                 
 3 CODE  SC@   ( --  char )                                        
 4         8 #  AH MOV                                             
 5           BH BH SUB                                             
 6              16 INT                                             
 7           AH AH SUB                                             
 8        128 # AX CMP                                             
 9 U>= IF  32 # AL MOV  THEN                                       
10                 1PUSH                                           
11              END-CODE                                           
12 :  MARK  ( n  -- )                                              
13         CUR@ 0 ROT  AT SC@ 112 ATRIB ! VEMIT 15 ATRIB ! CUR! ;  
14 : -MARK  ( n  -- )                                              
15         CUR@ 0 ROT  AT SC@  VEMIT   CUR! ;                      


Screen 28 not modified     
 0 \  READ-SCREEN                                 15:21JWB11/25/85 
 1                                                                 
 2  CREATE SLINE-BUF   80 ALLOT                                    
 3 \ Copy line n of screen into SLINE-BUF .                        
 4 : READ-SCREEN  ( n  -- )                                        
 5         25 MOD  CUR@ >R                                         
 6         80 0 DO  I OVER AT SC@                                  
 7                  SLINE-BUF I + C!                               
 8              LOOP  DROP                                         
 9         R> CUR!  ;                                              
10                                                                 
11 : TEST  ( n  -- )                                               
12        READ-SCREEN                                              
13        SLINE-BUF 80 -TRAILING TYPE   ;                          
14                                                                 
15                                                                 


Screen 29 not modified     
 0 \ Code definitions:  DOUBLE  10*                                
 1 CODE DOUBLE ( n   2n )                                          
 2         BX        POP        \ Move n from stack to reg BX      
 3         BX   BX   ADD        \ 2n                               
 4         BX        PUSH       \ Move result to stack.            
 5         NEXT      END-CODE                                      
 6                                                                 
 7 CODE  10*  ( n    10n )                                         
 8         BX        POP         \ Move n from stack to reg BX     
 9         BX  BX    ADD         \ 2n                              
10         BX  AX    MOV         \ 2n                              
11         AX  AX    ADD         \ 4n                              
12         AX  AX    ADD         \ 8n                              
13         AX  BX    ADD         \ 10n                             
14         BX        PUSH        \ Push 10n to the stack.          
15         NEXT      END-CODE                                      


Screen 30 not modified     
 0 \ Sample code definitions for the curious.     12:51JWB02/21/86 
 1 CODE  SPLIT ( hilo   lo hi )                                    
 2             BX POP                                              
 3             AH AH SUB                                           
 4             BL AL MOV                                           
 5                AX PUSH                                          
 6             BH AL MOV                                           
 7                AX PUSH                                          
 8             NEXT  END-CODE                                      
 9 CODE  MELD  ( lo hi    hilo )                                   
10                AX POP                                           
11                BX POP                                           
12             AL AH MOV                                           
13             BL AL MOV                                           
14                AX PUSH                                          
15             NEXT  END-CODE                                      


Screen 31 not modified     
 0 \  RECURSIVE TREES                                              
 1 :  TREE  ( pfa   -- )  RECURSIVE                                
 2        CREATE , DOES>  TREE ;                                   
 3 :  TREE 0 TREE ;                                                
 4                                                                 
 5 : WHATIS ( --  -- )                                             
 6       [COMPILE] ' DUP CR >NAME .ID >BODY                        
 7       BEGIN @ DUP                                               
 8       WHILE DUP BODY> >NAME .ID                                 
 9       REPEAT DROP ;                                             
10                                                                 
11 TREE  VEHICLE  VEHICLE BOAT     VEHICLE CAR     VEHICLE PLANE   
12 BOAT  FERRY    BOAT    TUG      BOAT    ROW                     
13 CAR   VW       CAR     FORD     CAR     DODGE   DODGE   DART    
14 VW    BUS      VW      BEETLE   VW      RABBIT  FORD    MUSTANG 
15 PLANE JET      JET     737      JET     747                     


Screen 32 not modified     
 0 \ RECURSIVE TREES                                               
 1 : BTREE ( --   -- )  RECURSIVE                                  
 2         CREATE  0 , 0 ,                                         
 3         DOES> DUP BTREE                                         
 4               HERE 4 - SWAP !                                   
 5               BTREE                                             
 6               HERE 4 - SWAP 2+ ! ;                              
 7   BTREE A                                                       
 8         A B1 B2                                                 
 9           B1 C1.1  C1.2                                         
10           B2 C2.1  C2.2                                         
11              C1.1  D1.1.1  D1.1.2                               
12              C1.2  D1.2.1  D1.2.2                               
13              C2.1  D2.1.1  D2.1.2                               
14              C2.2  D2.2.1  D2.2.2                               
15                                                                 


Screen 33 not modified     
 0                                                                 
 1 : TAB  BEGIN #OUT @ 7 MOD WHILE SPACE REPEAT ;                  
 2                                                                 
 3 : LEAVES  (  pfa   -- )   RECURSIVE                             
 4         DUP BODY> >NAME TAB .ID DUP @                           
 5         IF   DUP @ LEAVES  2+ @ LEAVES                          
 6         ELSE CR  DROP DEPTH 0 ?DO SPACE TAB LOOP THEN ;         
 7                                                                 
 8 : SL   [COMPILE] ' >BODY CR LEAVES ;                            
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 34 not modified     
 0 \ Intelligent data structures.                                  
 1 \ Finds the average of the n elements at adr+4 and stores the   
 2 \ result at adr+2. Only non zero elements are counted.          
 3 \ AARRAY looks like -> | n | avg | x1 | x2 | ... | xn |         
 4 : AAVERAGE ( adr  -- )                                          
 5         DUP 4 + OVER     \ a  a+4    a                          
 6         @ 2*             \ a  a+4    2n                         
 7         OVER + SWAP      \ a  a+2n+4 a+4                        
 8         0 0 2SWAP        \ a  0      0      a+2n+4  a+4         
 9         ?DO I @ DUP 0<>  \ a  sum    count  xn      flag        
10             IF 1 D+      \ a  sum    count                      
11             ELSE DROP                                           
12             THEN 2                                              
13         +LOOP            \ a  sum    count    <- final totals.  
14         / SWAP 2+ ! ;                                           
15                                                                 


Screen 35 not modified     
 0 \ Intelligent Data Structures.                                  
 1 \ This is a flag that indicates the acces mode. The default     
 2 \ mode is is fetch (flag false) and true indicates store mode.  
 3 VARIABLE (:=)   (:=) OFF                                        
 4 : :=  (:=) ON ;                                                 
 5 : AARRAY ( n  -- )                                              
 6         CREATE  DUP , 1+ 0                                      
 7                 ?DO 0 , LOOP                                    
 8         DOES>   DUP >R (:=) @                                   
 9                     >R (:=) OFF                                 
10                 SWAP 1+ 2* + R>                                 
11                 IF ! R> AAVERAGE                                
12                 ELSE @ R> DROP                                  
13                 THEN ;                                          
14                                                                 
15                                                                 
projects/sample9.blk.txt · Zuletzt geändert: 2013-06-06 21:27 (Externe Bearbeitung)