-
Notifications
You must be signed in to change notification settings - Fork 0
/
1-EXTEND.FTH
4045 lines (3226 loc) · 217 KB
/
1-EXTEND.FTH
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
TACHYON 1 flags CLR
\ CREATE EXPLORER
( DEFAULT BUILD IS SMALL SO BE SURE TO "CREATE EXPLORER" BEFOREHAND IF YOU WANT EVERYTHING )
IFDEF EXTEND.fth COLD ( force a clean system as EXTEND.fth should be added first ) }
IFNDEF EXPLORER
pub EXTEND.fth ." Primary extensions to TACHYON kernel" }
IFDEF EXPLORER
pub EXTEND.fth ." Tachyon Forth Propeller hardware debugger and explorer" }
." - 160828-1400" ;
\ some source loader listing control to augment the TACHYON word
pub NOOP ;
pub OK ( on/off -- ) IF 0 ELSE ' NOOP THEN prompt 2+ W! ; \ enable/disable OK prompts including the autospace )
pub ECHO ( on/off -- ) 1 flags ROT IF SET ELSE CLR THEN ;
pub [~ OFF ECHO OFF OK $0D ' EMIT 6 - C! ; [~ \ disable LFs using code table (160804)
\ end of load symbol - reenable interactive console
pub ]~ ON ECHO ON OK $0A ' EMIT 6 - C! ;
{ CHANGELOG:
160828 Add I2CSTOP to ESAVE blank checks to clear i2cflg otherwise ?I2C has a long timeout
160823 Fix I2C routines - remove I2C constant, replace ?I2CSTART with general ?I2C which includes a timeout
I2CSTART always checks busy with timeout but use I2CREST for a normal quick restart
160804 RTC detected and used during build.
}
IFNDEF EXPLORER
IFNDEF INCLUDE
: INCLUDE
\ .......TICASS.ARR.MSSNHP_PCLOM.....
\ .......ETNDAT.NET.APEUEW-IHORA.....
\ .......RCTCNR.SPC.PRRMXM_NRCGT.....
\ 33_2222222222_1111111111_0000000000
\ 10_9876543210_9876543210_9876543210
%00_0000101001_1110001100_1101100000
;
} }
DECIMAL
{ BASIC CODE which is NOT optional } \ therefore not in a module:
pub @NAMES ( -- addr \ put the address of the names register on the stack )
names W@
;
{ HELP @HATR ( -- atrptr )
Return with the pointer to the latest header attribute
}
pri @HATR
@NAMES C@++ +
;
pub IMMEDIATE ( -- \ Set the "immediate" tag of the latest name in the dictionary )
BL @HATR SET
;
IMMEDIATE
IFNDEF UNSMUDGE
pub UNSMUDGE ( -- )
$40 @HATR CLR
;
IMMEDIATE
}
pub PRIVATE ( -- ) 8 @HATR SET ;
pub PUBLIC ( -- ) 8 @HATR CLR ;
\ 140827 Added ALIAS which also copies the attributes and bytecode - no extra vectors or code used
pub ALIAS ( <old> <new> -- ) IMMEDIATE
[COMPILE] NFA' [COMPILE] GRAB C@++ + [COMPILE] CREATEWORD @HATR 3 CMOVE
;
ALIAS [COMPILE] [C]
ALIAS { HELP:
ALIAS { {HELP \ preferred form to be compatible with Kernel source compiled through Prop Spin compiler
\ ******************* TACHYON FORTH KERNEL EXTENSIONS + I2C BUS ROUTINES *********************
\ Create a dummy word to ignore form feed characters - renamed to the ^L control character
pub a ; $0C @NAMES 1+ C!
{ maybe a module with debug tools and maybe a second with interactive terminal words -
would be great to put somewhere near the end of the file to optionally load in }
IFDEF EXPLORER
\ if you later decide you need a private word for debugging etc.
\ use this before issuing RECLAIM to keep the word around accessible
pub UNPRIVATE ( <word> -- ) 8 [C] NFA' [C] GRAB DUP C@ + 1+ CLR ;
IMMEDIATE
}
{ \ meanwhile kernel version is already public - no need for this any more
\ Now redefine pub to enforce a non-private attribute - so disable kernel version first
0 NFA' pub 1+ C! \ disable kernel version of pub
: pub [C] : PUBLIC ; IMMEDIATE
}
\ Set the default for all names to PRIVATE
pub [PRIVATE 8 flags SET ;
pub PRIVATE] 8 flags CLR ;
--- Multi-line interactive
pub [ IMMEDIATE $80 flags SET ;
pub ] IMMEDIATE $80 flags CLR ;
pub ... ( -- \ separator for readability ) ; IMMEDIATE
ALIAS ... ok \ To be able to copy&paste from the terminal including "ok" responses
\ Commenting aliases - a bit of flexibility to make comments stand out besides the \ and ( ) methods
ALIAS \ \\\ \ normally used to disable a section of code
ALIAS \ // \ alt C++ style comment
ALIAS \ --- \ spaces out the comment from the code. --- ----- use space + more dashes for more spacing
\ Aliases for readability (and preferred over easily obscured traditional dot forms)
ALIAS . PRINT
ALIAS ." PRINT"
ALIAS OFF NO --- using NO instead of OFF can read better (i.e. OFF PUMP or NO WATER)
ALIAS TRUE YES
ALIAS ; RETURN
ALIAS FOR TIMES
{ Add plain as day words such as TIMES instead of FOR etc.
Use it like this:
#P28 == LED // assign port pin as the LED
pub BLINKY
10 TIMES
LED HIGH
100 ms
LED LOW
100 ms
NEXT
RETURN
}
--- V2.10 corrects terminology where BFA is the byte field address in the header and CFA is always the code field itself
IFNDEF NFA>CFA
ALIAS BFA>CFA >PFA
}
IFDEF NFA>BFA
\ ALIAS NFA>CFA NFA>BFA
: NFA>CFA BEGIN C@++ $7F > UNTIL ;
}
{HELP CREATE$ ( str -- )
Create a new header in the dictionary
}
pub CREATE$ ( str -- )
DUP LEN$ DUP @word 1- C! @word SWAP CMOVE (CREATE)
;
{ MJB
each variable in memory takes the bytecode for var plus the size.
since the content is aligned to the content size some memory is lost
bytes following each other take 2 bytes memory each, alignment is no issue
words following each other need 3 bytes plus 1 byte wasted
longs following each other take 5 byte + 3 bytes wasted
so if you want to optimize before a long var there might be room for a free byte var
PBJ: If you want contiguous mixed variables it is best to use the ORG and DS words which allocate space in the ORG
region for "Data Storage". The "variable" name is actually a constant that points to this data area.
}
pub AVAR ( size align -- \ Create a variable of 1,2 or 4 bytes etc )
[C] GRAB \ grab anything that has been entered earlier
"," delim C! \ allow for comma delimited list
BEGIN
codes W@ OVER 1- ANDN OVER 1- + codes W! \ align to a byte before
[C] CREATE \ compile a VARB bytecode just before storage area
OVER IF OVER FOR 0 [C] C, NEXT THEN \ zero the variable area
delim 1+ C@ "," <> \ check for comma seperated lists of names
UNTIL
2DROP BL delim C!
;
IMMEDIATE
}
\ Define common variable sizes
pub DOUBLE 8 4 [C] AVAR ; IMMEDIATE
pub LONG 4 4 [C] AVAR ; IMMEDIATE
pub WORD 2 2 [C] AVAR ; IMMEDIATE
---
pub BYTE 1 1 [C] AVAR ; IMMEDIATE
\ Usage: #256 LONGS pwmmap
pub LONGS ( n <name> -- ) [C] GRAB 4* 4 [C] AVAR ; IMMEDIATE
pri WORDS: ( n <name> -- ) [C] GRAB 2* 4 [C] AVAR ; IMMEDIATE
--- always align start of bytes array as a long
pub BYTES ( n <name> -- ) [C] GRAB 4 [C] AVAR ; IMMEDIATE
\ TABLE creates a long align structure which returns the address at runtime but does not allocate any memory yet
pub TABLE ( <name> -- | -- addr ) IMMEDIATE
0 4 [C] AVAR
;
{
TABLE creates a long align structure which returns the address at runtime but does not allocate any memory yet
pub TABLE ( <name> -- | -- addr ) IMMEDIATE
codes W@ 3 ANDN 3 + codes W! '' align to a byte before a long address
[C] CREATE
;
}
pub CONSTANT IMMEDIATE
[C] GRAB
[C] TABLE '' create and step back to override VARB
-1 ALLOT
' 0 1+ [C] BCOMP '' compile a CONL instead (!!!! must be 23140602 kernel or later )
codes W@ 1+ !
4 ALLOT
;
ALIAS CONSTANT ==
pub !!SP !SP $DEADBEEF ; --- Init the datastack but leave a $DEADBEEF marker on it for stack debug
0 @ == CLKFREQ --- Create a constant for CLKFREQ rather than accessing location 0 (corruption)
IFDEF V3
$28 == _con
}
IFNDEF V3
$20 == _con
}
BYTE pstkwr
8 LONGS pstk
{HELP PUSH ( n -- )
PUSH value onto global stack
}
pub PUSH pstkwr C@ $1F AND pstk + ! 4 pstkwr C+! ;
pub POP -4 pstkwr C+! pstkwr C@ $1F AND pstk + @ ;
LONG radix \ 4 level deep radix stack
pub RADIX ( base -- \ Set number base )
?DUP IF base C! THEN
;
pub >RADIX ( base -- \ backup and set number base )
radix @ 8<< base C@ + radix ! RADIX
;
pub RADIX> ( -- \ restore previous radix )
radix @ DUP RADIX 8>> radix !
;
pri nout DROP ;
pub NULLOUT ( -- \ set EMIT to discard characters like \dev0 )
' nout uemit W!
;
\ almost all of the above is BASIC non optional, so should go before the optional modules, maybe some words from further down as well MJB.
\ minimal overhead EXTEND module loader
LONG mod2load \ collects the bitfield of the modules to be loaded
LONG modloaded \ collects the bitfield of the modules that have been loaded
0 modloaded !
}
{ INCLUDE MODULE NOTES
current list of modules
#0
#1
#2
#3
#4
#5 MODULE: MATHS_FUNCTIONS
#6 MODULE: FIXED_POSITION_VARIABLES
#7 MODULE: LOCAL_VARIABLES
#8 MODULE: CHARACTER_OUTPUT
#9 MODULE: PIN_I/O_OPERATIONS
#10 MODULE: PWM
#11 MODULE: HEX FILE LOAD & DUMP
#12 MODULE: NUMBER_PRINT_FORMATING
#13 MODULE: PBASIC_STYLE_SERIAL_I/O
#14 MODULE: EXAMINE_SPECIAL_PURPOSE_REGISTERS
#15 MODULE: Memory Map Reporting
#16
#17
#18 MODULE: COMPILER REPORTING
#19 MODULE: ANSI_TERMINAL
#20 MODULE: STRINGS
#21 MODULE: SAN_FILTER
#22 MODULE: MCP3208_8_channel_ADC
#23 MODULE: COUNTERS
#24 MODULE: INTERTASK_COMMUNICATIONS
#25 MODULE: TERSE COMMAND MODE
#26
#27
#28
#29
#30
#31
defaults (at present @160804 = 10,026 bytes free vs 5,590 bytes for EXPLORER)
0300 INCLUDING #9 PIN I/O OPERATIONS
0472 INCLUDING #8 CHARACTER I/O
0520 INCLUDING #6 FIXED POSITION VARIABLES
0627 INCLUDING #5 MATHS FUNCTIONS
0691 INCLUDING #12 NUMBER PRINT FORMATING
0851 INCLUDING #19 ANSI TERMINAL SUPPORT
1039 INCLUDING #20 STRINGS
1354 INCLUDING #14 EXAMINE SPECIAL PURPOSE REGISTERS
1607 INCLUDING #23 COUNTERS
2078 INCLUDING #18 COMPILER REPORTING
2220 INCLUDING #25 TERSE COMMAND MODE
}
\ until the module loader is functional, all potential modules are set active
-1 mod2load !
{
If we have defined a MODULES constant before loading EXTEND.fth then use it for mod2load
Usage: : INCLUDE 7 MASK #24 MASK OR #17 MASK OR #13 MASK OR #18 MASK OR #15 MASK OR #14 MASK OR INVERT ;
alt - : INCLUDE !SP #7 #24 #17 #13 #18 #15 #14 #10 #21 #22 0 DEPTH 1- FOR SWAP MASK OR NEXT INVERT ;
alt - define INCLUDES in kernel: INCLUDES 1,2,3,4,5,6,8,9,11,12,16,19,20,23,25,26,27,28,29,30,31
alt = there must be a better way
So INCLUDE would NOT load those specified modules due to the INVERT mask
}
IFDEF INCLUDE
INCLUDE mod2load !
}
\ used to define the module table below
: SETMOD ( id <name> -- ) BL names W@ C@++ +
SET \ IMMEDIATE \ the <name> is only for comment purposes and ignored
[C] GRAB \ make id available on stack
mod2load @ OR mod2load ! \ set the id bits in mod2load
[C] \ \ consume and ignore the module <name> from the input line
;
\ now mod2load contains the mask for all EXTEND modules to be loaded
pri MODULE: IMMEDIATE ( modulenumber0..31 <modulename> ) \ the module name is just consumed and discarded
[C] GRAB \ put the module number on the stack
DUP MASK DUP mod2load @ AND
IF modloaded @ OR modloaded ! --- remember which modules were loaded - app can examine modloaded
PRINT" INCLUDING #"
DECIMAL SWAP . SPACE
BEGIN KEY DUP $0D <> WHILE EMIT REPEAT --- treat anything that follows on this line as a comment (but echoed)
16 FOR SPACE NEXT EMIT
CR $10A EMIT --- force a new line (<> $0A)
ELSE 2DROP [C] { \ else treat the block as a { } comment, similar to IFDEF ... }
THEN ;
{ usage:
#10 MODULE: PWM
\ module goes here
} \ ends the module
}
#9 MODULE: PIN I/O OPERATIONS
( PIN I/O OPERATIONS )
IFNDEF P@ --- allow for removal of seldom used P@ and P! from kernel
pub P@ $1F2 COG@ ;
pub P! $1F4 COG! ;
}
pub PIN! ( state pin -- )
MASK
'' Set one or more pins to high or low state
pub OUT ( state pinmask -- )
DUP OUTPUTS SWAP SHROUT 2DROP
;
'' Read a single input pin
pub PIN@ ( pin -- state )
MASK
pub IN ( pinmask -- state )
P@ AND 0<>
;
\ pub HIGH? ( pin -- flg ) PIN@ ;
ALIAS PIN@ HIGH?
pub LOW? ( pin -- flg ) HIGH? 0= ;
\ Read input pins and right justify and mask - #P8 4 PINS@ - reads P8..P11 as a nibble
pub PINS@ ( pin for – n )
P@ ROT SHR SWAP MASK 1- AND
;
\ Build up a mask using a starting pin number and the number of consecutive pins
\ Useage: #16 8 MASKS CONSTANT dbus
pub MASKS ( pin cnt -- mask )
0 ROT ROT ADO I MASK OR LOOP
;
pub PINS! ( data pin for -- )
ROT 3RD SHL ( pin for data<<pin ) --- shift data into correct position
ROT ROT MASKS ( data<<pin mask ) --- create mask
OUTCLR OUTSET
;
} \ end of #9 MODULE: PIN_I/O_OPERATIONS
{HELP COGREG! ( dat index -- )
Each Tachyon cog has an set of registers for setting up masks etc which are used in repetitive operations.
These are referred to as COGREGs.
}
pub COGREG! ( dat index -- )
COGREG COG!
;
{HELP COGREG@ ( index -- dat )
Each Tachyon cog has an set of registers for setting up masks etc which are used in repetitive operations.
These are referred to as COGREGs.
}
pub COGREG@ ( ix -- dat \ fetch dat long from COG register with index ix )
COGREG COG@
;
\ WAITPxx instructions also capture the CNT into COGREG0 or 1
pub WAITPNE ( mask -- \ wait until pins are not equal to mask, then capture counter onto COGREG0 )
3 COGREG! (WAITPNE)
;
pub WAITPEQ ( mask -- \ wait until pins are equal to mask, then capture counter onto COGREG1 )
3 COGREG! (WAITPEQ)
;
( COUNTER )
IFDEF SPR@
pub CNT@ 1 SPR@ ;
}
IFNDEF SPR@
pub CNT@ $1F1 COG@ ;
}
pub J 3 LSTACK COG@ ;
pub K 5 LSTACK COG@ ;
pub IX 0 LSTACK COG@ ;
IFNDEF LEAVE
\ make the loop index = to the limit so that it will leave on the next LOOP
pub LEAVE
IX 1- 1 LSTACK COG!
;
}
{HELP UNLOOP
Break out of a loop - uses a special loop index and loop branch stack
This was changed from BREAK to UNLOOP as BREAK is now a word used in CASE structures
}
pub UNLOOP ( -- \ exit from loop )
L> L> 2DROP BRANCH> R> 2DROP
;
IFNDEF BOUNDS
\ Format a start and cnt into a to and from for DO (not required for ADO)
pub BOUNDS ( addr cnt -- to from )
OVER + SWAP
;
}
pub MIN ( n1 n2 -- n3 ) --- signed minimum of two items
OVER OVER > IF SWAP THEN DROP
;
pub MAX ( n1 n2 -- n3 ) --- signed maximum of two items
OVER OVER > IF SWAP THEN NIP
;
--- cacluate an average while maintaining fractional parts and return the average
--- Usage: 1000 <myvar> AVG
pub AVG ( val var -- avg )
DUP @ 2/ 2/ ROT SWAP -
OVER +! @ 2/ 2/
;
IFNDEF >VEC
pub >VEC
DUP 1+ C@ 4* XCALLS + SWAP C@ ' CALL 3 + -
3 XOR SWAP OVER 1 AND 2* + SWAP 2 AND IF $400 + THEN
;
}
\ Convert the CFA (tick address) into a pointer to the name string
pub PFA>NFA ( pfa -- name )
@NAMES 1+
BEGIN
DUP NFA>CFA >PFA 3RD = IF NIP EXIT THEN
NFA>CFA 3 +
DUP C@ 0=
UNTIL
2DROP 0
;
ALIAS PFA>NFA >NAME ( cfa -- name$ )
pub CFA>NFA ( cfa -- nfa
````
( CONVERSION )
\ Conversion between longs, words, bytes
IFDEF BITS
pub >W ( long -- word \ extract lower word from long ) 16 BITS ;
}
IFNDEF BITS
pub >W ( long -- word \ extract lower word from long )
16
pub BITS ( n1 bits -- ) MASK 1- AND ;
}
IFNDEF >B
pub >B ( long -- byte \ extract lower byte from long ) $FF AND ;
pub >N ( long -- byte \ extract lower nibble from long ) $0F AND ;
}
pub L>W ( long - loword hiword \ split long into 2 words ) DUP >W SWAP 16>> ;
pub W>B ( word - lobyte hibyte \ split word into 2 bytes ) DUP >B SWAP 8>> >B ;
pub W>L ( loword hiword -- long \ merge to words to long ) 16<< OR ;
pub B>W ( lobyte hibyte -- word \ merge to bytes to word ) 8<< OR ;
pub B>L ( lobyte byte2 byte3 byte4 -- long \ merge 4 bytes to long ) B>W >L B>W L> W>L ;
\ Increment and decrement variables at address
pub ++ ( longAddr -- \ increment long ) 1 SWAP +! ;
pub -- ( longAddr -- \ decrement long ) -1 SWAP +! ;
pub W++ ( wordAddr -- \ increment word ) 1 SWAP W+! ;
pub W-- ( wordAddr -- \ decrement word ) -1 SWAP W+! ;
pub C++ ( byteAddr -- \ increment byte ) 1 SWAP C+! ;
pub C-- ( byteAddr -- \ decrement byte ) -1 SWAP C+! ;
\ Clear and set variable at address
pub ~ ( longAddr -- \ clear long ) 0 SWAP ! ;
pub ~~ ( longAddr -- \ set long ) -1 SWAP ! ;
pub W~ ( wordAddr -- \ clear word ) 0 SWAP W! ;
pub W~~ ( wordAddr -- \ set word ) -1 SWAP W! ;
pub C~ ( byteAddr -- \ clear byte ) 0 SWAP C! ;
pub C~~ ( byteAddr -- \ set byte ) -1 SWAP C! ;
IFDEF EXTRAS
pub SWAPB ( word -- word2 \ Swap the bytes in a 16-bit word )
DUP 8>> SWAP >B 8<< OR
;
pub LBIT! ( mask addr state -- \ Set or clear the bits of a long in memory that match the bit mask. )
>L SWAP OVER @ L> IF OR ELSE SWAP ANDN THEN SWAP !
;
pub LONGFILL ( addr cnt longval -- \ Fill longs at addr for long cnt with longval )
3RD ! \ Store long at start address
OVER 4 + \ Set destination as next long address
SWAP 1- 4* \ Adjust to byte count less the first long
CMOVE \ and copy over and over itself
;
}
#8 MODULE: CHARACTER I/O
( CHARACTER OUTPUT )
pub KEY@ ( -- keycode ) lastkey C@ ;
pub KEY! ( keycode -- ) delim 13 + C! ;
\ Wait for a period and if no key is received then return with a null
\ wait timer = wait*42us so #225 = 10ms
pub WAITKEY ( wait -- key )
lastkey C~
BEGIN KEY@ 0= OVER 0<> AND WHILE 1- REPEAT
KEY
;
pub <CR> ( -- \ send a CR = $0D to output ) $0D EMIT ;
pub TAB ( -- \ send a TAB = $09 to output ) 9 EMIT ;
pub ESC? ( -- flg \ true if an escape has been pressed )
KEY@ $1B =
;
pub GETLINE ( buf -- len )
DUP BEGIN 0 OVER C! WKEY DUP $0D <> WHILE OVER C! 1+ REPEAT DROP SWAP -
;
\ Use alternative name to avoid conflict with FTP commands, also ensure controls are converted to spaces
pub CTYPE ( str cnt -- \ Type out the string for cnt characters )
ADO I C@ BL MAX EMIT LOOP
;
\ ALIAS CTYPE TYPE
pub SPACES ( cnt -- \ print many spaces )
BL SWAP
pub EMITS ( ch cnt -- \ emit the same character many times )
?DUP IF FOR DUP EMIT NEXT THEN DROP
;
} \ end of #8 MODULE: CHARACTER_OUTPUT
#7 MODULE: LOCAL VARIABLES
( LOCAL VARIABLES )
{ Saving stack parameters to local variables can simplify the stack manipulation required
A specified number of parameters are removed and copied to the local variables area but first the
existing local variables are pushed up so that they are saved and can be restored with a RELEASE
To simplify the use of these variables any direct reference to them will automatically fetch the contents
rather than cluttering the code with @ after each instance.
Example of using LOCALs:
pri (RECT)
X4 X3 X2 HLINE
X4 X3 X1 1- + X2 1- HLINE
X4 X2 + 1- X3 X1 VLINE
X4 X3 X1 VLINE
;
\ Draw a rectangle
pub RECT ( x1 y1 width height -- )
( X4 X3 X2 X1 )
4 LOCAL (RECT) 4 RELEASE
}
\ space for up to 16 locals
16 LONGS locals
pri @X ( index -- ) 4* locals + ;
pub X1 ( -- local1 \ push local 1 on the stack ) locals @ ;
pub X2 ( -- local2 \ push local 2 on the stack ) 1 @X @ ;
pub X3 ( -- local3 \ push local 3 on the stack ) 2 @X @ ;
pub X4 ( -- local4 \ push local 4 on the stack ) 3 @X @ ;
pub LOCAL ( n -- \ pop the n top stack elements to the local space, TOS => X1, TOS+1 => X2 .. )
locals OVER @X 3RD 4* $40 SWAP - <CMOVE 0 DO I @X ! LOOP
;
pub RELEASE ( n -- \ remove n elements from locals, of no longer used )
DUP @X locals ROT 4* $40 SWAP - CMOVE
;
locals $40 ERASE \ Clean out the locals (easier for debugging)
} \ end of #7 MODULE: LOCAL VARIABLES
#6 MODULE: FIXED POSITION VARIABLES
( FIXED POSITION VARIABLES )
{ Create fixed variables by borrowing from assembler syntax using an origin and specify number of bytes for each variable
This allows us to work from a fixed area in RAM and the variables end up being defined as constants.
Usage:
$4000 ORG
2 DS readptr \ allocates 2 bytes for readptr at $4000
2 DS writeptr \ allocates 2 bytes for writeptr at $4002
#64 DS mybuffer \ allocates 64 bytes for mybuffer at $4004
or
TABLE myvars #64 6 * ALLOT \ allocate long aligned memory for 6 sets of 64 bytes
myvars ORG \ work from the start of the table
#12 DS name
4 DS offset
\ etc
Test it out:
myvars . 2E30 ok
offset . 2E3C ok
}
LONG _org
pub ORG ( addr -- ) --- move addr to org variable as base address for DS and DS+ operations
_org ! ;
pub DS+ ( bytes -- ) --- allocate bytes without naming
_org +! ;
pub DS ( bytes <name> -- ) --- allocate bytes and assign it the <name> literal following the DS word
[C] GRAB --- get the bytes
_org @ --- get org, which is the start of this new variable
SWAP _org +! --- increment org by bytes length of this variable as base for next variable
[C] CONSTANT --- and compile the old org value into a constant named <name>
;
IMMEDIATE --- this needs to be done at compile time so make DS IMMEDIATE
{HELP The CONSTANT word is redefined to == to reduce the clutter and increase readability (IMO)
Since CONSTANT is an immediate word it is forced to compile with [C]
At some point the == word may work differently from CONSTANT by forcing the compilation of the literal constant
rather than the call to the definition. This is in part to allow constants to be defined simply for compilation
without consuming runtime memory
}
\ pub == [C] CONSTANT ; IMMEDIATE
IFDEF EXPLORER
( SPR COG REGISTERS )
$1F0 ORG
0 DS SPR
1 DS PAR
1 DS CNT
1 DS INA
1 DS INB
1 DS OUTA
1 DS OUTB
1 DS DIRA
1 DS DIRB
1 DS CTRA
1 DS CTRB
1 DS FRQA
1 DS FRQB
1 DS PHSA
1 DS PHSB
1 DS VCFG
1 DS VSCL
\ Store data in the SPR (original version did not add offset)
pub SPR! ( data offset -- )
SPR + COG!
;
}
} \ end of #6 MODULE: FIXED_POSITION_VARIABLES
( MATHS FUNCTIONS )
--- basic maths functions - always load
pub U> SWAP U< ;
pub / ( n1 n2 -- n3 ) \ 18us signed divide (org 47us) vs 10us U/
OVER ABS OVER ABS U/ \ perform unsigned division
ROT ROT XOR -NEGATE \ now get signs set result accordingly
;
pub UM*/ ( u1 u2 u3 -- Du1*u2/u3 )
ROT ROT UM* ROT UM/MOD64 ROT DROP
;
{HELP MOD ( n1 modulus -- rem )
Extract the remainder after division of n1 by modulus
Usage: 1234 10 MOD . 4 ok
}
pub MOD ( n1 mod -- rem )
U/MOD DROP
;
LONG (rnd) PRIVATE
CNT@ (rnd) ! \ seed it at compile time
\ COMMENT: RND ( -- n ) Generate a 32-bit pseudo-random number enhanced with the system counter
pub RND ( -- n \ 32 bit pseudo random number enhanced with system counter )
\ to seed with custom value use “seed (rnd) !”
(rnd) @ DUP #13 SHL XOR
DUP #17 SHR XOR
DUP 5 SHL XOR
CNT@ * DUP (rnd) ! \ randomize the result as well using the system CNT
;
{
loop:
y = y – 1/16 * x
x = x + 1/16 * y
pub Minsky ( xOld yOld step -- xNew yNew )
>L SWAP OVER IX SAR - SWAP ( xNew yOld )
OVER L> SAR + ( xNew yNew )
;
}
( MORE OPERATORS )
pub ALIGN ( address align -- val00 \ given align = 2^n set the n-1 lowest bits to 0
\ align the address to a ‘align’ bytes border
\ n = 0 is byte align, n = 1 is word align, n = 2 is long align )
1- SWAP OVER + SWAP ANDN ;
;
LONG ulong PRIVATE
pub U! ( long addr -- \ Unaligned store long )
SWAP ulong ! ulong SWAP 4 CMOVE
;
pub U@ ( addr -- long \ Unaligned fetch long )
ulong 4 CMOVE ulong @
;
ALIAS SHR >>
ALIAS SHL <<
ALIAS MASK |< ( bit -- mask \ SPIN syntax for MASK, bit is the 0-based position of the only one bit to set )
pub >| ( mask -- bit \ give the 0-based position of the highest bit set )
BL 0 DO 2/ DUP 0= IF DROP I LEAVE THEN LOOP
;
pub => ( n1 n2 -- flg \ true if n1 is equal to or greater than n2 )
1- > ;
pub <= ( n1 n2 -- flg \ true if n1 is smaller than or equal to n2 )
SWAP => ;
pub @. ( longAddr -- \ Fetch long and print number )
@ U. ;
--- redefine ms and us to suit clkfreq
pub ms
?DUP 0EXIT CLKFREQ #1000 / UM* DROP DELTA
;
{ doesn't appear to be used anymore
16 == indent
pub .HEAD ( str -- \ Print the string as a header on a new line and space up to column 16 )
\ or per user settings
\ change the constant indent to your indent level
DUP #100 < IF ' indent 1+ ! ELSE CR DUP PRINT$ LEN$ indent SWAP - SPACES THEN
;
}
pub DPL ( -- n ) \ Return with number of decimal places
digits 1+ C@ DUP IF digits C@ SWAP - THEN
;
\ Flag next number print routine to use leading spaces instead of leading zeros
pub LSP 4 flags SET ;
#5 MODULE: MATHS FUNCTIONS
pub % ( val % -- val2 ) * 100 / ;
--- 8-bit binary percentage so that 256 %% = 100 %
pub %% ( val bin% -- val2 ) SWAP 1+ * 8>> ;
( RANDOM NUMBER GENERATOR )
\ Return with a random number between the specified limits from min to max-1
pub GETRND ( max min -- n )
SWAP OVER - RND 2/ SWAP MOD SWAP +
;
{HELP ROUND
Round a number to the nearest rounding value
Usage: 474 10 ROUND -> 470
474 5 ROUND -> 475
}
pub ROUND ( n1 rounder -- n1rnd )
SWAP OVER U/MOD --- now round it off to the nearest 0.25MHZ
SWAP 2* 3RD => 1 AND + *
;
pub /ROUND ( val1 divisor -- val2 \ Scale down a value by a divisor but round it up
\ if the remainder is => half the divisor
\ Usage:4567 100 /ROUND . 46 )
DUP >L U/MOD
SWAP L> 2/ > IF 1+ THEN
;
IFDEF [SQRT]
--- RUNMOD version also loads the module - just use RUNMOD inside of loops
pub SQRT [SQRT] RUNMOD ;
}
IFDEF EXTRAS
pub COS ( angle -- cosine \ the angle is in radians scaled to ?? bits ?? )
$800 +
pub SIN ( angle -- sine \ the angle is in radians scaled to ?? bits ?? )
DUP $1000 AND SWAP \ test quadrant 3|4
DUP $800 AND IF NEGATE THEN \ test quadrant 2|4 and negate if true
$7000 OR 2* W@ \ lookup word from sin table
SWAP IF NEGATE THEN \ if quadrant 3|4, negate sample
;
--- Powers
pub SQR ( value -- value*value )
DUP *
;
pub POW ( n pwr -- n^pwr )
1 SWAP FOR OVER * NEXT NIP
;
3.14159265 == PI ( 8 decimal places )
pub CIRC ( radius -- circumference )
2* 355 113 */
;
--- calculate the hypotenuse
--- 14 25 LAP HYPOT LAP .LAP 360.000us ok
pub HYPOT ( A B -- hypot )
DUP * SWAP DUP * + SQRT
;
--- return with the hypot as a double scaled to 5 decimal places
pub DHYPOT ( A B -- hypot.nnnnn )
DUP * SWAP DUP * + UMSQRT
;
{ Quick hypotenuse calculation - longerside + shorterside*⅜
Error is less than 6.78% max - 3% mean error
Execution time: 14.4us
}
pub QHYPOT ( A B -- hypot )
2DUP < IF SWAP THEN
DUP 2* + 3 SHR + \ *3/8
;
{ TEST: HYPOT function
pub HDEMO ( addr -- )
$40 DECIMAL
ADO I W@ $7FFF AND I 2 + W@ $7FFF AND
CR OVER .DEC TAB DUP .DEC
TAB PRINT" APPROX HYPOT=" 2DUP HYPOT DUP 0 REG ! .DEC TAB
PRINT" HYPOT = " ^2 SWAP ^2 + SQR DUP .DEC
DUP 0 REG @ - ABS #10000 * SWAP /
TAB PRINT" ERROR=" <# # # "." HOLD #S #> PRINT$ ." %" \ calulate % error scaled to 2 decimal places
4 +LOOP
;
}
}
{
Square root method based on this Tristan Muntsinger algorithm which uses multiplication:
unsigned int c = 0x8000;
unsigned int g = 0x8000;
for(;;) {
if(g*g > n)
g ^= c;
c >>= 1;
if(c == 0)
return g;
g |= c;
}
Timing:
1234 DUP * LAP SQRT LAP .LAP SPACE . 296.800us 1234 ok
200000000 LAP SQRT LAP .LAP SPACE . 300.200us 14142 ok
355.000000 113 / LAP SQRT LAP .LAP SPACE . 294.600us 1772 ok
}
IFNDEF SQRT
pub SQRT ( n -- sqrt )
$8000 DUP ( n c g )
BEGIN
DUP DUP * 4TH > --- if (g*g > n)
IF OVER XOR THEN --- g ^= c
SWAP 2/ ( n g c ) --- c >>= 1