projects:sample9.blk
Examples for lecture number nine
Screen 0 not modified
0 \ Examples for lecture number eight. 11:22JWB11/23/85
1 \ Last change: Screen 065 14:42JWB03/12/86
2
3
4 Extending the compiler.
5
6 Line backup buffer for Line editor.
7
8
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Load screen 10:04JWB11/24/85
1 \ Typing OK always loads screen 1!
2 6 VIEWS LEDIT.BLK \ Identify LEDIT.BLK as file # 6
3 6 VIEW# ! \ Set current view number.
4 FROM LEDIT.BLK OK \ load the line editor
5 NEW-EXP \ activate the new line editor.
6 7 VIEWS SAMPLE8.BLK \ Identify sample8.blk as file # 7
7 7 VIEW# ! \ Set current view number to 7
8 FROM SAMPLE8.BLK 7 LOAD \ Number Format examples & Verify.
9 FROM SAMPLE8.BLK 8 LOAD FROM SAMPLE8.BLK 9 LOAD
10 FROM SAMPLE8.BLK 16 LOAD \ Load SPY
11 FROM SAMPLE8.BLK 17 LOAD FROM SAMPLE8.BLK 18 LOAD
12 8 VIEWS SAMPLE9.BLK
13 8 VIEW# ! 7 LOAD 8 LOAD \ Sound words.
14 ONLY EDITOR ALSO SOUND ALSO FORTH DEFINITIONS
15 \ MARK EMPTY HERE FENCE ! SAVE-SYSTEM JFORTH.COM
Screen 2 not modified
0 \ Review-1 Dictionary Vocabularies 21:32JWB11/19/85
1 HIDE ( -- -- ) Unlink most latest word from dictionary.
2 REVEAL ( -- -- ) Link the latest word into the dictionary.
3 IMMEDIATE ( -- -- ) Set precedence bit so latest word is
4 executed during compilation instead of being compiled.
5
6 ['] {word} This is an IMMEDIATE word used within a definition.
7 It used to compile the cfa of the following word as a
8 LITERAL or number. It is equivalent to the sequence
9
10 [ ' {word} ] LITERAL
11
12 DP ( -- adr ) Variable containing next dict loacation.
13 HERE ( -- adr ) Returns next available dictionary location.
14 #VOCS ( -- n ) Constant, max vocabularies in search order.
15 VOCS ( -- -- ) List all vocabularies in this FORTH system.
Screen 3 not modified
0 \ Review-2 Vocabularies 21:31JWB11/19/85
1 CURRENT ( -- adr ) Points to compilation vocabulary.
2 CONTEXT ( -- adr ) Points the the vocabulary search order aray
3 First vocabulary in the list is called the
4 transient vocabulary, the remainder are
5 called the resident vocabularies.
6 DEFINITIONS ( -- -- ) Select the transient vocabulary ( first
7 in the context array) as the compilation
8 vocabulary into which all subsequent
9 new word definitions will be added.
10 ORDER ( -- -- ) Display current vocabulary search order.
11
12 ALSO ( -- -- ) Push transient vocabulary making it the first
13 resident vocabulary in the search order.
14 PREVIOUS ( -- -- ) The inverse of ALSO, removes the most
15 recently referenced vocabulary from the search order.
Screen 4 not modified
0 \ Review-3 Vocabularies 21:31JWB11/19/85
1
2 VOCABULARY {name} ( -- -- )
3 A dictionary entry for {name} is created which specifies a
4 new list of word definitions. Subsequent execution of {name}
5 replaces the first vocabulary in the current search order
6 with {name}. When name becomes the compilation vocabulary
7 new definitions will be appended to {name}'s word list.
8
9 ROOT ( -- -- ) A small vocabulary for controlling search order
10
11 ONLY ( -- -- ) Erases the search order and forces the ROOT
12 vocabulary to be the first and last.
13
14
15
Screen 5 not modified
0 \ Structure of a FORTH word definition. 21:33JWB11/19/85
1
2 4-bits 12-bits
3 vfa -> | File # | Block # | View Field
4 lfa -> | Link address | Link Field
5 nfa -> |1PScount | Name Field count=5bits
6 |0 char |
7 |0 char | char=7bits
8 |0 char |
9 |1 char |
10 cfa -> | Addr Inner Interpr.| Code field
11 pfa -> | Parameter List | Parameter Field
12 | . . . . | Also called the
13 | . . . . | BODY of the word
14 | . . . . | definition.
15
Screen 6 not modified
0 \ Making a new vocabulary 22:13JWB11/19/85
1 \ RECURSE Compile the cfa of the current definition.
2 \ : RECURSE LAST @ NAME> , ; IMMEDIATE
3
4 : FACT ( n n! )
5 DUP 0> IF DUP 1- RECURSE *
6 ELSE DROP 1
7 THEN ;
8
9 \ RECURSIVE Links the current definition so it can be found.
10 \ RECURSIVE Allow current definition to be self referencing.
11
12 : FACTORIAL ( n n! ) RECURSIVE
13 DUP 0> IF DUP 1- FACTORIAL *
14 ELSE DROP 1
15 THEN ;
Screen 7 not modified
0 \ Making a new vocabulary 21:38JWB11/19/85
1 ONLY FORTH ALSO DEFINITIONS CR ORDER
2 VOCABULARY SOUND CR .( VOCS ) VOCS CR
3 ROOT DEFINITIONS : SOUND SOUND ; CR ORDER
4 SOUND DEFINITIONS CR ORDER
5
6 \ PC! ( byte n -- ) Output byte to port number n.
7 \ PC@ ( n byte ) Input byte from port number n.
8 HEX
9 : S.ON ( -- -- ) \ Turn speaker on.
10 61 PC@
11 3 OR 61 PC! ;
12
13 : S.OFF ( -- -- ) \ Turn speaker off.
14 61 PC@
15 FFFC AND 61 PC! ; DECIMAL
Screen 8 not modified
0 \ Vocabularies 22:14JWB11/19/85
1
2
3 : TONE ( freq -- ) \ Make tone of specified frequency.
4 21 MAX \ Lowest frequency.
5 1.190000 ROT \ Get divisor for timer.
6 MU/MOD \ 16bit.rem 32bit.quot
7 DROP NIP [ HEX ] \ Keep 16-bit quotient only.
8 0B6 043 PC! \ Write to timer mode register.
9 100 /MOD SWAP \ Split into hi and low byte.
10 42 PC! 42 PC! \ Store low and high byte in timer.
11 S.ON ; DECIMAL \ turn speaker on.
12
13
14
15
Screen 9 not modified
0 \ Vocabularies. 23:18JWB11/19/85
1
2 : C 131 TONE ;
3 : D 147 TONE ;
4 : E 165 TONE ;
5 : F 175 TONE ;
6 : G 196 TONE ;
7 : A 220 TONE ;
8 : B 247 TONE ;
9 : CC 262 TONE ;
10
11 : BEAT 20000 0 DO LOOP ;
12
13 : SCALE C BEAT D BEAT E BEAT F BEAT G BEAT
14 A BEAT B BEAT CC BEAT BEAT BEAT S.OFF ;
15
Screen 10 not modified
0 \ Vectored execution, Brodie Ch 9 p 215 08:52JWB11/24/85
1
2 \ EXECUTE ( cfa -- ) Execute the word whose cfa is on stack
3
4 : F.HELLO ." Hello, I speak FORTH " ;
5 : B.HELLO ." Hello, I speak BASIC " ;
6 : P.HELLO ." Hello, I speak PASCAL" ;
7
8 VARIABLE INTRO
9
10 : GREETING INTRO @ EXECUTE ;
11
12 \ Try ' F.HELLO EXECUTE
13 \ ' F.HELLO INTRO ! GREETING
14 \ ' P.HELLO INTRO ! GREETING
15
Screen 11 not modified
0 \ PERFORM IS DEFER 09:32JWB11/24/85
1 \
2 \ PERFORM ( adr -- ) Equivalent to @ EXECUTE
3
4 : GREETING1 INTRO PERFORM ;
5
6 \ IS {word} ( adr -- ) Store adr in pfa of {word}
7 \ Sample usage: ' F.HELLO IS INTRO etc
8
9 : GREETING2 NOOP ;
10
11 \ DEFER {word} ( -- -- ) Like a variable except that it
12 \ fetches its contents and executes them.
13
14 DEFER GREETING3
15
Screen 12 not modified
0 \ Extending the compilers!!! 09:46JWB11/24/85
1 \ Template for creating new compilers:
2 \ : {compiler name}
3 \ CREATE {compile time code}
4 \ DOES> {run time code} ;
5
6 : BYTE-CON
7 CREATE C, \ Compile time procedure.
8 DOES> C@ ; \ Run time procedure.
9
10 : BYTE-VAR
11 CREATE 0 C, \ Compile time procedure.
12 DOES> ; \ Run time procedure.
13
14 11 BYTE-CON AA 22 BYTE-CON BB
15 BYTE-VAR XX BYTE-VAR YY
Screen 13 not modified
0 \ 10:01JWB11/24/85
1 VARIABLE STORE?
2
3 : => STORE? ON ;
4
5 : SMART-BYTE-VAR
6 CREATE 0 C,
7 DOES> STORE? @ STORE? OFF
8 IF OVER 255 >
9 ABORT" Range exceeded."
10 C!
11 ELSE C@
12 THEN ;
13
14 SMART-BYTE-VAR ZZ
15 SMART-BYTE-VAR WW
Screen 14 not modified
0 \ The MUSIC compiler. 11:43JWB11/24/85
1 ONLY FORTH ALSO SOUND DEFINITIONS
2 VARIABLE OCTAVE \ Octave to play
3 VARIABLE BEAT \ Number of beats for this note
4 5000 CONSTANT SPEED \ Alter to change 1/4 note time.
5 : DELAY SPEED 0 ?DO I DROP LOOP ; \ Aprox .5 sec delay.
6 \ Make it easy to change the beat and octave.
7 : 1/1 4 BEAT ! ; : 1/2 2 BEAT ! ; : 1/4 1 BEAT ! ;
8 : 1ST 1 OCTAVE ! ; : 2ND 2 OCTAVE ! ; : 3RD 4 OCTAVE ! ;
9 \ Rest for current number of beats.
10 : REST ( -- -- )
11 BEAT @ 0 ?DO DELAY LOOP ; : R REST ;
12 \ The note compiler.
13 : NOTE CREATE ,
14 DOES> @ OCTAVE @ * 5 + 10 / \ Compute frequency.
15 TONE REST S.OFF ; \ Play the note.
Screen 15 not modified
0 \ Create Notes 11:42JWB11/24/85
1 \ Create the notes with the note compiler.
2
3 1308 NOTE C 1386 NOTE C# 1468 NOTE D 1556 NOTE D#
4 1648 NOTE E 1746 NOTE F 1850 NOTE F# 1960 NOTE G
5 2077 NOTE G# 2200 NOTE A 2331 NOTE A# 2469 NOTE B
6
7
8 : SCALE 1ST 1/4 C D E F G A B 2ND 1/2 C R
9 1/4 C D E F G A B 3RD 1/2 C R ;
10
11
12
13
14
15
Screen 16 not modified
0 \ Music Music?? 11:32JWB11/24/85
1 : PART1 1/4 2ND F# E D C D E D
2 1ST A F# G A B A F# 1/2 A 1/4 2ND D E ;
3 : PART2 1/2 2ND F# F# 1/4 F# E D E F# E D F# 1/2 E ;
4
5 : PART3 1/4 2ND F# E F# G A F# D E F# D E 1ST A 1/2 2ND D R ;
6
7 : PART4 1/4 1ST F# E F# G A G F# E F# E F# G ;
8
9 : PART5 1/4 2ND D E F# D 1ST B 2ND C# D 1ST A F# G A F#
10 1/2 E 1/4 D E ;
11 : PART6 1/4 1ST F# E F# G A F# D E F# D E C# 1/2 D R ;
12
13 : TURKEY PART1 PART2 PART1 PART3 PART4 1/2 1ST A R
14 PART4 1/2 1ST B 1/4 B 2ND C# PART5 PART6 ;
15 2000 IS SPEED
Screen 17 not modified
0 \ Multi-diminsional arrays for F83 12:04JWB11/24/85
1 : ACHECK ( {n items} n {n items} n ) \ Check parameters.
2 DUP 1 < OVER 255 > OR
3 ABORT" Illegal dimension in array definition."
4 DUP 1+ ?ENOUGH ;
5 : *ARRAY ACHECK
6 CREATE
7 DUP C, ( save # of dimensions )
8 1 SWAP ( initialize total size )
9 0 DO ( loop on # of dimensions )
10 OVER , ( save dimension )
11 * ( increase total size )
12 LOOP
13 1 , ( save dummy dimension )
14 2 * ALLOT ( allocate space for words )
15 -->
Screen 18 not modified
0 \ Multi-dimensional array definition, cont 12:05JWB11/24/85
1 DOES>
2 COUNT ( get # of dimensions )
3 0 SWAP ( initialize offset )
4 0 DO ( loop on # of dimensions )
5 >R ( save offset )
6 OVER DUP 0< ABORT" Negative array index."
7 OVER @ < 0= ABORT" Array index too large."
8 2+ DUP @ ( advance to next dimension )
9 ROT R> + * ( calculate offset so far )
10 LOOP
11 2 * ( double offset for words )
12 + 2+ ; ( calculate element address )
13
14
15
Screen 19 not modified
0 \ Multi-dimensional array definition, cont 12:09JWB11/24/85
1 EXIT
2 To define an array, the vector size for each dimension
3 must be on the stack followed by the total # of dimensions
4 Example: to define a 3D array name MATRIX with a
5 vector length of 5 in each dimension (i.e. x, y, z = 0...4)
6 you would execute:
7 5 5 5 3 *ARRAY MATRIX
8
9 To get an indexed address into the array, put the coordinates
10 on the stack followed by the name of the array.
11 Example: to retrieve the value stored in (x,y,z) = (1,2,3)
12 for the array above, you would execute:
13 1 2 3 MATRIX @
14 to store (x,y,z) = 5 at 3D space x=2,y=3,z=5 do:
15 5 2 3 5 MATRIX !
Screen 20 not modified
0 \ Homework 12:14JWB11/24/85
1
2 EXIT
3 Homework Read Brodie chapter 11 p289-p299
4 Do problems 1, 2, & 3 p315 Answers are in the back
5
6
7
8
9
10
11
12
13
14
15
Screen 21 not modified
0 \ VECTOR 21:34JWB11/19/85
1 \ Create a one dimensional vector n storage cells
2 \ Usage: VECTOR {name} ( n -- )
3 \ Later: {name} ( index adr )
4
5 : VECTOR ( n -- )
6 CREATE \ This is the compile time routine
7 DUP , \ Compile n, maximum subscript.
8 0 DO 0 , LOOP \ Initialize vector to zeros.
9 DOES> \ index adr
10 TUCK @ OVER \ adr index n index
11 <= OVER 0< OR \ adr index flag
12 ABORT" Subscript out of range." \ Error message
13 1 + 2* + ; \ Compute address of ith element
14
15
Screen 22 not modified
0 \ ANY-SIGN? SKIP-BLANKS 15:20JWB11/25/85
1 \ Leave a true flag if string begins with a -ve sign.
2 \ Note we assume a counted string!! adr is 1 less than the
3 \ the first string character.
4 : ANY-SIGN? ( adr adr' flag )
5 DUP 1+ C@ DUP ASCII - = \ Increment adr , check for -
6 IF DROP 1+ TRUE \ Leave true flag if found.
7 ELSE ASCII + = \ Allow a +sign if desired.
8 IF 1+ THEN \ Increment past + sign
9 FALSE \ and leave false flag.
10 THEN ;
11 \ Move up to first non blank of string. Actually adr' points
12 \ to position before first non blank!!
13 : SKIP-BLANKS ( adr adr' )
14 BEGIN 1+ DUP C@ BL <> UNTIL 1- ;
15
Screen 23 not modified
0 \ FETCH/CONVERT 15:20JWB11/25/85
1 \ This routine fetches a string and converts to double number.
2 : FETCH/CONVERT ( adr n cur cur adr n dn )
3 BEGIN DUP CUR! \ a n c Position cursor.
4 -ROT 2DUP <LEDIT \ c a n Input string.
5 OVER 1- SKIP-BLANKS \ c a n Move up to non-blank
6 ANY-SIGN? \ c a n a' flg
7 >R 0 0 ROT -1 \ c a n dn a' -1
8 BEGIN DPL ! CONVERT \ c a n dn a"
9 DUP C@ ASCII . = \ c a n dn a" flg
10 WHILE 0 REPEAT \ c a n dn a" 0
11 C@ BL <> \ c a n dn flag
12 WHILE 2DROP R> DROP BEEP \ c a n
13 ASCII ? 2 PICK C! ROT \ a n c
14 REPEAT R> ?DNEGATE \ c a n dn
15 DPL @ 0< IF DPL OFF THEN ; \ DPL=0 if .pt not entered
Screen 24 not modified
0 \ (#IN) 15:20JWB11/25/85
1 \ Fetch a double number using field with of n using adr for
2 \ and input buffer. Invalid input is marked by ? and user is
3 \ required to repeat until he makes a valid number.
4 : (#IN) ( adr n dn )
5 CUR@ -ROT \ cur adr n Save cursor
6 2DUP 2+ BLANK \ cur adr n Blank buffer
7 DUP 0 ?DO 95 (CONSOLE) LOOP \ cur adr n Out underscore
8 ROT FETCH/CONVERT \ cur adr n dn
9 >R >R \ Save double number.
10 1+ ROT + CUR! \ Restore cursor.
11 DROP R> R> ; \ Recover our number.
12
13
14
15
Screen 25 not modified
0 \ D#IN WD#IN XYWD#IN 15:20JWB11/25/85
1 \ Input double number a current cursor position using default
2 \ field with of 6. Input buffer is at PAD
3 : D#IN ( -- dn )
4 PAD 12 (#IN) ;
5
6 \ As above but field width is specified on the stack.
7 : WD#IN ( n dn )
8 PAD SWAP (#IN) ;
9
10 \ As above but cursor position is also specified on the stack.
11 : XYWD#IN ( x y n dn )
12 -ROT AT WD#IN ;
13
14
15
Screen 26 not modified
0 \ S#IN WS#IN XYS#IN 15:20JWB11/25/85
1 \ Input single number a current cursor position using default
2 \ field with of 6. Input buffer is at PAD
3 : S#IN ( -- dn )
4 PAD 6 (#IN) DROP ;
5
6 \ As above but field width is specified on the stack.
7 : WS#IN ( n dn )
8 PAD SWAP (#IN) DROP ;
9
10 \ As above but cursor position is also specified on the stack.
11 : XYS#IN ( x y n dn )
12 -ROT AT WS#IN ;
13
14
15
Screen 27 not modified
0 \ Read screen location. SC@ 18:06JWB11/25/85
1 ONLY EDITOR ALSO FORTH ALSO DEFINITIONS
2
3 CODE SC@ ( -- char )
4 8 # AH MOV
5 BH BH SUB
6 16 INT
7 AH AH SUB
8 128 # AX CMP
9 U>= IF 32 # AL MOV THEN
10 1PUSH
11 END-CODE
12 : MARK ( n -- )
13 CUR@ 0 ROT AT SC@ 112 ATRIB ! VEMIT 15 ATRIB ! CUR! ;
14 : -MARK ( n -- )
15 CUR@ 0 ROT AT SC@ VEMIT CUR! ;
Screen 28 not modified
0 \ READ-SCREEN 15:21JWB11/25/85
1
2 CREATE SLINE-BUF 80 ALLOT
3 \ Copy line n of screen into SLINE-BUF .
4 : READ-SCREEN ( n -- )
5 25 MOD CUR@ >R
6 80 0 DO I OVER AT SC@
7 SLINE-BUF I + C!
8 LOOP DROP
9 R> CUR! ;
10
11 : TEST ( n -- )
12 READ-SCREEN
13 SLINE-BUF 80 -TRAILING TYPE ;
14
15
Screen 29 not modified
0 \ Code definitions: DOUBLE 10*
1 CODE DOUBLE ( n 2n )
2 BX POP \ Move n from stack to reg BX
3 BX BX ADD \ 2n
4 BX PUSH \ Move result to stack.
5 NEXT END-CODE
6
7 CODE 10* ( n 10n )
8 BX POP \ Move n from stack to reg BX
9 BX BX ADD \ 2n
10 BX AX MOV \ 2n
11 AX AX ADD \ 4n
12 AX AX ADD \ 8n
13 AX BX ADD \ 10n
14 BX PUSH \ Push 10n to the stack.
15 NEXT END-CODE
Screen 30 not modified
0 \ Sample code definitions for the curious. 12:51JWB02/21/86
1 CODE SPLIT ( hilo lo hi )
2 BX POP
3 AH AH SUB
4 BL AL MOV
5 AX PUSH
6 BH AL MOV
7 AX PUSH
8 NEXT END-CODE
9 CODE MELD ( lo hi hilo )
10 AX POP
11 BX POP
12 AL AH MOV
13 BL AL MOV
14 AX PUSH
15 NEXT END-CODE
Screen 31 not modified
0 \ RECURSIVE TREES
1 : TREE ( pfa -- ) RECURSIVE
2 CREATE , DOES> TREE ;
3 : TREE 0 TREE ;
4
5 : WHATIS ( -- -- )
6 [COMPILE] ' DUP CR >NAME .ID >BODY
7 BEGIN @ DUP
8 WHILE DUP BODY> >NAME .ID
9 REPEAT DROP ;
10
11 TREE VEHICLE VEHICLE BOAT VEHICLE CAR VEHICLE PLANE
12 BOAT FERRY BOAT TUG BOAT ROW
13 CAR VW CAR FORD CAR DODGE DODGE DART
14 VW BUS VW BEETLE VW RABBIT FORD MUSTANG
15 PLANE JET JET 737 JET 747
Screen 32 not modified
0 \ RECURSIVE TREES
1 : BTREE ( -- -- ) RECURSIVE
2 CREATE 0 , 0 ,
3 DOES> DUP BTREE
4 HERE 4 - SWAP !
5 BTREE
6 HERE 4 - SWAP 2+ ! ;
7 BTREE A
8 A B1 B2
9 B1 C1.1 C1.2
10 B2 C2.1 C2.2
11 C1.1 D1.1.1 D1.1.2
12 C1.2 D1.2.1 D1.2.2
13 C2.1 D2.1.1 D2.1.2
14 C2.2 D2.2.1 D2.2.2
15
Screen 33 not modified
0
1 : TAB BEGIN #OUT @ 7 MOD WHILE SPACE REPEAT ;
2
3 : LEAVES ( pfa -- ) RECURSIVE
4 DUP BODY> >NAME TAB .ID DUP @
5 IF DUP @ LEAVES 2+ @ LEAVES
6 ELSE CR DROP DEPTH 0 ?DO SPACE TAB LOOP THEN ;
7
8 : SL [COMPILE] ' >BODY CR LEAVES ;
9
10
11
12
13
14
15
Screen 34 not modified
0 \ Intelligent data structures.
1 \ Finds the average of the n elements at adr+4 and stores the
2 \ result at adr+2. Only non zero elements are counted.
3 \ AARRAY looks like -> | n | avg | x1 | x2 | ... | xn |
4 : AAVERAGE ( adr -- )
5 DUP 4 + OVER \ a a+4 a
6 @ 2* \ a a+4 2n
7 OVER + SWAP \ a a+2n+4 a+4
8 0 0 2SWAP \ a 0 0 a+2n+4 a+4
9 ?DO I @ DUP 0<> \ a sum count xn flag
10 IF 1 D+ \ a sum count
11 ELSE DROP
12 THEN 2
13 +LOOP \ a sum count <- final totals.
14 / SWAP 2+ ! ;
15
Screen 35 not modified
0 \ Intelligent Data Structures.
1 \ This is a flag that indicates the acces mode. The default
2 \ mode is is fetch (flag false) and true indicates store mode.
3 VARIABLE (:=) (:=) OFF
4 : := (:=) ON ;
5 : AARRAY ( n -- )
6 CREATE DUP , 1+ 0
7 ?DO 0 , LOOP
8 DOES> DUP >R (:=) @
9 >R (:=) OFF
10 SWAP 1+ 2* + R>
11 IF ! R> AAVERAGE
12 ELSE @ R> DROP
13 THEN ;
14
15
projects/sample9.blk.txt · Zuletzt geändert: 2013-06-06 21:27 von 127.0.0.1