Benutzer-Werkzeuge

Webseiten-Werkzeuge


projects:sample7.blk

Examples for lecture number seven.

Screen 0 not modified     
 0 \ Examples for lecture number seven.           14:27JWB11/03/85 
 1 \ Last change:   Screen  013                   13:20JWB02/21/86 
 2                                                                 
 3                                                                 
 4         Strings.                                                
 5                                                                 
 6         Number Formating.                                       
 7                                                                 
 8         Case  Statement                                         
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 1 not modified     
 0 \ Load Screen for sample 7.blk                 12:54JWB02/21/86 
 1 \ Typing  OK   always loads screen 1!                           
 2                                                                 
 3   FROM LEDIT.BLK  OK  \ load the line editor                    
 4   NEW-EXP             \ activate the new line editor.           
 5                                                                 
 6                                                                 
 7   10 11  THRU    \ load the new dump utility.                   
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 2 not modified     
 0 \ Suggested Projects - choose one.             13:06JWB02/21/86 
 1 1 HELP SYSTEM - organize, rewrite and/or add to existing help   
 2   screens(sample1.blk). Comment source screens and prepare word 
 3   glossary.  Fix help system so it works even when sample1.blk  
 4   in not the current screen file.                               
 5 2 LINE EDITOR - finish detailed comments screens 51 -62.  Modify
 6   function key assignments to match DOSEDIT.  Prepare word      
 7   glossary.  Add the recall line from screen feature.           
 8 3 FORTH BBS & TERMINAL PROGRAM - Sample term pgm is in FORTH DIM
 9   V6 N5, Don V. and Jack B have some BBS source.  Get it working
10   Detailed comments and word glossary.  Then enhance it.        
11 4 FLOATING POINT MATH - add the transcendental functions, square
12   root, etc to our simple floating point package. Detailed      
13   comments, glossary etc.                                       
14 5 FAST FOURIER TRANSFORM and COMPLEX NUMBERS -  Reference       
15   DDJ V9 N9 Sept 1984 page34, I have some of the source on disk.


Screen 3 not modified     
 0 \ Review-1 Star-slash the scaler.              20:54JWB10/31/85 
 1 \ */  ( a b c   ab/c )                                          
 2 \ Perform multiplication and then division.                     
 3 \ Star-slash multiplies 16bit  a  and  16bit  b  to form a 32bit
 4 \ intermediate result which is then divided by 16bit c to give a
 5 \ 16bit result.  The 32bit intermediate product ensures accurate
 6 \ results when multiplying by fractions.                        
 7                                                                 
 8 \ We use */  to multiply a  by the fraction b/c                 
 9 \ Examples:                                                     
10 \  32-bit intermediate product results in correct answer.       
11 \  15000   3   4  */      gives   11250     correct answer      
12                                                                 
13 \  16-bit intermediate product results in overflow and the      
14 \  15000   3   *  4 /     gives   -5134     wrong   answer      
15                                                                 


Screen 4 not modified     
 0 \ Review-2 Star slash mod, Rounding Fracti     21:04JWB10/31/85 
 1 \  */MOD  ( a b c   r q )                                       
 2 \ Compute ab/c with 32bit intermediate product ab  and leave    
 3 \ quotient q and remainder r .  Note:  Forth-83 */MOD uses      
 4 \ signed values  a b c  and uses floored symmetric division.    
 5                                                                 
 6 \ Rounding calculations that involve division.                  
 7 : %R1    10 */     5 +            10 /  .    ;                  
 8 : %R2    50 */     1+             2/    .    ;                  
 9 : %R3   100 */MOD  SWAP 50 +  100 / +   .    ;                  
10 : %R4   100 */MOD  SWAP 49 > NEGATE +   .    ;                  
11                                                                 
12 \ Fractions:  see Brodie page 125 for more.                     
13 : *PI       355     113 */ ;                                    
14 : *SQRT(2)  19601 13860 */ ;                                    
15 : *E        28667 10546 */ ;                                    


Screen 5 not modified     
 0 \ Review-3 Timer module.                       22:19JWB10/31/85 
 1 \ Return current time in ticks (18.2/sec) as a double integer.  
 2   CODE @TICKS ( --  dn )                                        
 3        AH  AH SUB       \ Set AH  to zero for timer read.       
 4            IP PUSH      \ Save FORTHs interpretive pointer.     
 5            RP PUSH      \ Save FORTHs return stack pointer.     
 6            26 INT       \ Call function 26 for timer read.      
 7            RP POP       \ Restore return stack pointer.         
 8            IP POP       \ Restore interpretive pointer.         
 9            DX PUSH      \ Push low 16 bits of double number.    
10            CX PUSH      \ Push high 16 bits of double number.   
11               NEXT      \ Return to inner interpreter.          
12               END-CODE  \ Indicate end of code definition.      
13   2VARIABLE TICKS                                               
14 \ Save current time in ticks.                                   
15 : !TIMER ( --  -- ) @TICKS TICKS 2! ;             : TIME ;      


Screen 6 not modified     
 0 \ Review-2 Timing Template.                    21:51JWB10/31/85 
 1   FORGET TIME    : TIME ;                                       
 2 \ Fetch elapsed time in ticks.                                  
 3 : @TIMER  ( --  dn )                                            
 4            @TICKS TICKS 2@ D- ;                                 
 5                                                                 
 6 \  @TIMER gives time in ticks, 18.2 ticks/sec so if we perform  
 7 \  1000 passes we can get count in micro-secs for one pass.     
 8                                                                 
 9 :  TIME.IT                                                      
10    !TIMER 1000   0                                              
11    DO      TUCK   NIP                     LOOP                  
12    @TIMER DROP CR                                               
13    5000 91 */   . 230 EMIT ." -seconds for one pass." ;         
14                                                                 
15 : TEST CR  5 0 DO TIME.IT LOOP ;                                


Screen 7 not modified     
 0 \ Review-5 Infinite & indefinite Loops         22:34JWB10/31/85 
 1 The infinite loop with no exit.                                 
 2                                                                 
 3      ... (step 1)  BEGIN   (step2)  AGAIN   (step3) ...         
 4                                                                 
 5 The infinite loop with EXIT  escape hatch.                      
 6                                                                 
 7    ... (s1) BEGIN (s2)                                          
 8                   (condition) IF EXIT THEN                      
 9                   (s3)                                          
10             AGAIN (s4) ...                                      
11 Indefinite Loops                                                
12                                                                 
13     ... (s1)  BEGIN   (s2)                                      
14                      (condition)                                
15               UNTIL   (s3) ...                                  


Screen 8 not modified     
 0 \ Review-6 Indefinite Loops                    15:40jwb11/01/85 
 1                                                                 
 2 \  ... (s1)  BEGIN  (s2)                                        
 3 \                   (condition)                                 
 4 \            WHILE  (s3)                                        
 5 \            REPEAT (s4) ...                                    
 6                                                                 
 7                                                                 
 8                                                                 
 9                                                                 
10                                                                 
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 9 not modified     
 0 \ Review-7 Loops                               15:40jwb11/01/85 
 1 \   ... (s1)  l i   DO  (s2)      LOOP  (s3) ...                
 2 \   ... (s1)  l i   DO  (s2)  n  +LOOP  (s3) ...                
 3 \   ... (s1)  l i  ?DO  (s2)      LOOP  (s3) ...                
 4 \   ... (s1)  l i  ?DO  (s2)  n  +LOOP  (s3) ...                
 5 \ Leaving Loops early.                                          
 6 \   (s1)  l i   DO    (s2)                                      
 7 \                     (condition) IF  (s3) LEAVE THEN           
 8 \                     (s4)                                      
 9 \               LOOP  (s5) ...                                  
10 \ This is an alternative form if step 3 is not required.        
11 \   (s1)  l i   DO    (s2)                                      
12 \                     (condition) ?LEAVE                        
13 \                     (s4)                                      
14 \               LOOP  (s5) ...                                  
15 \                                                               


Screen 10 not modified     
 0 \ [IN]  .ASCII  ?SPACE  .RBYTE  HEAD           14:33JWB11/02/85 
 1 \ Leave true flag if  a <= x <= b .                             
 2 : [IN]  ( x a b  f )  1+ -ROT 1- OVER < -ROT > AND ;            
 3                                                                 
 4 : .ASCII ( n  -- ) \ EMIT n as printable ascii or a space.      
 5         127 AND DUP BL 126 [IN] NOT IF DROP BL THEN EMIT ;      
 6 \ Double space if i is equal to 8 .                             
 7 : ?SPACE ( i  -- ) 8 = IF SPACE SPACE THEN ;                    
 8 \ Print byte right justified in field w wide.                   
 9 : .RBYTE ( n w  -- )                                            
10          >R 0 <# # # #> R> OVER - SPACES TYPE ;                 
11 \ Based on address adr ,  display heading for VERIFY            
12 : HEAD  ( adr   -- )                                            
13       CR 5 SPACES 16 0 DO I OVER + 255 AND                      
14       I ?SPACE 3 .RBYTE LOOP                                    
15       2 SPACES 16 0 DO I OVER + 15 AND 1 .R LOOP DROP ;         


Screen 11 not modified     
 0 \ 1LINE VERIFY  PEEK    Problem 1.              14:39JWB11/02/85
 1 : 1LINE     ( adr   -- ) \ Verify 16 bytes from address.        
 2    DUP CR 0 4 D.R SPACE  DUP           \ Display address.       
 3    16 0 DO   I ?SPACE COUNT  3 .RBYTE  \ Display bytes in hex.  
 4         LOOP DROP 2 SPACES                                      
 5    16 0 DO   COUNT  .ASCII             \ Display bytes as ASCII.
 6         LOOP DROP SPACE   ;                                     
 7                                                                 
 8 : VERIFY ( adr  -- ) \ Only 32 bytes from adr with header.      
 9      BASE @ SWAP HEX DUP HEAD                                   
10      DUP 1LINE DUP 16 + 1LINE HEAD  CR BASE ! ;                 
11                                                                 
12 \ Dump out first 32 bytes of a word in the dictionary.          
13 : PEEK  ' >NAME 1-  VERIFY ;                                    
14 \ Problem 1:  Use  HEAD  and 1LINE to write a better memory     
15 \ DUMP utility.                                                 


Screen 12 not modified     
 0 \ String operators-1                           13:15JWB02/21/86 
 1 \ A counted string in memory is   |05|48|45|4C|4C|4F|   <-hex   
 2 \ preceded by character count.    |05| H| E| L| L| O|           
 3 \   Compile a counted {text} string into dictionary.            
 4 \ ," {text}"  ( --  -- )  USE OUTSIDE DEFINITION ONLY!!!        
 5 CREATE NAME$ ," George Smith"                                   
 6 \   If adr points to a counted string,  COUNT will fetch the    
 7 \ character count an increment adr to point to first character. 
 8 \ Count is often used to fetch successive characters of a string
 9 \ as in the definition of TYPE below and VER of screen 11.      
10 \ COUNT ( adr   adr+1 n)                                        
11   : COUNT  DUP 1+ OVER C@ ;  \  Actually  COUNT is a CODE  def. 
12 \ Given address adr and character count n type the string.      
13 \ TYPE  ( adr n  -- )     Type n characters of string at adr.   
14 : TYPE                                                          
15       0 ?DO  COUNT EMIT LOOP DROP ;                             


Screen 13 not modified     
 0 \ String operators-2                           13:20JWB02/21/86 
 1 \ " {text}" ( --  adr count )  ONLY USE WITHIN A WORD DEFINITION
 2 \ Compile a counted string into a word definition.  When word   
 3 \ is later executed the address and count are returned.         
 4 : JOB$  " FORTH Programmer" ;                                   
 5                                                                 
 6 : DASHED1  CR ." ----------" ;                                  
 7 CREATE DASH  ," ----------" ;                                   
 8                                                                 
 9 : DASHED2  CR DASH COUNT TYPE ;                                 
10 : DASHED3  CR " ----------" TYPE ;                              
11 : DASHED4  CR 10 0 DO  ASCII - EMIT LOOP ;                      
12                                                                 
13 \ FILL  ( adr  n c )   Fill string at adr with n copies of c .  
14 \ ERASE ( adr  n   )   Fill string at adr with n null's or 0's. 
15                                                                 


Screen 14 not modified     
 0 \ String Examples.                             13:11JWB02/21/86 
 1 \ Input a string of length n to buffer at adr . Actual number   
 2 \ of characters entered is stored in a variable called SPAN.    
 3 \ EXPECT ( adr n  -- )                                          
 4 \ Note:  EXPECT does not return a counted string.               
 5 CREATE BUFFER1  80 ALLOT       VARIABLE LEN                     
 6 \ Accept a string up to 80 characters long from the console.    
 7 : READLINE  ( --  -- )                                          
 8            BUFFER1 80 BL FILL   \ Clear BUFFER1 to blanks.      
 9         CR BUFFER1 80  EXPECT SPAN @ LEN ! ;                    
10 \ Note:  Actual character count is returned in variable SPAN    
11                                                                 
12 \ Display string stored in BUFFER1                              
13 : SHOWLINE  ( --  -- )                                          
14      CR  BUFFER1 LEN @  TYPE ;                                  
15                                                                 


Screen 15 not modified     
 0 \ Moving Strings.                              22:20JWB10/31/85 
 1 \ Move n bytes from adrf to adrt.  Left-most or low memory bytes
 2 \ are moved first. ( ie  Move starts at beginning of string.)   
 3 \ CMOVE    ( adrf  adrt  n  -- )   Use when  adrf > adrt        
 4 \ Use CMOVE to move strings down to lower memory.               
 5                                                                 
 6 \ Move n bytes from adrf to adrt. Right-most or high memory     
 7 \ bytes are moved first. ( ie Move starts at end of string.)    
 8 \ CMOVE>   ( adrf  adrt  n  -- )  Use when adrf < adrt          
 9 \ Use CMOVE> to move strings up to higher memory.               
10                                                                 
11 \ Move n bytes from adrf to adrt. If adrf < adrt use CMOVE>     
12 \ otherwise use CMOVE.  This will prevent overlap.              
13 \ MOVE     ( adrf  adrt  n  -- )                                
14 : MOVE -ROT 2DUP U<                                             
15        IF   ROT CMOVE>  ELSE  ROT CMOVE  THEN  ;                


Screen 16 not modified     
 0 \  Packing and chopping strings.               14:47JWB11/02/85 
 1   CREATE BUFFER2   80 ALLOT                                     
 2                                                                 
 3 \ Move a string at adrf and pack it at adrt with count n.       
 4 : CPACK  ( adrf adrt n  -- )                                    
 5         SWAP 2DUP  C!   \ Store string count.                   
 6         1+  SWAP  CMOVE  ;                                      
 7                                                                 
 8 \ Try:  READLINE   BUFFER1  BUFFER2  LEN @  CPACK               
 9 \       BUFFER2  VERIFY                                         
10 \       BUFFER2  COUNT  TYPE                                    
11                                                                 
12 \ Chopping n characters from the left of a string               
13 : CHOP  ( adr count n  adr' count' )                            
14         ROT OVER + -ROT - ;                                     
15                                                                 


Screen 17 not modified     
 0 \ -TRAILING  CONVERT                           14:54JWB11/02/85 
 1 \  Remove trailing blanks from a string.                        
 2 :  -TRAILING ( adr count1   adr count2 )                        
 3         DUP  0                                                  
 4         ?DO                \ Examine each character if any.     
 5             2DUP + 1-      \ Address of last character.         
 6             C@ BL <>       \ Is this character a blank?         
 7             IF LEAVE THEN  \ If its not we are done.            
 8             1-             \ Decrease count by 1 to shorten.    
 9          LOOP ;                                                 
10 \ Convert a string at adr1+1 accumulating number into d1.       
11 \ Stops at first non digit character at addr2.  adr1 is usually 
12 \ the address of a counted or packed digit string.  The first   
13 \ digit of the string will be at adr1+1   .                     
14 \ CONVERT  ( d1  adr1    d2  adr2 )                             
15                                                                 


Screen 18 not modified     
 0 \  Converting a string to a number.            22:20JWB10/31/85 
 1 \  Convert a ASCII digit string to a double number.             
 2 :  VAL  ( adr count   dn  flag )                                
 3         PAD SWAP CPACK     \ Copy and pack string at PAD buffer.
 4         BL PAD COUNT + C!  \ Add a blank at the end of string.  
 5         0 0                \ Double number accumlator.          
 6         PAD                \ Start address-1                    
 7         CONVERT            \ Convert the number.                
 8         DUP C@ ASCII - =   \ Stopped by -ve sign?               
 9         IF  CONVERT        \ If so continue conversion.         
10             >R DNEGATE R>  \ Apply the -ve sign to result.      
11         THEN C@  BL =  ;   \ Successful conversion if we end    
12                            \ with a blank.                      
13 : D#IN   BEGIN  READLINE  BUFFER1 LEN @ VAL NOT                 
14          WHILE  CR ." REDO FROM START"  2DROP                   
15          REPEAT  ;                                              


Screen 19 not modified     
 0 \ EMIT  CTYPE                                  15:19JWB11/02/85 
 1 \ Echo character n to the printer if its on and the console.    
 2 \ : EMIT  ( n   -- )                                            
 3 \       PRINTING @                                              
 4 \       IF    DUP (PRINT) -1 #OUT +!                            
 5 \       THEN  (CONSOLE)  ;                                      
 6                                                                 
 7 \ PRINTING  ( --  adr ) Printer flag. True for printer output.  
 8 \ (PRINT)   ( n  -- )   Send character n to the printer.        
 9 \ (CONSOLE) ( n  -- )   Send character n to the console only.   
10 \ #OUT      ( --  adr ) Variable, # of characters output since  
11                         the last carriage return.               
12 \ Output n bytes of string at adr to console only.              
13 : CTYPE  ( adr  n  --  )                                        
14         0 ?DO  COUNT  (CONSOLE)  LOOP  DROP ;                   
15                                                                 


Screen 20 not modified     
 0 \ Double Number Conversion Primitives-1.       15:35JWB11/02/85 
 1   CREATE PBUF  40  ALLOT   \ Buffer to hold output string.      
 2 : PAD  ( --  adr )         \ Return address for output string.  
 3       PBUF  16  +  ;                                            
 4   VARIABLE  HLD            \ Current output address in PBUF .   
 5  : ???   CR .S  PBUF 1LINE CR ;                                 
 6 : HOLD   ( n  -- )   \ Add character n to string being formed.  
 7         -1 HLD +!   HLD @  C!  ;                                
 8 \ Start numeric conversion.                                     
 9 : <#     ( --   -- )     PBUF  32 ERASE                         
10         PAD  HLD  !  ; \ Initialize HLD for new output.         
11 \ Terminate numeric conversion.                                 
12 : #>     ( dn   adr len )                                       
13         2DROP         \ Drop double number.                     
14         HLD @         \ Address of string.                      
15         PAD OVER - ;  \ Compute length of string.               


Screen 21 not modified     
 0 \ Double Number Conversion Primitives-2.       15:53JWB11/02/85 
 1 \ If n is negative insert a -ve sign in the output string.      
 2 : SIGN  ( n  -- )                                               
 3         0< IF   ASCII -  HOLD  THEN  ;                          
 4 \ Convert a single digit using the current number BASE.         
 5 : #  ( dn     dn' )                                             
 6         BASE @   MU/MOD     \ Divide dn by current base.        
 7         ROT  9   OVER  <    \ Digit greater than 9 ?            
 8         IF   7   +   THEN   \ Add offset of letter A for hex etc
 9     ASCII 0 + HOLD ( ???) ; \ Add offset to digit zero and save.
10 \  MU/MOD  is a mixed mode division operator.  It divides a     
11 \ double number dn by a single divisor n leaving a single       
12 \ remainder r and a double quotiend dq.                         
13 \  MU/MOD   ( dn n   r  dq  )   \  dn = dq*n + r                
14 : #S  ( dn  dn')   \ Convert a number until finished.           
15         BEGIN  #  2DUP  OR  0=  UNTIL  ;                        


Screen 22 not modified     
 0 \ Numeric Output-1                             16:04JWB11/02/85 
 1                                                                 
 2 \ (U.)  Convert an unsigned 16 bit number to a string.          
 3 : (U.)  (S u -- a l )   0    <# #S #>   ;                       
 4 \ U.    Output as an unsigned single number with trailing space.
 5 : U.    (S u -- )       (U.)   TYPE SPACE   ;                   
 6 \ U.R   Output as an unsigned single number right justified.    
 7 : U.R   (S u l -- )     >R   (U.)   R> OVER - SPACES   TYPE   ; 
 8                                                                 
 9 \ (.)   Convert a signed 16 bit number to a string.             
10 : (.)   (S n -- a l )   DUP ABS 0   <# #S   ROT SIGN   #>   ;   
11 \ .     Output as a signed single number with a trailing space. 
12 : .     (S n -- )       (.)   TYPE SPACE   ;                    
13 \ .R    Output as a signed single number right justified.       
14 : .R    (S n l -- )     >R   (.)   R> OVER - SPACES   TYPE   ;  
15                                                                 


Screen 23 not modified     
 0 \ Numeric Output-2                             16:03JWB11/02/85 
 1                                                                 
 2 \ (UD.) Convert an unsigned double number to a string.          
 3 : (UD.) (S ud -- a l )  <# #S #>   ;                            
 4 \ UD.   Output as unsigned double number with a trailing space  
 5 : UD.   (S ud -- )      (UD.)   TYPE SPACE   ;                  
 6 \ UD.R  Output as an unsigned double number right justified.    
 7 : UD.R  (S ud l -- )    >R   (UD.)   R> OVER - SPACES   TYPE  ; 
 8                                                                 
 9 \ (D.)  Convert a signed double number to a string.             
10 : (D.)  (S d -- a l )   TUCK DABS   <# #S   ROT SIGN  #>   ;    
11 \ D.    Output as a signed double number with a trailing space. 
12 : D.    (S d -- )       (D.)   TYPE SPACE   ;                   
13 \ D.R   Output as a signed double number right justified.       
14 : D.R   (S d l -- )     >R   (D.)   R> OVER - SPACES   TYPE   ; 
15                                                                 


Screen 24 not modified     
 0 \ Number formating examples.                   15:35JWB11/02/85 
 1 \ Print single number as four digit hex and preserve system base
 2 : H.     BASE @ >R 16 BASE !                                    
 3          0 <# # # # # #>                                        
 4          R> BASE !  TYPE SPACE ;                                
 5 \ Print 16-bit number as binary saving preserving current BASE. 
 6 : B.     BASE @ >R  2 BASE !                                    
 7          0 <#  # # # #  # # # #  # # # #  # # # #  #>           
 8          R> BASE !  TYPE SPACE ;                                
 9 \ Print double number as signed dollars and cents.              
10 : $.   ( dn   -- )                                              
11     TUCK DABS   <#                                              
12          ROT   0< IF ASCII - HOLD ELSE ASCII + HOLD THEN        
13          # #  ASCII . HOLD  #S  ASCII $ HOLD                    
14                  #>  TYPE SPACE  ;                              
15                                                                 


Screen 25 not modified     
 0 \ Formating the time.                          15:35JWB11/02/85 
 1                                                                 
 2 : SECONDS ( --   dn )                                           
 3    @TICKS  18 MU/MOD  ROT DROP ;    ( should be 18.2 )          
 4                                                                 
 5 :  SEX  6 BASE !   ;                                            
 6                                                                 
 7 : :##   #  ( base 10 )  SEX   # ( base 6 )                      
 8         DECIMAL   ASCII :  HOLD  ;                              
 9                                                                 
10 : .TIME                                                         
11       SECONDS   <#  :##   :##  #S  #>  TYPE  SPACE  ;           
12 \ Problem:                                                      
13 \ We need M*/ to get the SECONDS correct.  See Brodie page 174  
14 \ and screen 24 of SAMPLE2.BLK  and fix SECONDS so we get the   
15 \ correct time.                                                 


Screen 26 not modified     
 0 \  Home Work                                   15:35JWB11/02/85 
 1 \ Do problems 1 through 8  page 182 of BRODIE                   
 2                                                                 
 3 \ Redefine  D.  so that                                         
 4 \ 1234567.  D.  gives    1,234,567                              
 5                                                                 
 6 \ Now do it again so that                                       
 7 \ 1234567.  D.  gives   1 234 567.         <<< Note dec. point  
 8                                                                 
 9 \ Write the word O. that displays a number as Octal while       
10 \ preserving the current system base.                           
11                                                                 
12 \ Write B.R  H.R  and O.R   that take a number n  and a field   
13 \ width  w  and then display  Binary, Hex, or Octal right       
14 \ justified in a field w wide while preserving the current      
15 \ system base.                                                  


Screen 27 not modified     
 0 \  Editor words used in  LEDIT                 15:35JWB11/02/85 
 1                                                                 
 2 \  LITTLE-CURSOR   Makes a little cursor.                       
 3 \  BIG-CURSOR      Makes a big cursor.                          
 4                                                                 
 5 \  Clear window with ul corner at  (x,y) and lr at (x',y').     
 6 \  a is the attribute byte.  7 or  0111 binary clears window.   
 7 \  112  or  01110000 binary clears window to all white!!        
 8 \  INIT-WINDOW  ( x y x' y' a   -- )                            
 9 :  DELAY   0 0 DO LOOP ;                                        
10 :  WOW     32  0 DO 0 0 79 24 I INIT-WINDOW                     
11           CR ." THIS IS NUMBER " I .  DELAY LOOP ;              
12                                                                 
13 \ Wait for key press ( without ^C abort ) and return as n.      
14 \  {KEY}        ( --   n )                                      
15                                                                 


Screen 28 not modified     
 0 \ Multi-way branching IF .. ELSE .. THEN       14:09JWB11/03/85 
 1 : TIS  ( --  -- ) CR  ."  THIS  IS  DIGIT  NUMBER  "  ;         
 2 : TEST1  ( --  -- )                                             
 3     BEGIN  KEY  DUP 13 <> WHILE                                 
 4       ASCII 1  OVER = IF DROP  TIS  ." ONE "     ELSE           
 5       ASCII 2  OVER = IF DROP  TIS  ." TWO "     ELSE           
 6       ASCII 3  OVER = IF DROP  TIS  ." THREE "   ELSE           
 7       ASCII 4  OVER = IF DROP  TIS  ." FOUR "    ELSE           
 8       ASCII 5  OVER = IF DROP  TIS  ." FIVE "    ELSE           
 9       ASCII 6  OVER = IF DROP  TIS  ." SIX "     ELSE           
10       ASCII 7  OVER = IF DROP  TIS  ." SEVEN "   ELSE           
11       ASCII 8  OVER = IF DROP  TIS  ." EIGHT "   ELSE           
12       ASCII 9  OVER = IF DROP  TIS  ." NINE "    ELSE           
13       ASCII 0  OVER = IF DROP  TIS  ." ZERO "    ELSE           
14      BEEP DROP  THEN  THEN  THEN  THEN  THEN                    
15                 THEN  THEN  THEN  THEN  THEN  REPEAT DROP ;     


Screen 29 not modified     
 0 \ CASE ... OF ... ENDOF ...  ENDCASE           14:19JWB11/03/85 
 1 \ CASE  causes an index value to be compared to a series        
 2 \ OF    values.  Any number of OF .. ENDOF  pairs may be used.  
 3 \ OF      is equivalent to  OVER = IF DROP                      
 4 \ ENDOF   is equivalent to  ELSE                                
 5 \ ENDCASE is equivalent of DROP and number of THENs             
 6 \ When the index value equals one of the OF values, the sequence
 7 \ between that OF and the corresponding ENDOF is executed.      
 8 \ Control then branches to the word following ENDCASE.          
 9 \ If no match is found,  ENDCASE drops the index from the stack.
10                                                                 
11 \ The "otherwise" case may be handled by a sequence placed      
12 \ between the last ENDOF  and ENDCASE.  The index value must    
13 \ however be preserved across this otherwise sequence so that   
14 \ ENDCASE  may  DROP it.                                        
15                                                                 


Screen 30 not modified     
 0 \ (OF)                                         14:12JWB06/16/85 
 1 \ EQUIVALENT TO   OVER = IF  DROP                               
 2 CODE (OF)                                                       
 3            AX   POP    BX  POP                                  
 4        BX  AX   CMP                                             
 5      0<> IF BX  PUSH                                            
 6      0 [IP] IP  MOV                                             
 7                 NEXT                                            
 8      THEN   IP  INC                                             
 9             IP  INC                                             
10                 NEXT END-CODE                                   
11                                                                 
12                                                                 
13                                                                 
14                                                                 
15                                                                 


Screen 31 not modified     
 0 \ CASE OF ENDOF ENDCASE                        14:12JWB06/16/85 
 1 ( see FORTH DIMENSIONS, II/3 page 37 )                          
 2                                                                 
 3 : CASE          CSP @ !CSP TRUE ; IMMEDIATE                     
 4                                                                 
 5 : OF            ?CONDITION COMPILE (OF) ?>MARK ; IMMEDIATE      
 6                                                                 
 7 : ENDOF         COMPILE BRANCH ?>MARK                           
 8                 2SWAP  ?>RESOLVE TRUE  ; IMMEDIATE              
 9                                                                 
10 : ENDCASE       ?CONDITION  COMPILE DROP BEGIN SP@              
11                 CSP @ = 0= WHILE ?>RESOLVE                      
12                           REPEAT CSP ! ; IMMEDIATE              
13                                                                 
14                                                                 
15                                                                 


Screen 32 not modified     
 0 \ Multi-way branching   CASE  Statement        14:06JWB11/03/85 
 1 : TEST2  ( --  -- )                                             
 2     BEGIN  KEY  DUP 13 <> WHILE                                 
 3     CASE                                                        
 4       ASCII 1  OF         TIS  ." ONE "     ENDOF               
 5       ASCII 2  OF         TIS  ." TWO "     ENDOF               
 6       ASCII 3  OF         TIS  ." THREE "   ENDOF               
 7       ASCII 4  OF         TIS  ." FOUR "    ENDOF               
 8       ASCII 5  OF         TIS  ." FIVE "    ENDOF               
 9       ASCII 6  OF         TIS  ." SIX "     ENDOF               
10       ASCII 7  OF         TIS  ." SEVEN "   ENDOF               
11       ASCII 8  OF         TIS  ." EIGHT "   ENDOF               
12       ASCII 9  OF         TIS  ." NINE "    ENDOF               
13       ASCII 0  OF         TIS  ." ZERO "    ENDOF               
14             BEEP                                                
15     ENDCASE                         REPEAT DROP ;               



Screen 34 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                                      
projects/sample7.blk.txt · Zuletzt geändert: 2013-06-06 21:27 (Externe Bearbeitung)