projects:sample8.blk
Examples for lecture number eight.
Screen 0 not modified
0 \ Examples for lecture number eight. 11:18JWB02/28/86
1 \ Last change: Screen 001 17:03jwb03/24/87
2
3
4 Dictionary Structure.
5
6 Vocabularies.
7
8 Recursion.
9
10
11
12
13
14
15
Screen 1 not modified
0 \ Load screen. 17:03jwb03/24/87
1 \ Typing OK always loads screen 1!
2 FROM SAMPLE1.BLK 9 LOAD \ MQUIT
3 6 VIEWS B:LEDIT.BLK \ Identify LEDIT.BLK as file # 6
4 6 VIEW# ! \ Set current view number.
5 FROM B:LEDIT.BLK OK \ load the line editor
6 NEW-EXP \ activate the new line editor.
7
8 7 VIEWS B:SAMPLE8.BLK \ Identify sample8.blk as file # 7
9 7 VIEW# ! \ Set current view number to 7
10
11 7 9 THRU \ Load Number Format examples and Verify.
12 16 18 THRU \ Load SPY
13
14 ONLY FORTH ALSO EDITOR ALSO FORTH DEFINITIONS
15
Screen 2 not modified
0 \ Review-1 Strings 21:41JWB11/14/85
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
4 ," {text}" ( -- -- ) ONLY USE OUTSIDE A WORD DEFINITION
5 Compile a counted {text} string into dictionary. Do not use in
6 a word definition!! System will crash (if you're lucky).
7
8 " {text}" ( -- adr count ) ONLY USE WITHIN A WORD DEFINITION
9 Compile a counted string into a word definition. When word
10 is later executed the address and count are returned.
11
12 Examples:
13 CREATE NAME$ ," George Smith"
14 : JOB$ " FORTH Programmer" ;
15
Screen 3 not modified
0 \ Review-2 COUNT TYPE EXPECT 21:58JWB11/14/85
1
2 COUNT ( adr adr+1 n)
3 If adr points to a counted string, COUNT will fetch the
4 character count an increment adr to point to first character.
5 Count is often used to fetch successive characters of a string
6
7 TYPE ( adr n -- ) Type n characters of string at adr.
8
9 FILL ( adr n c ) Fill string at adr with n copies of c .
10 ERASE ( adr n ) Fill string at adr with n null's or 0's.
11
12 EXPECT ( adr n -- )
13 Input a string of length n to buffer at adr . Actual number
14 of characters entered is stored in a variable called SPAN.
15 Note: EXPECT does not return a counted string.
Screen 4 not modified
0 \ Review-3 Moving Strings. 22:05JWB11/14/85
1
2 CMOVE ( adrf adrt n -- ) Use when adrf > adrt
3 Move n bytes from adrf to adrt. Left-most or low memory bytes
4 are moved first. ( ie Move starts at beginning of string.)
5 Use CMOVE to move strings down to lower memory.
6
7 CMOVE> ( adrf adrt n -- ) Use when adrf < adrt
8 Move n bytes from adrf to adrt. Right-most or high memory
9 bytes are moved first. ( ie Move starts at end of string.)
10 Use CMOVE> to move strings up to higher memory.
11
12 MOVE ( adrf adrt n -- )
13 Move n bytes from adrf to adrt. If adrf < adrt use CMOVE>
14 otherwise use CMOVE. This will prevent overlap.
15 Use MOVE when you can't remember whether to use CMOVE or CMOVE>
Screen 5 not modified
0 \ Review-4 Strings 22:10JWB11/14/85
1 \ Move a string at adrf and pack it at adrt with count n.
2 : CPACK ( adrf adrt n -- )
3 SWAP 2DUP C! \ Store string count.
4 1+ SWAP CMOVE ;
5 \ Chopping n characters from the left of a string
6 : CHOP ( adr count n adr' count' )
7 ROT OVER + -ROT - ; EXIT
8
9 -TRAILING ( adr count1 adr count2 ) Remove trailing blanks
10
11 \ CONVERT ( d1 adr1 d2 adr2 )
12 \ Convert a string at adr1+1 accumulating number into d1.
13 \ Stops at first non digit character at addr2. adr1 is usually
14 \ the address of a counted or packed digit string. The first
15 \ digit of the string will be at adr1+1 .
Screen 6 not modified
0 \ Review-5 Number formating 19:01JWB11/18/85
1
2 PAD ( -- adr ) Return address for string output buffer.
3 HLD ( -- adr ) Pointer to current location in output buf
4 HOLD ( n -- ) Add character n to string being formed.
5 SIGN ( n -- ) If n is negative insert a -ve sign in the
6 output string. DIFFERENT FROM BRODIE
7
8 <# ( dn dn ) Start number formating ( PAD HLD ! ) .
9 dn, the number to be formated, is not
10 used by <# but is usually present.
11 # ( dn dn' ) Convert one digit of dn using current
12 number BASE and remaining digits as dn' .
13 #S ( dn dn') Convert a number until finished. When
14 conversion is finished dn' will be zero.
15 #> ( dn adr len ) Terminate numeric conversion.
Screen 7 not modified
0 \ Number formating examples. 22:44JWB11/14/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 \ Save sign as third item.
12 <# ROT SIGN
13 ( 0< IF ASCII - HOLD ELSE ASCII + HOLD THEN )
14 # # ASCII . HOLD #S ASCII $ HOLD
15 #> TYPE SPACE ;
Screen 8 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 9 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 2- VERIFY ;
14 \ Problem 1: Use HEAD and 1LINE to write a better memory
15 \ DUMP utility.
Screen 10 not modified
0 \ CASE ... OF ... ENDOF ... ENDCASE 11:24JWB02/28/86
1 \ First look at sample7.blk screen number 28.
2 \ CASE causes an index value to be compared to a series
3 \ OF values. Any number of OF .. ENDOF pairs may be used.
4 \ OF is equivalent to OVER = IF DROP
5 \ ENDOF is equivalent to ELSE
6 \ ENDCASE is equivalent of DROP and number of THENs
7 \ When the index value equals one of the OF values, the sequence
8 \ between that OF and the corresponding ENDOF is executed.
9 \ Control then branches to the word following ENDCASE.
10 \ If no match is found, ENDCASE drops the index from the stack.
11
12 \ The "otherwise" case may be handled by a sequence placed
13 \ between the last ENDOF and ENDCASE. The index value must
14 \ however be preserved across this otherwise sequence so that
15 \ ENDCASE may DROP it.
Screen 11 not modified
0 \ Multi-way branching CASE Statement 22:52JWB11/14/85
1 : TIS ( -- -- ) CR ." THIS IS DIGIT NUMBER " ;
2 : TEST2 ( -- -- )
3 BEGIN KEY DUP 13 <> WHILE
4 CASE
5 ASCII 1 OF TIS ." ONE " ENDOF
6 ASCII 2 OF TIS ." TWO " ENDOF
7 ASCII 3 OF TIS ." THREE " ENDOF
8 ASCII 4 OF TIS ." FOUR " ENDOF
9 ASCII 5 OF TIS ." FIVE " ENDOF
10 ASCII 6 OF TIS ." SIX " ENDOF
11 ASCII 7 OF TIS ." SEVEN " ENDOF
12 ASCII 8 OF TIS ." EIGHT " ENDOF
13 ASCII 9 OF TIS ." NINE " ENDOF
14 ASCII 0 OF TIS ." ZERO " ENDOF
15 BEEP ENDCASE REPEAT DROP ;
Screen 12 not modified
0 \ Structure of a FORTH word definition. 19:24JWB11/18/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 13 not modified
0 \ View, Link, Name: Details 19:26JWB11/18/85
1 View Field: Contains the File # as set by VIEWS and the
2 Block # or screen # that the word definition is on.
3 File # The File # set by the VIEWS comand is in the top
4 or most significant 4 bits of the view field.
5 Block # Or screen # is in the low 12 bits of view field.
6 Link Field: Contains the address of the Name Field of the
7 of the previous word in the dictionary.
8
9 Name Field: Byte 1: 1 Delimeter bit
10 P Precedence bit, 1 for IMMEDIATE words
11 S Smudge bit, HIDE sets REVEAL clears.
12 0 4 Character count max is 31
13 Byte 2: 0char
14
15 Last Byte : 1char 1 is delimiter.
Screen 14 not modified
0 \ Code and Parameter fields 10:20JWB11/17/85
1 Code Field : Contains pointer to ( ie address of ) the
2 machine code of the routine that implements this
3 particular class of words. This will be
4 different for constants, variables, colon,
5 and machine code definitions. It is called
6 the code field because it always points to
7 machine code for the host CPU!!
8
9 Parameter Field The contents of this field depends on the type
10 of word. For single (16-bit) variables and
11 and constants it contains their 16-bit value.
12 For a colon definition it contains a list of
13 the cfa's of the words that make up the colon
14 definition. For a code definion it contains
15 the actual machine code for the word.
Screen 15 not modified
0 \ Accessing a words fields. 10:40JWB11/17/85
1
2 ' {word} ( -- cfa ) Leave code field address of {word}.
3
4 >VIEW ( cfa vfa ) Go to view field from code field.
5 >LINK ( cfa lfa ) Go to link field from code field.
6 >NAME ( cfa nfa ) Go to name field from code field.
7 >BODY ( cfa pfa ) Go to parameter field from code field.
8 VIEW> ( vfa cfa ) Go from view field to code field.
9 LINK> ( lfa cfa ) Go from link field to code field.
10 NAME> ( nfa cfa ) Go from name field to code field.
11 BODY> ( pfa cfa ) Go from body to code field.
12 N>LINK ( nfa lfa ) Go from name field to link field.
13 L>NAME ( lfa nfa ) Go from link field to name field.
14 Hints: Read >VIEW as "to view field"
15 VIEW> as "from view field"
Screen 16 not modified
0 \ SPY-VFA 20:04JWB11/18/85
1 \ Display contents of field in both binary and hex.
2 : .RAW ( adr -- )
3 DUP H. ." Contains: " @ DUP H. ." hex or " B. ." bin" ;
4 : SPY-VFA ( cfa -- )
5 CR ." VFA: "
6 >VIEW DUP .RAW CR 11 SPACES \ Display raw contents of vfa.
7 @ DUP 4095 AND DUP \ Mask top 4 bits to get scr#
8 IF SWAP 4096 / 15 AND ?DUP \ Extract view file number.
9 IF 2* VIEW-FILES + @ \ Find cfa of the view file.
10 ." Located in file: " \ Display file name.
11 >BODY .FILE
12 ELSE ." May be in current file: "
13 FILE?
14 THEN ." Screen # " . \ Display screen number.
15 ELSE 2DROP ." Entered at the terminal." THEN ;
Screen 17 not modified
0 \ SPY-LFA SPY-NFA 13:52JWB11/17/85
1
2 : SPY-LFA ( cfa -- )
3 CR ." LFA: "
4 >LINK DUP .RAW
5 CR 11 SPACES ." This word is linked to: "
6 @ L>NAME .ID ;
7
8 : SPY-NFA ( cfa -- )
9 CR ." NFA: "
10 >NAME DUP .RAW CR DUP HEX 1LINE DECIMAL
11 DUP C@ 64 AND CR 11 SPACES ." Precedence bit is "
12 IF " on." ELSE ." off." THEN
13 DUP C@ 32 AND ." Smudge bit is "
14 IF " on." ELSE ." off." THEN
15 C@ 31 AND ." The word length is " . ;
Screen 18 not modified
0 \ SYP-CFA SPY-PFA SPY 12:23JWB11/17/85
1
2 : SPY-CFA ( cfa -- )
3 CR ." CFA: " .RAW ;
4
5 : SPY-PFA ( cfa -- )
6 >BODY CR ." PFA: " .RAW ;
7
8 : SPY ( -- -- )
9 ' CR DUP SPY-VFA
10 CR DUP SPY-LFA
11 CR DUP SPY-NFA
12 CR DUP SPY-CFA
13 CR DUP SPY-PFA
14 CR KEY 13 = IF DROP ELSE (SEE) THEN ;
15
Screen 19 not modified
0 \ The Smudge bit and the Precedence bit 20:00JWB11/18/85
1 HIDE ( -- -- ) Removes last word defined by unlinking it
2 from its vocabulary thread. Previously smudge bit was set.
3 REVEAL ( -- -- ) Link the most recently defined word into
4 the current vocabulary. Previously smudge bit was cleared.
5 IMMEDIATE ( -- -- ) Turn on the precedence bit of the most
6 recently defined word in the dictionary.
7 IMMEDIATE flags a definition so that it is executed during
8 compilation instead of being compiled.
9 IMMEDIATE marks the most recently compiled definition so that
10 when it is encountered at compile time, it is executed rather
11 than compiled. Many compiler words are immediate.
12 ['] {word} This is an IMMEDIATE word used within a definition.
13 It used to compile the cfa of the following word as a
14 LITERAL or number. It is equivalent to the sequence
15 [ ' {word} ] LITERAL
Screen 20 not modified
0 \ DP HERE CURRENT #VOC CONTEXT 14:26JWB11/17/85
1 DP ( -- adr ) Variable containing the current top
2 of the dicitionary.
3 HERE ( -- adr ) Returns top of dictionary as stored in
4 DP
5 CURRENT ( -- adr ) Variable containing the pfa of the
6 vocabulary in to which new definitions
7 are compiled.
8 #VOCS ( -- n ) Constant whose value is the maximum
9 number of dictionaries that can be in
10 the search order.
11 CONTEXT ( -- adr ) Variable containing the address of the
12 array space that holds the 8=#VOCs
13 transient vocabulary pointers ( pfas)
14 The CONTEXT array specifies the search
15 order for the text interpreter.
Screen 21 not modified
0 \ ORDER VOC-LINK VOCS DEFINITIONS 14:37JWB11/17/85
1 ORDER ( -- -- ) Display the vocabulary names forming the
2 search order in their present search
3 order sequence. Then show vocabulary
4 into which new definitions will be put.
5 VOC-LINK ( -- adr ) Variable that contains pointer to the
6 most recently defined vocabulary.
7 The pointer is actually pfa+8 !!!
8 Vocabularies are thus linked in the
9 order of their creation.
10 VOCS ( -- -- ) List all vocabularies that exist in this
11 FORTH system.
12 DEFINITIONS ( -- -- ) Select the transient vocabulary ( first
13 in the context array) as the compilation
14 vocabulary into which all subsequent
15 new word definitions will be added.
Screen 22 not modified
0 \ VOCABULARY ALSO PREVIOUS 17:05JWB11/17/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 ALSO ( -- -- )
10 Push transient vocabulary making it the first resident
11 vocabulary in the search order.
12
13 PREVIOUS ( -- -- )
14 The inverse of ALSO, removes the most recently referenced
15 vocabulary from the search order.
Screen 23 not modified
0 \ ROOT ONLY SEAL 17:04JWB11/17/85
1
2 ROOT ( -- -- )
3 A small vocabulary for controlling search order.
4
5 ONLY ( -- -- )
6 Erases the search order and forces the ROOT vocabulary to be
7 the first and last.
8
9 SEAL ( -- -- )
10 Usage: SEAL FORTH will change the search order such that
11 only FORTH will be searched. Used for turn-key applications.
12
13
14
15
Screen 24 not modified
0 \ 17:16JWB11/17/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 HEX
5
6 \ PC! ( byte n -- ) Output byte to port number n.
7 \ PC@ ( n byte ) Input byte from port number n.
8
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 25 not modified
0 \ TONE 17:09JWB11/17/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 26 not modified
0 \ SCALE 17:30JWB11/17/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 27 not modified
0 \ Recursive Factorial Function. 21:34JWB11/18/85
1
2 : FACTORIAL ( n n! )
3 CR ." entering factorial" .S
4 DUP 0> IF DUP 1- [ REVEAL ] FACTORIAL [ HIDE ] *
5 ELSE DROP 1
6 THEN CR ." leaving factorial" .S ; EXIT
7
8 \ RECURSIVE Allow current definition to be self referencing.
9
10 : FACTORIAL ( n n! ) RECURSIVE
11 CR ." entering factorial" .S
12 DUP 0> IF DUP 1- FACTORIAL *
13 ELSE DROP 1
14 THEN CR ." leaving factorial" .S ;
15
Screen 28 not modified
0 \ 22:53JWB11/14/85
1 : 2** ( n 2**n ) RECURSIVE
2 CR ." entering" .S
3 DUP 0> IF 1- 2** 2*
4 ELSE DROP 1
5 THEN CR ." leaving " .S ;
6
7 : FIBONACCI ( n fib ) RECURSIVE
8 CR ." entering" .S DUP 0< ABORT" invalid argument"
9 DUP 1 >
10 IF DUP 1- FIBONACCI
11 SWAP 2- FIBONACCI +
12 THEN CR ." leaving " .S ;
13
14 \ : MYSELF LAST @ NAME> , ; IMMEDIATE
15 \ : RECURSE LAST @ NAME> , ; IMMEDIATE
Screen 29 not modified
0 \ Stack Bubble Sort 12:42JWB02/28/86
1
2 \ Recursive bubble sort
3 : BUBBLE ( n n n ... m m m ... one pass ) RECURSIVE
4 CR ." ENTERING " .S
5 DEPTH 1 >
6 IF 2DUP < IF SWAP THEN
7 >R BUBBLE R>
8 THEN
9 CR ." LEAVING " .S ;
10
11 : SORT ( n n n n ... m m m m ... sorted )
12 DEPTH 1 > IF
13 DEPTH 1- 0 DO BUBBLE LOOP THEN ;
14
15
Screen 30 not modified
0 \ Stack Bubble Sort 12:42JWB02/28/86
1 VARIABLE DIRECTION
2 : ASCENDING DIRECTION ON ; : DESCENDING DIRECTION OFF ;
3 : COMPARE DIRECTION @ IF < ELSE > THEN ;
4
5 : BUBBLE ( n n n ... m m m ... one pass ) RECURSIVE
6 CR ." ENTERING " .S
7 DEPTH 1 >
8 IF 2DUP COMPARE IF SWAP THEN
9 >R BUBBLE R>
10 THEN
11 CR ." LEAVING " .S ;
12
13 : SORT ( n n n n ... m m m m ... sorted )
14 DEPTH 1 > IF
15 DEPTH 1- 0 DO BUBBLE LOOP THEN ;
Screen 31 not modified
0 \ Multi-way branching IF .. ELSE .. THEN 14:58JWB03/04/86
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 ;
projects/sample8.blk.txt · Zuletzt geändert: 2013-06-06 21:27 von 127.0.0.1