-
Notifications
You must be signed in to change notification settings - Fork 31
/
utilities.lisp
2409 lines (2286 loc) · 157 KB
/
utilities.lisp
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
;;; -*- Mode:Lisp; Syntax:ANSI-Common-Lisp; Coding:utf-8; Package:April -*-
;;;; utilities.lisp
(in-package #:april)
"Utility functions for April. It's important to understand the difference between the functions and macros provided here and the ones that come from the aplesque package. The faculties provided by aplesque reflect features of APL, but they have uses other than implementing APL. The material here is specifically for use in implementing APL, with utility aside from an APL implementation not accounted for in its design. The functions here are used to implement language mechanics as opposed to functions in the language's standard library; the latter are implemented in functions.lisp."
(defvar *april-idiom* nil)
(define-symbol-macro this-idiom *april-idiom*)
(define-symbol-macro *apl-timestamp* (apl-timestamp))
(define-symbol-macro *first-axis* (if (not axes) 0 (apply-scalar #'- (first axes) index-origin)))
(define-symbol-macro *last-axis* (if axes (- (first axes) index-origin)
(max 0 (1- (rank-of omega)))))
(define-symbol-macro *first-axis-or-nil* (if axes (apply-scalar #'- (first axes) index-origin)))
(define-symbol-macro *branches* (symbol-value (find-symbol "*BRANCHES*" space)))
(defvar *function-identities* nil)
(defvar *value-composable-lexical-operators* nil)
;; the names of library functions that curry functions having axes with index-origin, needed for the λχ macro
(defparameter *io-currying-function-symbols-monadic* '(ravel-arrays))
(defparameter *io-currying-function-symbols-dyadic* '(catenate-arrays catenate-on-first section-array))
(defparameter *package-name-string* (package-name *package*))
(defvar *demo-packages*
(append '(april-demo.ncurses)
#.(if (or (not (string= "Armed Bear Common Lisp" (lisp-implementation-type)))
(with-open-stream (cmd-out (make-string-output-stream))
(uiop:run-program "mvn -v" :output cmd-out :ignore-error-status t)
(< 0 (length (get-output-stream-string cmd-out)))))
''(april-demo.cnn) nil)))
#+lispworks (lw:set-default-character-element-type 'cl:character)
(defvar *library-packages*
'(april-lib.dfns.array april-lib.dfns.string april-lib.dfns.power
;; tree library is disabled for ABCL, Lispworks because its large functions cannot be
;; compiled using the JVM, while the functions cause LispWorks to freeze
#+(not (or abcl lispworks)) april-lib.dfns.tree
april-lib.dfns.graph april-lib.dfns.numeric))
(defvar ∇ nil)
(defvar ∇∇ nil)
;; set ∇ and ∇∇ to nil; this prevents errors when they are seen in operator compositions
(defvar *digit-vector* "0123456789")
(defvar *alphabet-vector* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
(defvar *idiom-native-symbols* '(⍺ ⍵ ⍶ ⍹ ⍺⍺ ⍵⍵ ∇ ∇∇ index-origin print-precision *digit-vector*
*alphabet-vector* *apl-timestamp* to-output output-stream))
(defvar *system-variables* '(:index-origin *index-origin* :print-precision *print-precision*
:comparison-tolerance *comparison-tolerance* :division-method *division-method*
:rngs *rngs*))
(defvar *rng-names* #(:linear-congruence :mersenne-twister-64 :system))
(defmacro aprgn (&rest content)
"This macro aliases (progn) - it is a solution for macros like (iterate) that chew up (progns) found in April's generated code."
`(let () ,@content))
(defun system-command-exists (command-string &optional prefix)
"Check for the existence of a shell command under the host operating system."
(unless prefix (setq prefix ""))
(zerop (multiple-value-bind (1st 2nd error-code)
(uiop:run-program (format nil "~acommand -v ~a" prefix command-string)
:ignore-error-status t)
(declare (ignore 1st 2nd))
error-code)))
(defun count-cpus ()
"Count the available threads in the system, accounting for different operating systems."
(with-open-stream (cmd-out (make-string-output-stream))
(uiop:run-program
(case (uiop:operating-system)
((:linux :linux-target)
(if (system-command-exists "nproc") "nproc" ""))
((:bsd :freebsd :openbsd :netbsd)
(if (system-command-exists "sysctl") "sysctl -n hw.ncpu" ""))
((:macosx :darwin)
(if (system-command-exists "sysctl") "sysctl -n hw.logicalcpu" ""))
((:windows)
"echo %NUMBER_OF_PROCESSORS%"))
:output cmd-out)
(let ((output (get-output-stream-string cmd-out)))
(if (zerop (length output))
1 (read-from-string output)))))
;; (defun make-threading-kernel-if-absent ()
;; "Create a kernel for multithreaded executuion via lparallel if none is present."
;; (unless lparallel:*kernel*
;; (setq lparallel:*kernel* (setq *april-parallel-kernel*
;; (lparallel:make-kernel (count-cpus) :name "april-language-kernel")))))
(defmacro sub-lex (item) item)
(defmacro sub-aliasing (form)
(if (not (or (symbolp form)
(and (listp form)
(eql (first form) 'function))))
form (let ((args (gensym)) (this-meta (gensym)))
`(if (not (functionp ,form))
,form (lambda (&rest ,args)
(let ((,this-meta (apply ,form (cons :get-metadata
(when (second ,args) (list nil))))))
;; pass the environment variables if this is a user-defined function;
;; remember not to add the nil argument if an internal
;; variable state is being set
(apply ,form (append ,args (when (and (not (second ,args)))
(list nil))
(unless (getf ,this-meta :lexical-reference)
(list (list :fn-params
:index-origin index-origin)))))))))))
(let ((this-package (package-name *package*)))
(defmacro in-april-workspace (name &body body)
"Macro that interns symbols in the current workspace; works in tandem with ⊏ reader macro."
(let* ((space-name (concatenate 'string "APRIL-WORKSPACE-" (string-upcase name)))
(lex-space-name (concatenate 'string space-name "-LEX"))
;; build list of values assigned in the (april) call; these are stored as dynamic vars
(top-level-instrs (mapcar (lambda (item) (string (cadar item))) (cdadar body)))
(symacro-lex) (symacro-syms))
(labels ((replace-symbols (form &optional inside-function)
(loop :for item :in form :for ix :from 0
:collect (cond ((listp item)
;; assign sublexicon based on symbol macros for invocation
(when (and (not symacro-lex) (symbolp (first item))
(eql 'symbol-macrolet (first item)))
(setf symacro-lex (second item)
symacro-syms (loop :for i :below (length (second item))
:collect (gensym))))
(when (and (symbolp (first item))
(eql 'sub-lex (first item)))
;; replace sub-lex forms with sub-lexicon instance
(setf item `(let ,(loop :for l :in symacro-lex
:for s :in symacro-syms
:collect (list s (first l)))
(declare (ignorable ,@symacro-syms))
(symbol-macrolet
,(loop :for l :in symacro-lex
:for s :in symacro-syms
:collect (list (first l) s))
(sub-aliasing ,(second item))))))
(if (and (second item) (not (third item))
(symbolp (second item)) (position (first item) #(inws inwsd)
:test #'eql))
(let ((istring (string (second item))))
(intern (string (second item))
(if (and inside-function
(not (eql 'inwsd (first item)))
(not (char= #\* (aref istring 0)))
(loop :for str :in top-level-instrs
:never (string= str istring)))
lex-space-name space-name)))
;; don't lex-intern functions like #'⊏|fn|
(replace-symbols item (and (not (eql 'function (first item)))
(or inside-function
(position (first item)
#(alambda olambda)
:test #'eql))))))
((and (symbolp item) (string= "+WORKSPACE-NAME+" (string-upcase item)))
(list 'quote (find-symbol (string-upcase name) this-package)))
(t item)))))
(replace-symbols (first body))))))
;; this reader macro expands to (inws symbol) for reader-friendly printing of compiled code
(set-macro-character #\⊏ (lambda (stream character)
(declare (ignore character))
(list 'inws (read stream t nil t))))
;; this reader macro expands to (inwsd symbol) for reader-friendly printing of compiled code
(set-macro-character #\⊑ (lambda (stream character)
(declare (ignore character))
(list 'inwsd (read stream t nil t))))
;; printer extension to use the ⊏ reader macro
(set-pprint-dispatch '(cons (member inws))
#'(lambda (s list)
(if (and (symbolp (second list)) (not (third list)))
(funcall (formatter "⊏~W") s (second list))
(pprint-fill s list))))
;; printer extension to use the ⊑ reader macro
(set-pprint-dispatch '(cons (member inwsd))
#'(lambda (s list)
(if (and (symbolp (second list)) (not (third list)))
(funcall (formatter "⊑~W") s (second list))
(pprint-fill s list))))
(defun load-libs ()
"Load the April library packages."
(dolist (package-symbol *library-packages*) (asdf:load-system package-symbol)))
;; creating (let) bindings in the macro below causes problems, so these dynamic vars are used
(defvar *lib-tests-run*)
(defvar *lib-tests-failed*)
(defmacro run-lib-tests ()
"Run the tests for each April library package."
`(progn (setf *lib-tests-run* (setf *lib-tests-failed* 0))
,@(loop :for package-symbol :in *library-packages*
:append (if (asdf:registered-system package-symbol)
(let ((run-function-symbol
(find-symbol "RUN-TESTS"
(string-upcase package-symbol))))
(when (fboundp run-function-symbol)
`((,run-function-symbol)
(incf *lib-tests-run*
(getf prove.suite::*last-suite-report* :plan))
(incf *lib-tests-failed*
(* 1/2 (getf prove.suite::*last-suite-report* :failed))))))
(format t "~% Warning: library system ｢~a｣ not loaded. Did you evaluate (load-libs) before trying to run the library tests?~%"
package-symbol)))
(incf *lib-tests-failed* (getf prove.suite::*last-suite-report* :failed))
(format nil "Ran ~a tests, ~a failed." *lib-tests-run* *lib-tests-failed*)))
(defun add-aprepl-load-to-emacs-init-file (&optional unique-init-path)
"Add a line loading the ApREPL utility to the Emacs init file so ApREPL will be ready for use when Emacs is loaded."
(let ((init-path (or unique-init-path (probe-file "~/.emacs.el")
(probe-file "~/.emacs") (probe-file "~/.emacs.d/init.el")
"~/.emacs"))
(el-path (asdf:system-relative-pathname :april "aprepl/aprepl.el")))
(with-open-file (init-file init-path :direction :output :if-exists :append
:if-does-not-exist :create)
(format init-file "~%(when (file-exists-p \"~a\")" el-path)
(format init-file "~% (load \"~a\"))~%" el-path)
(format nil "Added ApREPL load instruction to Emacs init file at ~a." init-path))))
(defun disclose-atom (item)
"If the argument is a non-nested array with only one member, disclose it, otherwise do nothing."
(if (not (and (not (stringp item)) (arrayp item) (is-unitary item)
(not (arrayp (row-major-aref item 0)))))
item (row-major-aref item 0)))
(defmacro insym (symbol)
"Macro used in grammar.lisp to intern value-referencing symbols in appropriate workspace package."
`(if (or (not (symbolp ,symbol))
(member ,symbol *idiom-native-symbols*))
,symbol (intern (string ,symbol) space)))
(defun check-value (item)
;; TODO: performing this check is time-consuming; is there another way to accomplish this?
(if (not (functionp item))
item (error "Functions cannot return functions, they must return values.")))
(defmacro alambda (params options &body body)
"Generate a lambda with a self-reference for use with APL's ∇ character for self-reference in a defn."
(let* ((options (rest options))
(meta (rest (assoc :meta options)))
(space (second (assoc :space options)))
(env (gensym)) (blank (gensym)) (vals-list))
`(symbol-macrolet ((%in-function-p% t))
(labels ((∇self ,(append params (append (unless (member '&optional params)
(list '&optional))
(list env blank)))
(declare (ignorable ,@(loop :for var :in params :when (not (eql '&optional var))
:collect var)
,env ,blank))
(if (eq :get-metadata ,(first params))
,(cons 'list meta)
(let ,(when space
(loop :for (key val) :on *system-variables* :by #'cddr
:collect (list (first (push (find-symbol (string val) space)
vals-list))
`(or (getf (rest ,env) ,(intern (string key) "KEYWORD"))
,(find-symbol (string val) space)))))
(declare (ignorable ,@vals-list))
(when (getf (rest ,env) :test-param)
(print (list :env ,env)))
,@(append (butlast body)
(list (cons 'check-value (last body))))))))
#'∇self))))
(defmacro olambda (params &body body)
"Generate a lambda with a self-reference for use with APL's ∇∇ symbol for self-reference in a defined operator."
`(symbol-macrolet ((%in-function-p% t))
(labels ((∇oself ,params ,@body))
#'∇oself)))
(defmacro fn-meta (function &rest meta)
"Wrap a function in another function so that it may carry metadata."
(let ((args (gensym)))
`(lambda (&rest ,args)
(if (eq :get-metadata (first ,args))
,(cons 'list meta)
(apply ,(if (not (symbolp function))
function `(function ,function))
,args)))))
(defmacro ws-assign-val (symbol value)
"Assignment macro for use with (:store-val) directive."
`(progn (unless (boundp ',symbol)
(proclaim '(special ,symbol)))
(setf (symbol-value ',symbol) ,value)))
(defmacro ws-assign-fun (symbol value)
"Assignment macro for use with (:store-fun) directive."
(let ((params (gensym)) (call-params (gensym)) (this-fn (gensym)))
`(let ((,this-fn ,value))
(unless (boundp ',symbol)
(proclaim '(special ,symbol)))
(setf (symbol-function ',symbol)
(lambda (&rest ,params)
(let ((,call-params (if (not (third ,params))
,params (butlast ,params))))
;; remove third params item (for example, (:FN-PARAMS :INDEX-ORIGIN 1))
;; from params so that the imported function can be called correctly
(if (eq :get-metadata (first ,call-params))
(list :meta-stuff nil)
;; input to user-imported functions is rendered
;; but deferrable by default - TODO: should there be other options?
(apply ,this-fn (mapcar (lambda (item)
(vrender item :may-be-deferred t))
;; the below logic is needed to handle metadata and
;; nil arguments when passed to imported functions
;; taking only one argument
(if (second ,params)
(list (first ,params) (second ,params))
(list (first ,params))))))))))))
(defmacro inv-fn (function &optional is-dyadic inverse-type)
"Wrap a function to be inverted; returns an error if the function has no inverse form."
(let ((metadata (gensym)) (inverse (gensym)))
`(let* ((,metadata (funcall ,function :get-metadata ,@(if is-dyadic (list nil))))
(,inverse (when (listp ,metadata) (getf ,metadata ,(or inverse-type :inverse)))))
(or ,inverse (error "Cannot invert function ~a." (quote ,function))))))
(defmacro achoose (item indices &rest rest-params)
"Wrapper for the choose function."
(let ((indices-evaluated (gensym)))
`(let ((,indices-evaluated ,indices))
(choose ,item ,indices-evaluated ,@rest-params))))
(defmacro make-virtual (type &rest params)
"Wrapper for the choose function."
(let* ((indices (getf params :argument))
(indices-evaluated (gensym))
(params-with-placeholder))
(loop :for (key value) :on params :by #'cddr
:do (setf (getf params-with-placeholder key)
(if (eq :argument key) indices-evaluated value)))
`(let ((,indices-evaluated ,indices))
(make-instance ,type ,@params-with-placeholder))))
(defun dummy-nargument-function (first &rest rest)
"Placeholder function to be assigned to newly initialized function symbols."
(declare (ignorable rest))
first)
(defun dummy-operator (first &rest rest)
"Placeholder function to be assigned to newly initialized operator symbols."
(declare (ignorable rest))
first)
;; these macros are shorthand for lambda definitions used in the spec; they make April's compiled code
;; more compact and comfortable to read
(defmacro λω (&rest body)
`(lambda (omega) ,@body))
(defmacro λωα (&rest body)
`(lambda (omega alpha) ,@body))
(defmacro λωαχ (&rest body)
`(lambda (omega alpha &optional axes) ,@body))
(defmacro λωχ (&rest body)
`(lambda (omega &optional axes) ,@body))
(defmacro λχ (body axes)
"Curry a function with axes for use with an operator."
(let ((function-type (if (eql 'fn-meta (first body))
(caadr body) (first body))))
(if (member function-type (cons 'λωαχ *io-currying-function-symbols-dyadic*))
`(λωα (funcall ,body omega alpha ,(cons 'list axes)))
(if (member function-type (cons 'λωχ *io-currying-function-symbols-monadic*))
`(λω (funcall ,body omega ,(cons 'list axes)))
body))))
(defun of-meta-hierarchy (meta-form key &optional symbol)
"Fetch a combined list of symbols of a given type at each level of a closure metadata hierarchy. Used to query data collected as part of lexer postprocessing."
(if symbol (or (and (getf meta-form key) (member symbol (getf meta-form key) :test #'eql))
(and (getf meta-form :parent) (of-meta-hierarchy (rest (getf meta-form :parent)) key symbol)))
(when (getf meta-form key)
(append (getf meta-form key)
(of-meta-hierarchy (rest (getf meta-form :parent)) key)))))
(defun reg-side-effect (item meta-form)
"Add a reference to a side effect to a closure metadata object."
(when meta-form (push item (getf (rest meta-form) :side-effects))))
(defun reg-symfn-call (function space meta-form)
"Add a reference to a call to a symbolic function to a closure metadata object."
(when (and meta-form function (listp function))
(if (eql 'sub-lex (first function))
(reg-symfn-call (second function) space meta-form)
;; if this function is represented by a symbol from the top-level scope, push its symbol to the list
;; of symbolic functions called in the immediate scope
(let ((h-sym (of-meta-hierarchy (rest meta-form) :fn-syms (second function))))
(if (and (not h-sym) (position (first function) #(inws inwsd) :test #'eql))
(push (intern (string (second function)) space)
(getf (rest meta-form) :symfns-called))
(if (of-meta-hierarchy (rest meta-form) :side-effecting-functions (first h-sym))
;; if this function is listed as a side-effecting function in the local scope
;; (as for evaluations like {acm←⍬ ⋄ upd←{acm,←⍵} ⋄ {_←{upd ⍵}¨⍵⋄⌽¯1↓⍵}⍣⍵⊢⍳⍵ ⋄ acm} 5)
;; push it to the list of side-effecting functions called in the immediate scope
(when (symbolp (second function))
(push (intern (string (second function)) space)
(getf (rest meta-form) :sefns-called)))
(if (eql 'alambda (first function))
(let ((fn-meta (rest (second (third function)))))
(dolist (sf (second (getf fn-meta :symfns-called)))
(push sf (getf (rest meta-form) :symfns-called)))
(dolist (se (second (getf fn-meta :side-effects)))
(reg-side-effect se meta-form)))
(when (eql 'a-comp (first function))
(reg-symfn-call (fourth function) space meta-form)
(reg-symfn-call (fifth function) space meta-form)))))))))
(defun side-effect-free (function)
"Use a function's metadata to check whether it has side effects. Needed for multithreaded operators - the functions composed with operators must be free of side effects for multithreading."
(let ((fn-meta (handler-case (funcall function :get-metadata)
(error () nil))))
(and fn-meta (or (member :side-effects fn-meta)
(member :lexical-reference fn-meta))
(not (getf fn-meta :side-effects))
(not (getf fn-meta :side-refs))
(or (not (getf fn-meta :symfns-called))
(loop :for fn :in (getf fn-meta :symfns-called)
:always (or (not (fboundp fn))
(side-effect-free (symbol-function fn))))))))
(defmacro is-workspace-value (item)
"Checks if a variable is present in the current workspace as a value."
`(and (find-symbol (string ,item) space)
(boundp (find-symbol (string ,item) space))
(not (fboundp (find-symbol (string ,item) space)))))
(defmacro is-workspace-function (item)
"Checks if a variable is present in the current workspace as a function."
`(and (find-symbol (string ,item) space)
(fboundp (find-symbol (string ,item) space))
(or (not (find-symbol (string ,item) space))
(not (boundp (find-symbol (string ,item) space)))
(not (listp (symbol-value (find-symbol (string ,item) space))))
(not (getf (rest (symbol-value (find-symbol (string ,item) space))) :valence)))))
(defmacro is-workspace-operator (item)
"Checks if a variable is present in the current workspace as an operator."
`(and (find-symbol (string ,item) space)
(fboundp (find-symbol (string ,item) space))
(boundp (find-symbol (string ,item) space))
(listp (symbol-value (find-symbol (string ,item) space)))
(getf (rest (symbol-value (find-symbol (string ,item) space))) :valence)))
(defun get-array-meta (array &rest keys)
"Gets one or more metadata of an array using the displacement reference technique."
(let ((metadata-holder (array-displacement array)))
(when metadata-holder
(apply #'values (loop :for key :in keys :collect (getf (aref metadata-holder 0) key))))))
(defun set-array-meta (array &rest data)
"Sets one or more metadata of an array using the displacement reference technique."
(let ((metadata-holder (array-displacement array)))
(when metadata-holder (loop :for (key value) :on data :by #'cddr
:do (setf (getf (aref metadata-holder 0) key) value))
data)))
(defun array-setting-meta (array &rest data)
"Sets one or more metadata of an array using the displacement reference technique, returning the displaced array."
(let ((metadata-holder (array-displacement array)))
(if metadata-holder (progn (loop :for (key value) :on data :by #'cddr
:do (setf (getf (aref metadata-holder 0) key) value))
array)
(let ((output)
(meta-array (make-array (1+ (size array)) :element-type t)))
(setf (aref meta-array 0) data
output (make-array (dims array) :displaced-to meta-array
:displaced-index-offset 1 :element-type t))
output))))
(defun follow-path (space path &optional item)
"Follow a path through a namespace and fetch the function or value there."
(if (not path)
item (if item (follow-path space (rest path)
(getf item (intern (string (first path)) "KEYWORD")))
(when (and (find-symbol (string (first path)) space)
(boundp (find-symbol (string (first path)) space)))
(follow-path space (rest path)
(symbol-value (find-symbol (string (first path)) space)))))))
(defun is-alphanumeric (character)
"Consistently check whether a character is alphanumeric - needed since different CL implementations consider different sets of characters to be alphanumeric as per (alphanumericp)."
;; to get an idea of the variance between alphanumeric sets in different CLs, try evaluating:
;; (loop :for c :below (expt 2 16) :when (and (code-char c) (alphanumericp (code-char c))) :count c)
;; this will show you the difference just in the UCS-2 set (characters in the 16-bit Unicode range)
(position (nth-value 1 (cl-unicode:general-category character))
#(cl-unicode-names::lu cl-unicode-names::ll cl-unicode-names::lt cl-unicode-names::lm
cl-unicode-names::lo cl-unicode-names::nd cl-unicode-names::nl cl-unicode-names::no)
:test #'eql))
(defun build-populator (array)
"Generate a function that will populate array elements with an empty array prototype."
(when (zerop (size array))
(let ((found (get-array-meta array :empty-array-prototype)))
(when found (lambda () (copy-nested-array found))))))
(defun make-prototype-of (array)
"Make a prototype version of an array; all values in the array will be blank spaces for character arrays or zeroes for other types of arrays."
(if (not (eq t (element-type array)))
(make-array (dims array) :element-type (element-type array)
:initial-element (if (position (element-type array)
#(base-char character)
:test #'eql)
#\ 0))
(let ((output (make-array (dims array))))
(dotimes (i (size output)) (setf (row-major-aref output i)
(if (not (arrayp (row-major-aref array i)))
0 (make-prototype-of (row-major-aref array i)))))
output)))
(defmacro print-and-run (form)
"Print a formatted code string and then run the code; used in april's arbitrary evaluation tests."
`(let ((*print-case* :downcase))
(princ (indent-code (write-to-string (quote ,form))))
,form))
(defun indent-code (string)
"Indent a code string produced by (print-and-run) as appropriate for April's test output."
(concatenate 'string " * " (regex-replace-all "[\\n]" string (format nil "~% "))))
(defun process-path (item key-list &optional processor value)
"Generate appropriate code to fetch or change elements nested within (arrays of) namespaces."
(if (not key-list)
(funcall (or processor (lambda (a b) (declare (ignore b)) a))
item value)
(if (symbolp (first key-list))
(if (and (listp item) (eql 'achoose (first item)))
(let ((arg (gensym)) (key-sym (intern (string (first key-list)) "KEYWORD")))
;; if multiple namespaces have been fetched from an array, the function to fetch the
;; rest of the path must be applied over the output array with (apply-scalar)
`(apply-scalar (lambda (,arg) ,(process-path `(getf ,arg ,key-sym)
(rest key-list) processor value))
,item))
(process-path `(getf ,item ,(intern (string (first key-list)) "KEYWORD"))
(rest key-list) processor value))
(let ((this-item (gensym)) (other (gensym)))
(if processor ;; if there's a processor, this path is being used for assignment
(enclose-axes item (first key-list)
:set value
:set-by `(lambda (,this-item ,other)
,(process-path this-item (rest key-list) processor other)
,this-item))
(process-path (enclose-axes item (first key-list))
(rest key-list) processor value))))))
(defmacro nspath (list &rest keys)
"Macro to expedite the fetching of values from nested namespaces."
`(at-path ,(if (not (and (listp list) (eql 'fn-ref (first list))))
list (second list))
,(cons 'list (loop :for k :in keys
:collect (if (symbolp k) (intern (string k) "KEYWORD")
`(mapcar (lambda (array)
(when array
(apply-scalar #'- array index-origin)))
,(if (eql 'list (first k))
k (cons 'list (first k)))))))))
(defun format-nspath (items &optional output)
"Create a string representation of a namespace path from the symbol list implementing that path."
(if (not items)
output (let ((this-item (if (and (listp (first items))
(position (caar items) #(inws inwsd) :test #'eql))
(cadar items) (when (symbolp (first items))
(first items)))))
(when this-item
(format-nspath (rest items) (if output (format nil "~a.~a" output this-item)
(string this-item)))))))
(defun at-path (object path &key (value) (value-nil) (set-by))
"Get or set values within a namespace (structured as a ptree), handling arrays within the namespace according to array indices within the namespace path or eliding arrays in the absence of specific coordinates."
(let ((value (vrender value :may-be-deferred t)))
(if (and (not value) (not value-nil) (arrayp object) (symbolp (first path)))
(apply-scalar (lambda (item) (at-path item path))
object)
(if (= 1 (length path)) ;; path is one element long, as for a
(if (symbolp (first path))
(if (or value value-nil) ;; path is assigned a value, as for a←X
(progn (if (and object (symbolp object))
(if set-by (setf (getf (symbol-value object) (first path))
(funcall set-by value
(getf (symbol-value object) (first path))))
(setf (getf (symbol-value object) (first path)) value))
(if (arrayp object) ;; handle elided assignment of array elements
(progn (dotimes (i (size object))
(setf (getf (row-major-aref object i) (first path))
(if set-by (funcall set-by value
(getf (row-major-aref object i)
(first path)))
value)))
object)
(setf (getf object (first path))
(if set-by (funcall set-by value (getf object (first path)))
value))))
object)
;; path is just referenced, not assigned, as for a
(if (arrayp object) ;; handle elision of arrays
(let ((output (make-array (dims object))))
(dotimes (i (size output))
(let ((original (row-major-aref object i)))
(setf (row-major-aref output i)
(getf (row-major-aref original i) (first path)))))
output)
(getf (if (not (symbolp object)) object (symbol-value object))
(first path))))
(nth-value 1 (achoose object (first path) ;; path is a set of coordinates, as for [1]
:set value :set-nil value-nil :modify-input t
:set-by (or set-by (lambda (a b) (declare (ignore a)) b)))))
(let ((object (if (not (symbolp object))
object (symbol-value object))))
(if (or value value-nil)
(if (= 2 (length path)) ;; path is 2 long and assigned a value
(if (symbolp (first path))
(if (symbolp (second path)) ;; elements 1 and 2 are symbols, as for a.b←X
(if (arrayp object)
(progn (dotimes (i (size object)) ;; handle elision
(setf (getf (row-major-aref object i) (first path))
(at-path (getf (row-major-aref object i) (first path))
(rest path) :value value :value-nil value-nil
:set-by set-by)))
object)
(let ((this-object (getf object (first path))))
(if (arrayp this-object) ;; handle elision
(progn (at-path this-object (rest path)
:value value :value-nil value-nil
:set-by set-by)
this-object)
(setf (getf this-object (second path)) value
(getf object (first path)) this-object))))
(if (arrayp object) ;; second element is coords, as for a[1]←x
(let ((this-object object))
(dotimes (i (size this-object))
(setf (row-major-aref this-object i)
(at-path (row-major-aref this-object i)
path :value value :value-nil value-nil
:set-by set-by)))
this-object)
(let ((this-object (at-path (getf object (first path))
(rest path)
:value value :value-nil value-nil
:set-by set-by)))
(setf (getf object (first path)) this-object)
object)))
;; first element is coords and second element may be symbol or coords,
;; as for [1].b←X or [1][2]←X
(nth-value 1 (achoose object (first path)
:set value :set-nil value-nil :modify-input t
:set-by (lambda (a b)
(at-path a (rest path) :value b
:set-by set-by)))))
;; path is more than two elements long and assigned a value
(if (not (symbolp (first path)))
;; first elem is array coordinates, as for [1]...←X
(progn (achoose object (first path)
:set value :set-nil value-nil :modify-input t
:set-by (when (rest path)
(lambda (a b)
(at-path a (rest path)
:value b :value-nil value-nil
:set-by set-by))))
object)
;; first elem is a symbol, as for a...←X
(if (arrayp object)
(progn (dotimes (i (size object)) ;; handle elision
(setf (getf (row-major-aref object i) (first path))
(at-path (getf (row-major-aref object i) (first path))
(rest path) :value value :value-nil value-nil
:set-by set-by)))
object)
(if (not (symbolp (second path)))
(setf (getf object (first path))
(at-path (getf object (first path)) (rest path)
:value value :value-nil value-nil :set-by set-by))
(at-path (getf object (first path)) (rest path)
:value value :value-nil value-nil :set-by set-by)))))
;; path is over 1 element long and not assigned a value,
;; like a.b, a.b.c, a[1].c, etc...
(if (symbolp (first path)) ;; first element is a symbol as for a...
(if (arrayp object) (dotimes (i (size object)) ;; handle elision
(at-path (getf (row-major-aref object i) (first path))
(rest path)))
(at-path (getf object (first path)) (rest path)))
;; first element is coordinates like [1]...
(at-path (achoose object (first path))
(rest path)))))))))
(defmacro a-set (symbol value &key (by) (axes))
"This is macro is used to build variable assignment forms and includes logic for strand assignment."
(labels ((follow-path (item path)
(if (not path)
item (follow-path `(getf ,item ,(intern (string (first path)) "KEYWORD"))
(rest path)))))
(if (not (listp symbol))
(let* ((is-symbol-value (or (symbolp value)
(and (listp value)
(or (position (first value) #(inws inwsd) :test #'eql)
;; remember to duplicate an assigned symbol as well
(and (eql 'a-set (first value))
(or (symbolp (second value))
(and (listp (second value))
(position (second value) #(inws inwsd)
:test #'eql))))))))
(ns-sym (find-symbol "*NS-POINT*" (package-name (symbol-package symbol))))
(namespace (if (boundp ns-sym) (symbol-value ns-sym)))
(set-to (if (not is-symbol-value) value `(duplicate ,value))))
;; handle assignment of ⍺ or ⍵; ⍺-assignment sets its default value if no right argument is
;; present; ⍵-assignment is an error. This is handled below for strand assignments.
(cond (axes (enclose-axes symbol axes :set value :set-by by))
((eql '⍺ symbol) `(or (and (or (not (listp ⍺))
(not (eql :fn-params (first ⍺))))
⍺)
(setf ⍺ ,set-to)))
((eql '⍵ symbol) `(error "The [⍵ right argument] cannot have a default assignment."))
((string= "*RNGS*" (string symbol))
(let ((valsym (gensym)) (seed (gensym))
(rngindex (gensym)) (rngname (gensym)))
`(let ((,valsym (vrender ,value)))
(if (or (integerp ,valsym)
(and (vectorp ,valsym) (= 1 (length ,valsym))))
(let ((,seed (disclose-atom ,valsym)))
(if (not (or (integerp ,seed)
(and (vectorp ,seed) (zerop (length ,seed)))))
(error "Random seeds set by ⎕RL←X must be integers or empty vectors.")
(let ((,rngname (getf (rest ,symbol) :rng)))
(setf (getf (rest ,symbol) ,rngname)
(if (eq :system ,rngname)
:system
(if (and (vectorp ,seed) (zerop (length ,seed)))
(random-state:make-generator ,rngname)
(random-state:make-generator ,rngname ,seed)))
(getf (rest ,symbol) :seed)
(unless (and (vectorp ,seed) (zerop (length ,seed)))
,seed)))))
(if (and (vectorp ,valsym) (= 2 (length ,valsym)))
(let* ((,seed (aref ,valsym 0)) (,rngindex (aref ,valsym 1))
(,rngname (aref *rng-names* ,rngindex)))
(if (not (or (integerp ,seed)
(and (vectorp ,seed) (zerop (length ,seed)))))
(error "Random seeds set by ⎕RL←X must be ~a"
"integers or empty vectors.")
(setf (getf (rest ,symbol) :rng)
,rngname
(getf (rest ,symbol) ,rngname)
(if (eq :system ,rngname)
:system
(if (and (vectorp ,seed) (zerop (length ,seed)))
(random-state:make-generator ,rngname)
(random-state:make-generator
,rngname ,seed)))
(getf (rest ,symbol) :seed)
(unless (and (vectorp ,seed) (zerop (length ,seed)))
,seed))))
(error "The [⎕RL random link] value can only be set as an ~a"
"integer or a 2-element vector."))))))
(t (let ((sym-package (package-name (symbol-package symbol))))
(if (and (listp value) (eql 'a-call (first value))
(listp (second value)) (eql 'function (caadr value))
(position (cadadr value) #(external-workspace-function
external-workspace-operator)
:test #'eql)
(not (string= "LEX" (subseq sym-package (+ -3 (length sym-package))
(length sym-package)))))
(let ((args (gensym))
(other-space (concatenate 'string "APRIL-WORKSPACE-"
(first (last value)))))
`(aprgn
(proclaim '(special ,symbol))
(setf (symbol-function ',symbol)
(lambda (&rest ,args)
(let ,(loop :for (key val) :on *system-variables* :by #'cddr
:collect (list (intern (string val) other-space)
(intern (string val) sym-package)))
(apply ,value ,args)))
,@(if (eql 'external-workspace-operator (cadadr value))
`((symbol-value ',symbol)
(symbol-value ',(intern (third value) other-space)))))))
(if namespace `(setf (getf ,(if (symbolp namespace)
namespace (follow-path (first namespace)
(rest namespace)))
,(intern (string symbol) "KEYWORD"))
,set-to)
;; toggle rendering varrays on assignment
`(setf ,symbol (vrender ,set-to :may-be-deferred t))))))))
(cond ((and (listp symbol) (eql 'nspath (first symbol)))
;; handle assignments within namespaces, using process-path to handle the paths
(let ((val (gensym)))
`(let ((,val ,value))
,(if (= 3 (length symbol))
`(setf ,(second symbol)
,(append (macroexpand (append symbol (if axes (list axes))))
(list :value val :value-nil `(null ,val))
(if by (list :set-by by))))
(append (macroexpand (append symbol (if axes (list axes))))
(list :value val :value-nil `(null ,val))
(if by (list :set-by by)))))))
((and (listp symbol) (eql 'make-virtual (first symbol))
(eql 'quote (caadr symbol)) (eql 'vader-select (cadadr symbol)))
;; handle selective assignments, using process-path to handle the paths
`(setf ,(getf (cddr symbol) :base)
(vrender ,(append symbol (list :assign value)
(if by (list :calling by)))
:may-be-deferred t)))
((and (listp symbol) (eql 'symbol-function (first symbol)))
`(setf ,symbol ,value))
(t (let ((symbols (if (not (eql 'avec (first symbol)))
symbol (rest symbol))))
;; handle multiple assignments like a b c←1 2 3
(labels ((process-symbols (sym-list values)
(let* ((is-nested (gensym)) (this-val (gensym))
;; (this-generator (gensym))
(assigning-xfns (and (listp values) (eql 'a-call (first values))
(listp (second values))
(eql 'function (caadr values))
(position (cadadr values)
#(external-workspace-function
external-workspace-operator)
:test #'eql)))
(other-space (and assigning-xfns
(concatenate 'string "APRIL-WORKSPACE-"
(first (last values)))))
(sym-package (and assigning-xfns
(package-name (symbol-package (first sym-list)))))
(values (if (or (not assigning-xfns)
(not (listp values))
(not (listp (third values)))
(not (eql 'avec (first (third values)))))
;; change (avec 'values') to (list 'values') so that
;; the external item loaders can properly tell the difference
;; between "abc" and (avec #\a #\b #\c) as arguments
values (cons (first values)
(cons (second values)
(cons (cons 'list (rest (third values)))
(cdddr values)))))))
(if (and (listp sym-list) (listp values)
(eql 'avec (first values))
(/= (length sym-list) (length (rest values))))
(error "Attempted to assign a vector of values to a ~a"
"vector of symbols of a different length."))
`(let* ((,is-nested ,(loop :for sym
:in (if (not (eql 'avec (first sym-list)))
sym-list (rest sym-list))
:always (not (and (listp sym)
(not (eql 'inws
(first sym)))))))
(,this-val (vrender ,values :not-nested ,is-nested)))
;;(declare (ignorable ,this-val ,this-generator))
;; IPV-TODO: currently threaded assignment requires rendering
;; of the input vector; can this be improved?
,@(loop :for sym :in (if (not (eql 'avec (first sym-list)))
sym-list (rest sym-list))
:for sx :from 0
:append
(cond ((and (listp sym) (not (eql 'inws (first sym))))
(list (process-symbols
sym `(if (not (vectorp ,this-val))
,this-val (aref ,this-val ,sx)))))
((eql '⍺ sym)
`((or ⍺ (setf ⍺ (if (vectorp ,this-val)
(aref ,this-val sx)
(disclose ,this-val))))))
((eql '⍵ sym)
`(error "The [⍵ right argument] cannot ~a"
"have a default assignment."))
(assigning-xfns
;; handle assignment of multiple functions
;; from another WS like fn1 fn2 ← ⎕XWF 'fn1' 'fn2'
(let ((args (gensym)))
`((proclaim '(special ,sym))
(setf (symbol-function ',sym)
(lambda (&rest ,args)
(let ,(loop :for (key val)
:on *system-variables*
:by #'cddr
:collect
(list (find-symbol (string val)
other-space)
(find-symbol (string val)
sym-package)))
(apply (aref ,this-val ,sx)
,args)))))))
(t `((setf ,sym (if (vectorp ,this-val)
(aref ,this-val ,sx)
(disclose ,this-val)))))))
,this-val))))
(process-symbols symbols value))))))))
(defun process-ns-output (item)
;; TODO: the use of this should change; NSes should have rendered content by default
"Process a namespace for output, rendering all virtual arrays within."
(if (not (listp item))
item (loop :for i :in item :collect (if (listp i) (process-ns-output i)
(vrender i)))))
(defmacro a-out (form &key (print-to) (output-printed) (unrendered)
(print-assignment) (print-precision) (with-newline))
"Generate code to output the result of APL evaluation, with options to print an APL-formatted text string expressing said result and/or return the text string as a result."
(let ((result (gensym)) (printout (gensym))
;; get the symbol referencing a function passed as the output
(function-name-value (when (and (listp form) (eql 'function (first form)))
`(string (quote ,(second form)))))
(form (if (not (and (characterp form) (of-lexicons this-idiom form :functions)))
form (build-call-form form))))
;; (print (list :bb unrendered form))
;; don't render if the (:unrendered) option has been passed
`(let* ((,result ,(if unrendered form `(process-ns-output (vrender ,form))))
;; (,result ,form)
;; (a (print :cc))
(,printout ,(when (and (or print-to output-printed))
;; don't print the results of assignment unless the :print-assignment
;; option is set, as done when compiling a ⎕← expression
(or (and function-name-value
`(concatenate 'string "∇" ,function-name-value))
;; if a bare function name is to be output, prefix it with ∇
(and (listp form)
(eql 'a-set (first form))
(not print-assignment)
"")
`(matrix-print ,result :append #\Newline
:segment (lambda (n &optional s)
(count-segments n ,print-precision s))
:format (lambda (n &optional s r)
(print-apl-number-string
n s ,print-precision nil r)))))))
(declare (ignorable ,result ,printout))
;; TODO: add printing rules for functions like {⍵+1}
;; (print (list :dd ,result))
,@(when print-to
(let ((string-output `(aprgn (write-string ,printout ,print-to))))
`((aprgn (if (arrayp ,result)
,string-output (concatenate 'string ,string-output (list #\Newline)))
,@(if with-newline
`((if (not (char= #\Newline (aref ,printout (1- (size ,printout)))))
(write-char #\Newline ,print-to))))))))
,(if output-printed (if (eq :only output-printed) printout `(values ,result ,printout))
result))))
(defun array-to-nested-vector (array)
"Convert an array to a nested vector. Useful for applications such as JSON conversion where multidimensional arrays must be converted to nested vectors."
(aops:each (lambda (member) (if (not (and (arrayp member) (< 1 (rank member))))
member (array-to-nested-vector member)))
(aops:split array 1)))
(defun avec (&rest items)
"This function returns an APL vector; in the case of virtual arrays within the vector, a nested virtual container vector is returned."
(let ((type) (contains-varrays))
(loop :for item :in items :while (or (not contains-varrays) (not (eq t type)))
:do (setq type (type-in-common type (assign-element-type (if (or (not (integerp item))
(> 0 item))
item (max 16 item))))
contains-varrays (or contains-varrays (varrayp item))))
(if contains-varrays
(let ((item-vector (make-array (length items) :element-type type :initial-contents items)))
(make-instance
'vader-subarray :base item-vector :shape (shape-of item-vector)
:nested t :generator (varray::generator-of item-vector)))
(make-array (length items) :element-type type :initial-contents items))))
(defun parse-apl-number-string (number-string &optional component-of)
"Parse an APL numeric string into a Lisp value, handling high minus signs, J-notation for complex numbers and R-notation for rational numbers."
(ignore-errors ;; if number parsing fails, just return nil
(let ((nstring (string-upcase (regex-replace-all (of-system this-idiom :number-spacers-pattern)
number-string ""))))
(if (and (not (eql 'complex component-of))
(position #\J nstring :test #'char=))
(let ((halves (cl-ppcre:split #\J nstring)))
(when (and (= 2 (length halves))
(< 0 (length (first halves)))
(< 0 (length (second halves))))
(complex (parse-apl-number-string (first halves) 'complex)
(parse-apl-number-string (second halves) 'complex))))
(if (position #\E nstring :test #'char=)
(let ((exp-float (parse-number:parse-number
(regex-replace-all (of-system this-idiom :negative-signs-pattern)
nstring "-")
:float-format 'double-float)))
(if (< double-float-epsilon (nth-value 1 (floor exp-float)))
exp-float (let ((halves (mapcar #'parse-apl-number-string
(cl-ppcre:split #\E nstring))))
(floor (* (first halves) (expt 10 (second halves)))))))
(if (and (not (eql 'rational component-of))
(position #\R nstring :test #'char=))
(let ((halves (cl-ppcre:split #\R nstring)))
(/ (parse-apl-number-string (first halves) 'rational)
(parse-apl-number-string (second halves) 'rational)))
;; the macron character is converted to the minus sign
(parse-number:parse-number
(regex-replace-all (of-system this-idiom :negative-signs-pattern)
nstring "-")