-
Notifications
You must be signed in to change notification settings - Fork 7
/
cortex.w
4304 lines (4224 loc) · 103 KB
/
cortex.w
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
World [
Title: "Cortex Preferences"
Date: 12-Oct-2015
Version: 0.7.20
History: [
0.7.20 [12-10-2015 JN {Changed FIND/CASE back to FIND in tab-completion}]
0.7.19 [28-9-2015 JN {Added system/schemes}]
0.7.18 [21-9-2015 JN {Changed and' or' xor' to and? or? xor?}]
0.7.17 [9-8-2015 JN {Added OPEN
Changed net-utils to use local variables}]
0.7.16 [2-8-2015 JN {Added immediate! and IMMEDIATE?
Changed typeset! to an immediate!}]
0.7.15 [31-7-2015 JN {Changed PRINT-LAST-ERROR to not output long strings}]
0.7.14 [30-7-2015 JN {Changed CHANGE
Added READ/BINARY to LOAD in case of /ALL}]
0.7.13 [29-7-2015 JN {Added system/options/home to INCLUDE}]
0.7.12 [28-7-2015 JN {Added comment!
Changed LOAD to use MAKE block! to load comments}]
0.7.11 [24-7-2015 JN {Changed any-object to any-context
Added copy/shallow to parse-utils/split-string}]
0.7.10 [23-7-2015 JN {Added task-id and task-name to PRINT-LAST-ERROR}]
0.7.9 [21-7-2015 JN {Changed issue! from any-string! to any-word!}]
0.7.8 [12-7-2015 JN {Added /part refinement to lowercase and uppercase
Added bitset? and tuple?
Added replacE
Added check for lit-string! in HELP
Changed LOAD/LINES to not include empty lines, unless /ALL
Changed LOAD to not use BACK and TAIL
Changed LAST to not use TAIL
Changed LAST regarding retain
Changed AFTER to use NEXT'
Changed TAB-COMPLETION to not use TAIL and SKIP
Changed TAB-COMPLETION to use :values (it could be a function)
Changed EMPTY? regarding retain
Optimized SWITCH
Fixed bug in DETAB
Removed complex! from number!}]
0.7.7 [7-5-2015 JN {Added path! support to INCLUDE}]
0.7.6 [3-4-2015 JN {Added word! support to INCLUDE}]
0.7.5 [30-3-2015 JN {Made comment a mezzanine again}]
0.7.4 [12-3-2015 JN {Added lit-string!}]
0.7.3 [10-3-2015 JN {Changed FIND to FIND/CASE in debase
Changed FIND to FIND/CASE in tab-completion}]
0.7.2 [2-3-2015 JN {Changed FORM regarding issue!, set-word!, get-word!, lit-word!,
and refinement! values
Fixed sparse regarding new FORM
Moved dt (Delta-time) to %mezz/delta-time.w
Added map!
Removed /retain from CHANGE}]
0.7.1 [13-2-2015 JN {Added as-range
Added callback
Added callback?}]
0.7.0 [6-2-2015 JN {Added tau}]
0.6.31 [6-2-2015 JN {Added typeset! to type-rules in bparse}]
0.6.30 [30-1-2015 JN {Added to-local-file
Added load}]
0.6.29 [17-1-2015 JN {Added support for block within blocks to SAVE
Added /lines refinement to SAVE
Added support for block newlines to FORM
Removed special treatment of integer! in FORM}]
0.6.28 [28-10-2014 JN {Changed tail? to test on =, not >=}]
0.6.27 [22-6-2014 JN {Added char! to random}]
0.6.26 [18-4-2014 JN {Added node, node! and node?}]
0.6.25 [16-3-2014 JN {Added support for rules like [copy var 2 skip] to parse
Added binary recognition to string parsing
Fixed string parsing when changing input
Fixed FOREACH in case of just one value in data}]
0.6.24 [20-1-2014 JN {Added support for block newlines to SAVE
Added /skip refinement to SORT}]
0.6.23 [2-10-2013 JN {Added vector!
Added vector helper function}]
0.6.22 [17-9-2013 JN {Changed help to deal with datatypes in all cases
Changed >> to use negate instead of unary minus
Improved random}]
0.6.21 [7-8-2013 JN {Added pair!
Added pair?
Added as-pair
Added image!
Added image?
Added dehex
Added email!
Added email?
Added list!
Added list?
Added enbase
Added debase
Added actor
Added compose
Fixed parse regarding new mem rules and SET
Improved help}]
0.6.20 [10-7-2013 JN {Changed input to not use trim}]
0.6.19 [2-7-2013 JN {Added task-id! to any-type!
Added task-id?}]
0.6.18 [19-6-2013 JN {Added task! to any-function!
Added support for task! to several functions}]
0.6.17 [7-6-2013 JN {Added kill}]
0.6.16 [4-6-2013 JN {Added task, task! and task?}]
0.6.15 [2-6-2013 JN {Added bitset! and tuple! to any-type!}]
0.6.14 [31-5-2013 JN {Changed form regarding integer!}]
0.6.13 [28-5-2013 JN {Added last}]
0.6.12 [26-5-2013 JN {Added of
Removed /deg from arccos, arcsin and arctan
Added to-deg
Changed include
Remove time (was the same as dt)
Added block rules to bitset
Changed set/at to set/local/at in parsing}]
0.6.11 [24-5-2013 JN {Made head and tail native
Made negate, not and clear native
Changed detab to not use parse
Fixed foreach
Changed forall
Added deg}]
0.6.10 [14-5-2013 JN {Moved last-error to system
Added detab}]
0.6.9 [12-5-2013 JN {Changed source to also take function argument}]
0.6.8 [10-5-2013 JN {Added input}]
0.6.7 [9-5-2013 JN {Added retain to many functions
Added /free and /retain to change}]
0.6.6 [4-5-2013 JN {Added columnize to sys-utils
Added tab-completion to sys-utils}]
0.6.5 [1-5-2013 JN {Added forall}]
0.6.4 [29-4-2013 JN {Changed input' to local in parse}]
0.6.3 [27-4-2013 JN {Added free-all}]
0.6.2 [26-4-2013 JN {Changed random to return percent!
Fixed bug in form}]
0.6.1 [22-4-2013 JN {Changed head and tail to support word! *** Doesn't work with contexts! ***
Changed help, becuase of new memory management}]
0.6.0 [9-4-2013 JN {Changed q, because of new memory management}]
0.5.24 [21-2-2012 JN {Added copy-series to sys-utils
Improved head
Removed /local from head and tail}]
0.5.23 [20-2-2012 JN {Added mold-series to sys-utils}]
0.5.22 [19-2-2012 JN {Rewrote switch because of datatype! <-> word! coercion}]
0.5.21 [17-2-2012 JN {Added none! check to empty?
Added more?}]
0.5.20 [16-2-2012 JN {Removed append, as it's now native }]
0.5.19 [22-12-2011 JN {Added check on system/options/quiet}]
0.5.18 [22-12-2011 JN {Removed ?? (binding rules)}]
0.5.17 [19-12-2011 JN {Added "No information" to help}]
0.5.16 [17-12-2011 JN {Changed print of typeset! argument types in help}]
0.5.15 [15-12-2011 JN {Added routine
Added ??
Fixed bug in foreach}]
0.5.14 [13-12-2011 JN {Added struct}]
0.5.13 [12-12-2011 JN {Added type check to append}]
0.5.12 [11-12-2011 JN {Added compile/reset to append}]
0.5.11 [10-12-2011 JN {Added sys-utils}]
0.5.10 [5-12-2011 JN {Added routine! to help}]
0.5.9 [2-12-2011 JN {Added license
Removed compile from loop
Added min
Added reverse
Fixed bug in parse
Changed does
Added has}]
0.5.8 [28-11-2011 JN {Added dump-obj
Removed call-by-word from head, tail, sort, trim,
lower- and uppercase}]
0.5.7 [27-11-2011 JN {Added time (the same as dt)}]
0.5.6 [26-11-2011 JN {Added /lines to trim
Changed foreach}]
0.5.5 [25-11-2011 JN {Added repeat
Added after
Added before
Added form
Added sort}]
0.5.4 [24-11-2011 JN {Added support for many datatypes in the rules for string parsing}]
0.5.3 [23-11-2011 JN {Made get-token inline in parse}]
0.5.2 [22-11-2011 JN {Added tag!
Added issue!}]
0.5.1 [21-11-2011 JN {Added percent!
Added foreach}]
0.5.0 [18-11-2011 JN {Added net-utils}]
0.4.10 [14-11-2011 JN {Fixed bug in parse}]
0.4.9 [11-11-2011 JN {Added result to until}]
0.4.8 [10-11-2011 JN {Made back native}]
0.4.7 [9-11-2011 JN {Added parse
Added max}]
0.4.6 [7-11-2011 JN {Added binary! to any-string!}]
0.4.5 [3-11-2011 JN {Changed for}]
0.4.4 [2-11-2011 JN {Added bitset}]
0.4.3 [31-10-2011 JN {Added url!
Added port!
Added any-object!}]
0.4.2 [27-10-2011 JN {Added default help to help}]
0.4.1 [25-10-2011 JN {Added integer!, char! and call-by-word to back
Added call-by-word to head and tail}]
0.4.0 [18-10-2011 JN {Added native
Added native-op
Added operator}]
0.3.8 [3-10-2011 JN {Added special attributes to help}]
0.3.7 [18-9-2011 JN {Added time! to number argument in negate}]
0.3.6 [15-9-2011 JN {Removed cos, sin and tan, as they're now natives
Added arccos, arcsin and arctan}]
0.3.5 [14-9-2011 JN {Added [throw] to some functions}]
0.3.4 [22-8-2011 JN {Fixed bug in switch}]
0.3.3 [18-7-2011 JN {Added on and off}]
0.3.2 [11-7-2011 JN {Added vocal test to help
Added switch}]
0.3.1 [4-6-2011 JN {Added log
Made comment native}]
0.3.0 [30-5-2011 JN {Added descriptions
Moved none, true and false to state.c}]
0.2.0 [24-5-2011 JN {Added help}]
0.1.3 [16-5-2011 JN {Added math and series functions}]
0.1.2 [14-4-2010 JN {Added mold to probe}]
0.1.1 [6-3-2010 JN {Removed zero}]
0.1.0 [3-3-2010 JN {Added func, does}]
0.0.7 [1-3-2010 JN {Added !}]
0.0.6 [25-2-2010 JN {Added probe}]
0.0.5 [22-2-2010 JN {Added negate}]
0.0.4 [19-2-2010 JN {Added sqrt}]
0.0.3 [18-2-2010 JN {Removed true?. Added comment}]
0.0.2 [17-2-2010 JN {Added none, not, zero, zero?, true?, exp}]
0.0.1 [16-2-2010 JN {Created Added false, true, e, pi}]
]
]
;\{ ; exclude all
comment: make function! [[
'"Ignore the argument value."
value '"A string, block, or any other value"
][
]]
if system/options/quiet = false [
prin '"Loading Cortex... "
]
license: make function! [[
'"Print the World/Cortex license agreement."
][
print system/license
]]
off: make logic! 0
on: make logic! 1
any-block!: make typeset! [block! paren! path! set-path! get-path! lit-path!]
any-context!: make typeset! [context! error! port!]
any-function!: make typeset! [operator! function! routine! task!]
;any-object!: make typeset! [context! error! port!]
any-paren!: make typeset! [paren!]
any-path!: make typeset! [path! set-path! get-path! lit-path!]
any-string!: make typeset! [string! binary! file! email! url! tag!]
any-type!: make typeset! [unset! none! logic! integer! real! complex! percent! char! pair! range! time! date! string! lit-string! binary! file! email! url! tag! issue! bitset! tuple! vector! image! block! list! paren! path! set-path! get-path! lit-path! map! datatype! typeset! word! set-word! get-word! lit-word! refinement! operator! function! routine! callback! context! error! task! task-id! port! handle! struct! library! node! comment! KWATZ!]
any-word!: make typeset! [word! set-word! get-word! lit-word! refinement!]
immediate!: make typeset! [unset! none! logic! integer! real! complex! percent! char! pair! range! time! date! lit-string! issue! tuple! datatype! typeset! word! set-word! get-word! lit-word! refinement! task-id!]
number!: make typeset! [integer! real! percent!]
scalar!: make typeset! [integer! real! complex! percent! char! pair! range! tuple! time!]
series!: make typeset! [string! binary! file! email! url! tag! block! list! paren! path! set-path! get-path! lit-path! KWATZ!]
system/schemes: make map! reduce [
'default make context! [
make-port: make function! [[
url [url!]
][
net-utils/URL-Parser/parse-url url
]]
read: make function! [[
'"Read from a url."
[retain]
url [url!]
/local scheme f
][
scheme: pick system/schemes net-utils/URL-Parser/get-scheme url
f: pick scheme 'read
f url
]]
]
'console make context! [
scheme: 'console
ref: [scheme: 'console]
]
'dir make context! [
scheme: 'dir
ref: none
]
'file make context! [
scheme: 'file
ref: none
size: 0
]
'tcp make context! [
title: '"Transmission Control Protocol"
scheme: 'tcp
ref: none
host: none
port-id: none
service: none
user: none
pass: none
target: none
path: none
]
]
system/ports/input: make port! [scheme: 'console]
insert system/schemes reduce [
'http retain make system/schemes/tcp [
title: '"HyperText Transport Protocol v1.1"
scheme: 'http
port-id: 80
service: "80"
read: make function! [[
'"Read from a HTTP url."
[retain]
source [port! url!]
/local port line length chunked?
][
port: either url! = type? source [
net-utils/URL-Parser/parse-url source
] source
if not port/port-id [
port/port-id: 80
port/service: "80"
]
open-port port
;print "!! port opened"
write port join {GET / HTTP/1.1^/User-Agent: World Programming Language^/Host: } [
port/host
{^/Accept: */*^/^/}
]
wait port
line: system/words/read/lines/part port 1
;print line/1
if line/1 = "HTTP/1.1 200 OK" [
length: 0
chunked?: false
while [
line: system/words/read/lines/part port 1
;print line/1
if find/match line/1 "Content-Length: " [
length: pick load skip line/1 16 1
]
if find/match line/1 "Transfer-Encoding: chunked" [
chunked?: true
]
line/1 <> ""
] []
either chunked? [
line: system/words/read/lines/part port 1
append line/1 #"h"
as string! system/words/read/part port pick load line/1 1
][
as string! system/words/read/part port length
;system/words/read/lines/part port 4
]
]
]]
]
]
e: 2.718281828459045
pi: 3.141592653589793
tau: 6.283185307179586 ; 2 * pi
null: #"^@"
esc: #"^["
bs: #"^H"
cr: #"^M"
lf: #"^/"
newline: #"^/"
newpage: #"^L"
tab: #"^-"
slash: #"/"
backslash: #"\"
crlf: "^M^/"
; Comparison
same?: make function! [[
'"True if the values are identical."
value1
value2
][
:value1 =? :value2
]]
equal?: make function! [[
'"True if the values are equal."
value1
value2
][
:value1 = :value2
]]
strict-equal?: make function! [[
'"True if the values are equal and of the same datatype."
value1
value2
][
:value1 == :value2
]]
not-equal?: make function! [[
'"True if the values are not equal."
value1
value2
][
:value1 <> :value2
]]
greater?: make function! [[
'"True if the first value is greater than the second."
value1
value2
][
:value1 > :value2
]]
lesser?: make function! [[
'"True if the first value is less than the second."
value1
value2
][
:value1 < :value2
]]
greater-or-equal?: make function! [[
'"True if the first value is greater than or equal the second."
value1
value2
][
:value1 >= :value2
]]
lesser-or-equal?: make function! [[
'"True if the first value is less than or equal the second."
value1
value2
][
:value1 <= :value2
]]
; Context
context: make function! [[
'"Define a unique, underived context."
[throw retain] ; TODO Thy is throw here?
block [block!] '"Context variables and values"
][
make context! block
]]
node: make function! [[
'"Define a node"
[throw retain] ; TODO Thy is throw here?
block [block!] '"Node variables and values"
][
make node! block
]]
; Control
actor: make function! [[
'"Define a task after the actor model."
[retain]
body [block!] '"The body block of the actor"
][
insert body [
wait 'message
]
make task! reduce [[] head' set-newline skip' reduce [
'while [true] body
] 2 false
]
]]
callback: make function! [[
'"Define a callback function with given spec and body."
[retain]
spec [block!] '"^"Description^" followed by arguments (opt type and string)"
body [block!] '"The body block of the callback function"
][
make callback! reduce [spec body]
]]
compose: make function! [[
'"Evaluate a block of expressions, only evaluate parens, and return a block."
[throw retain]
value [block!] '"Block to compose"
/deep '"Compose nested blocks"
/only '"Insert a block value as a block"
/local ptr v
][
ptr: copy/shallow value
either deep [
either only [
while [0 < length? ptr] [
v: pick ptr 1
either block! = type? :v [
compose/deep/only v
][
if paren! = type? :v [
insert/only remove ptr do v
]
]
next' ptr
]
][
while [0 < length? ptr] [
v: pick ptr 1
either block! = type? :v [
compose/deep v
][
if paren! = type? :v [
insert remove ptr do v
]
]
next' ptr
]
]
][
either only [
while [0 < length? ptr] [
v: pick ptr 1
if paren! = type? :v [
insert/only remove ptr do v
]
next' ptr
]
][
while [0 < length? ptr] [
v: pick ptr 1
if paren! = type? :v [
insert remove ptr do v
]
next' ptr
]
]
]
value
]]
does: make function! [[
'"Define a function that has no arguments."
[retain]
body [block!] '"The body block of the function"
][
make function! reduce [[] body]
;make function! back insert/only remove next [[]] body
]]
for: make function! [[
'"Evaluate a block over a range of values."
[throw retain]
'word [word!] '"Variable to hold current value"
start [number! char!] '"Starting value"
end [number! char!] '"Ending value"
bump [number! char!] '"Amount to skip each time"
body [block!] '"Block to evaluate each time"
/local do-body
][
;if end == #"^(FF)" [
;make error! join "FOR - invalid argument: " end
;]
do-body: make function! reduce [reduce [[throw retain] word] body]
start: start - bump
either bump < 0 [
while [end <= start: start + bump] [
do-body start
]
][
while [end >= start: start + bump] [
do-body start
]
]
]]
forall: make function! [[
'"Evaluate a block for every value in a series."
[throw retain]
'word [word!] '"Word set to each position in series"
body [block!] '"Block to evaluate each time"
/local l result
][
word: get/at word body
;l: - length? word
;while [any [0 < length? word (skip' word l false)]] [
l: -1 + index? word
while [any [0 < length? word (skip' head' word l false)]] [
result: do body
next' word
result
]
]]
foreach: make function! [[
'"Evaluate a block for each value(s) in a series."
[throw retain]
'word [word! block!] '"Word or block or words to set each time"
data [series! map!] '"Series to traverse"
body [block!] '"Block to evaluate each time"
/local c l body' data' result
][
if map! = type? data [data: to block! data]
if 0 < length? data [
c: copy [none]
either block! = type? word [
l: length? word
while [l > 0] [
insert c to set-word! word/:l
l: l - 1
]
c: make context! bind c body
body': bind copy body c
l: length? word
set/local/at word data c
result: do body'
data': copy/shallow data
while [0 < length? skip' data' l] [
set/local/at word data' c
result: do body'
]
set/local/at word none c
][
insert c to set-word! word
c: make context! bind c body
body': bind copy body c
set/local/at word data/1 c
result: do body'
data': copy/shallow data
while [0 < length? next' data'] [
set/local/at word data'/1 c
result: do body'
]
set/local/at word none c
]
]
result
]]
func: make function! [[
'"Define a function with given spec and body."
[retain]
spec [block!] '"^"Description^" followed by arguments (opt type and string)"
body [block!] '"The body block of the function"
][
make function! reduce [spec body]
]]
has: make function! [[
'"Define a function that has local variables but no arguments."
[retain]
locals [block!]
body [block!] '"The body block of the function"
][
;make function! reduce [insert insert clear [] locals /local body]
;make function! insert/only
;insert/only remove/part [] 2 body
;insert insert clear [] locals /local
;make function! reduce [insert copy locals /local body]
make function! insert/only
insert/only copy [] body
append copy [/local] locals
]]
loop: make function! [[
'"Evaluate a block a specified number of times."
[throw retain]
count [integer!] '"Number of repetitions"
block [block!] '"Block to evaluate each time"
][
;if false = compiled? block [
;compile/at block 'loop
;compile/at block block
;compile block
;]
while [0 <= count: count - 1] block
]]
native: make function! [[
'"Define a native function with given spec and native code."
[retain]
spec [block!] '"^"Description^" followed by arguments (opt type and string)"
nc [integer!] '"Native code specifying the native function"
][
make function! reduce [spec nc]
]]
native-op: make function! [[
'"Define a native operator with given spec and native code."
[retain]
spec [block!] '"^"Description^" followed by exactly two arguments (opt type and string)"
nc [integer!] '"Native code specifying the native operator"
][
make operator! reduce [spec nc]
]]
operator: make function! [[
'"Define an operator with given spec and body."
[retain]
spec [block!] '"^"Description^" followed by exactly two arguments (opt type and string)"
body [block!] '"The body block of the operator"
][
make operator! reduce [spec body]
]]
q: make function! reduce [pick :quit 1 pick :quit 2]
repeat: make function! [[
'"Evaluate a block a number of times."
[throw retain]
'word [word!] '"Word to set each time"
value [integer!] '"Maximum number"
body [block!] '"Block to evaluate each time"
/local spec do-body start
][
spec: [[throw retain]]
append spec word
do-body: make function! reduce [spec body]
remove/last spec
start: 0
while [value > start] [
start: start + 1
do-body start
]
]]
routine: make function! [[
'"Define a library routine"
[retain]
spec [block!] '"^"Description^" followed by library, routine name, arguments and return type"
][
make routine! spec
]]
struct: make function! [[
'"Define a structure."
[retain]
spec [block!] '"^"Description^" followed by datatypes and arguments (opt string)"
values [block! none! word!] '"Initial values"
][
make struct! reduce [spec values]
]]
switch: make function! [[
'"Select a choice and evaluate the block that follows it."
[throw retain]
value '"Value to search for"
cases [block!] '"Block of cases to search"
/default
case '"Default case if no others are found"
/local to-do
][
to-do: find cases either datatype! = type? :value [
to word! value
][
:value
]
either to-do [
while [all [find' next' to-do block! block! <> type? pick to-do 1]] []
either block! = type? pick to-do 1 [
do pick to-do 1
][
if default [do case]
]
][
if default [do case]
]
]]
task: make function! [[
'"Define a task with given spec and body."
[retain]
spec [block!] '"^"Description^""
body [block!] '"The body block of the task"
][
make task! reduce [spec body]
]]
until: make function! [[
'"Evaluate a block until it is true."
[throw retain]
block [block!]
/local result
][
while [not result: do block] []
result
]]
vector: make function! [[
'"Define a vector."
[retain]
spec [block!] '"Datatype and size (opt block of initial values)"
][
make vector! spec
]]
; Datatype
none?: make function! [['"True for none values." value][none! = type? :value]]
unset?: make function! [['"True for unset values." value][unset! = type? value]]
logic?: make function! [['"True for logic value." value][logic! = type? :value]]
integer?: make function! [['"True for integer values." value][integer! = type? :value]]
real?: make function! [['"True for real values." value][real! = type? :value]]
complex?: make function! [['"True for complex values." value][complex! = type? :value]]
percent?: make function! [['"True for percent values." value][percent! = type? :value]]
char?: make function! [['"True for char values." value][char! = type? :value]]
pair?: make function! [['"True for pair values." value][pair! = type? :value]]
range?: make function! [['"True for range values." value][range! = type? :value]]
time?: make function! [['"True for time values." value][time! = type? :value]]
date?: make function! [['"True for date values." value][date! = type? :value]]
string?: make function! [['"True for string values." value][string! = type? :value]]
lit-string?: make function! [['"True for lit-string values." value][lit-string! = type? :value]]
binary?: make function! [['"True for binary values." value][binary! = type? :value]]
file?: make function! [['"True for file values." value][file! = type? :value]]
email?: make function! [['"True for email values." value][email! = type? :value]]
url?: make function! [['"True for url values." value][url! = type? :value]]
tag?: make function! [['"True for tag values." value][tag! = type? :value]]
issue?: make function! [['"True for issue values." value][issue! = type? :value]]
bitset?: make function! [['"True for bitset values." value][bitset! = type? :value]]
tuple?: make function! [['"True for tuple values." value][tuple! = type? :value]]
vector?: make function! [['"True for vector values." value][vector! = type? :value]]
image?: make function! [['"True for image values." value][image! = type? :value]]
block?: make function! [['"True for block values." value][block! = type? :value]]
list?: make function! [['"True for list values." value][list! = type? :value]]
paren?: make function! [['"True for paren values." value][paren! = type? :value]]
path?: make function! [['"True for path values." value][path! = type? :value]]
set-path?: make function! [['"True for set-path values." value][set-path! = type? :value]]
get-path?: make function! [['"True for get-path values." value][get-path! = type? :value]]
lit-path?: make function! [['"True for lit-path values." value][lit-path! = type? :value]]
map?: make function! [['"True for map values." value][map! = type? :value]]
datatype?: make function! [['"True for datatype values." value][datatype! = type? :value]]
typeset?: make function! [['"True for typeset values." value][typeset! = type? :value]]
word?: make function! [['"True for word values." value][word! = type? :value]]
set-word?: make function! [['"True for set-word values." value][set-word! = type? :value]]
get-word?: make function! [['"True for get-word values." value][get-word! = type? :value]]
lit-word?: make function! [['"True for lit-word values." value][lit-word! = type? :value]]
refinement?: make function! [['"True for refinement values." value][refinement! = type? :value]]
operator?: make function! [['"True for operator values." value][operator! = type? :value]]
function?: make function! [['"True for function values." value][function! = type? :value]]
routine?: make function! [['"True for routine values." value][routine! = type? :value]]
callback?: make function! [['"True for callback values." value][callback! = type? :value]]
context?: make function! [['"True for context values." value][context! = type? :value]]
error?: make function! [['"True for error values." value][error! = type? :value]]
task?: make function! [['"True for task values." value][task! = type? :value]]
task-id?: make function! [['"True for task-id values." value][task-id! = type? :value]]
port?: make function! [['"True for port values." value][port! = type? :value]]
library?: make function! [['"True for library values." value][library! = type? :value]]
node?: make function! [['"True for node values." value][node! = type? :value]]
comment?: make function! [['"True for comment values." value][comment! = type? :value]]
KWATZ?: make function! [['"True for KWATZ values." value][KWATZ! = type? :value]]
any-block?: make function! [['"True for any-block values." value][find any-block! type? :value]]
any-context?: make function! [['"True for any-context values." value][find any-context! type? :value]]
any-function?: make function! [['"True for any-function values." value][find any-function! type? :value]]
;any-object?: make function! [['"True for any-object values." value][find any-object! type? :value]]
any-paren?: make function! [['"True for any-paren values." value][find any-paren! type? :value]]
any-path?: make function! [['"True for any-path values." value][find any-path! type? :value]]
any-string?: make function! [['"True for any-string values." value][find any-string! type? :value]]
any-type?: make function! [['"True for any-type values." value][find any-type! type? :value]]
any-word?: make function! [['"True for any-word values." value][find any-word! type? :value]]
immediate?: make function! [['"True for any-word values." value][find immediate! type? :value]]
number?: make function! [['"True for number values." value][find number! type? :value]]
scalar?: make function! [['"True for scalar values." value][find scalar! type? :value]]
series?: make function! [['"True for series values." value][find series! type? :value]]
as-pair: make function! [[
'"Combine x and y values into a pair."
x [integer! char!]
y [integer! char!]
][
add 1x0 * x 0x1 * y
]]
as-range: make function! [[
'"Combine x and y values into a range."
x [integer! char!]
y [integer! char!]
][
add 1-0 * x 0-1 * y
]]
; Help
probe: make function! [[
'"Print a molded value and return that same value."
;[retain]
value
][
print mold :value
:value
]]
dump-obj: make function! [[
'"Return a block of information about a context or port."
[retain]
obj [context! error! port!]
/match '"Include only those that match a string or datatype" pat
/local words-of clip-str str form-val val form-pad out wild type
][
words-of: make function! [[
[retain]
value
/local result w
][
result: to block! value
while [0 < length? result] [
w: as word! result/1
insert remove/part result 2 w
next' result
]
head result
]]
clip-str: make function! [[[retain] str] [
trim/lines str
if 43 < length? str [head' append clear skip' str 43 '"..."]
str
]]
form-val: make function! [[[retain] val] [
if any-block? :val [return form reduce ['"length:" mold length? val]]
;if image? :val [return form reduce ['"size:" val/size]]
;if datatype? :val [return get in spec-of val 'title]
if any-function? :val [
either string! = type? pick pick :val 1 1 [
return clip-str pick pick :val 1 1
][
either lit-string! = type? pick pick :val 1 1 [
return clip-str to string! pick pick :val 1 1
][
return clip-str mold pick :val 1
]
]
]
any [
if vector! = type? :val [val: reduce [pick val 'type pick val 'size]]
if find any-context! type? :val [val: words-of val]
;if typeset? :val [val: to-block val]
if port! = type? :val [val: reduce [val/scheme val/ref]]
;if gob? :val [return form reduce ['"offset:" val/offset "size:" val/size]]
]
clip-str mold :val
]]
form-pad: make function! [[[retain] val size] [
val: form val
append/dup val #" " size - length? val
val
]]
out: copy []
wild: all [string! = type? pat find pat "*"]
foreach [word val] to block! obj [
type: type?/word :val
if any [
not match
all [
unset! <> type? :val
either string! = type? :pat [
either wild [
"" = find/any/match to string! word pat
][
find to string! word pat
]
][
all [
datatype! = type? get :pat
type = :pat
]
]
]
][
str: form-pad word 15
append str #" "
append str form-pad type 12 - ((length? str) - 15)
append out form reduce ['" " str form-val :val newline]
]
]
out
]]
help: make function! [[
'"Print information about words and values."
'word
/local value args item arg-no item2 att types
][
if false = value? 'word [
print {To use help, supply a word or value as its
argument:
help copy
help system
help system/console
To view all words that match a pattern use a
string or partial word and optional * wildcard:
help "for"
help for*
help any-
To see words with values of a specific datatype:
help real!
help datatype!
Word completion:
Use <tab> at the command line for word completion.
Press <tab> twice to see choices.
Other useful functions:
source <function> - view source of a function
Other information:
license - show user license
More information: http://www.world-lang.org
}
exit
]
if all [word! = type? :word not value? :word] [word: mold :word]
if any [string! = type? :word all [word! = type? :word datatype! = type? get :word]] [
types: dump-obj/match system/words :word
sort types
if 0 < length? types [
print ['"Found these words:" newline types]
exit
]
if all [word! = type? :word datatype! = type? get :word] [
print [mold :word '"is a datatype!"]
exit
]
print ['"No information on" word '"(word has no value)"]
exit
]
if all [word! <> type? :word path! <> type? :word] [
prin [mold :word '"is "]
print either find "aeiou" pick mold type? :word 1 [
['"an" type? :word]
][
['"a" type? :word]