Forth-eV Wiki

Benutzer-Werkzeuge

Webseiten-Werkzeuge

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

Unterschiede

Hier werden die Unterschiede zwischen zwei Versionen angezeigt.

Link zu dieser Vergleichsansicht

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