Forth-eV Wiki

Benutzer-Werkzeuge

Webseiten-Werkzeuge

Sie befinden sich hier: Forth Wiki » papierkorb » Examples for lecture number nine
Zuletzt angesehen:
papierkorb:sample9.blk

Unterschiede

Hier werden die Unterschiede zwischen zwei Versionen angezeigt.

Link zu dieser Vergleichsansicht

papierkorb:sample9.blk [2025-08-16 17:50] – ↷ Seite von projects:sample9.blk nach papierkorb:sample9.blk verschoben mkapapierkorb:sample9.blk [Unbekanntes Datum] (aktuell) – gelöscht - Externe Bearbeitung (Unbekanntes Datum) 127.0.0.1
Zeile 1: Zeile 1:
-=== Examples for lecture number nine === 
-<code> 
-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                                                                  
- 
-</code> 
papierkorb/sample9.blk.1755359401.txt.gz · Zuletzt geändert: 2025-08-16 17:50 von mka