├── go.sum ├── S39 ├── prf.txt ├── shen-to-tcl.txt ├── tcl-to-shen.txt ├── Lib │ ├── StLib │ │ ├── Encrypt │ │ │ ├── az.txt │ │ │ ├── tbos.txt │ │ │ └── encrypt.shen │ │ ├── README.txt │ │ ├── package-stlib.shen │ │ ├── Strings │ │ │ ├── macros.shen │ │ │ ├── smart.shen │ │ │ └── smartmem.shen │ │ ├── Symbols │ │ │ ├── symbols2.shen │ │ │ └── symbols1.shen │ │ ├── IO │ │ │ ├── delete-file.shen │ │ │ ├── prettyprint.shen │ │ │ └── files.shen │ │ ├── Maths │ │ │ ├── r.shen │ │ │ ├── complex.dtype │ │ │ ├── rationals.dtype │ │ │ ├── complex.shen │ │ │ ├── numerals.dtype │ │ │ ├── macros.shen │ │ │ ├── numerals.shen │ │ │ └── rationals.shen │ │ ├── Data │ │ │ └── data.shen │ │ ├── Tuples │ │ │ └── tuples.shen │ │ ├── install.shen │ │ └── Vectors │ │ │ ├── jnk.shen │ │ │ └── macros.shen │ ├── README.txt │ ├── package-stlib.shen │ ├── Tk │ │ ├── loadme.shen │ │ ├── Samples │ │ │ ├── wo-types.shen │ │ │ ├── loadme.shen │ │ │ └── calculator.shen │ │ ├── macros.shen │ │ ├── root.tcl │ │ ├── interface.shen │ │ ├── web.shen │ │ ├── package.shen │ │ └── test.shen │ ├── install.shen │ ├── IDE │ │ └── idedec.shen │ ├── LICENSE │ ├── patches-scheme.shen │ └── Concurrency │ │ └── concurrency.shen ├── Test Programs │ ├── runme.shen │ ├── README │ ├── findall.shen │ ├── mutual.shen │ ├── nreverseprolog.shen │ ├── prime.shen │ ├── fork.shen │ ├── powerset.shen │ ├── call.shen │ ├── bubble version 2.shen │ ├── propcalcprolog.shen │ ├── cartprod.shen │ ├── cut.shen │ ├── change.shen │ ├── streams.shen │ ├── bubble version 1.shen │ ├── parseprolog.shen │ ├── binary.shen │ ├── proplog version 1.shen │ ├── proplog version 2.shen │ ├── calculator.shen │ ├── totalprolog.shen │ ├── stack.shen │ ├── depth.shen │ ├── unification.shen │ ├── semantic net.shen │ ├── tableauprolog.shen │ ├── secd1.shen │ ├── spreadsheet.shen │ ├── einsteins-riddle.shen │ ├── lisp.shen │ ├── n queens.shen │ ├── n queens-r.shen │ ├── strings.shen │ ├── n queens.kl │ ├── classes-untyped.shen │ ├── parser.shen │ ├── prolog.shen │ ├── structures-untyped.shen │ ├── qmachine.shen │ ├── harness.shen │ ├── search.shen │ ├── montague.shen │ ├── yacc.shen │ ├── structures-typed.shen │ ├── proof assistant.shen │ ├── classes-typed.shen │ ├── metaprog.shen │ ├── classes-defaults.shen │ └── classes-inheritance.shen ├── logo3.png ├── KLambda │ ├── trace.lsp │ └── load.kl ├── Sources │ ├── README.txt │ ├── make.shen │ ├── LICENSE │ ├── load.shen │ └── writer.shen ├── Primitives │ ├── hd.lsp │ ├── tl.lsp │ ├── cons.lsp │ ├── set.lsp │ ├── value.lsp │ ├── close.lsp │ ├── intern.lsp │ ├── let.lsp │ ├── iscons.lsp │ ├── freeze.lsp │ ├── read-byte.lsp │ ├── write-byte.lsp │ ├── and.lsp │ ├── isabsvector.lsp │ ├── isstring.lsp │ ├── lambda.lsp │ ├── simple-error.lsp │ ├── address-get.lsp │ ├── cn.lsp │ ├── or.lsp │ ├── type.lsp │ ├── absvector.lsp │ ├── address-send.lsp │ ├── char-stoutput.lsp │ ├── read-unit-string.lsp │ ├── tlstr.lsp │ ├── trap-error.lsp │ ├── n-to-string.lsp │ ├── write-string.lsp │ ├── error-to-string.lsp │ ├── if.lsp │ ├── char-stinput.lsp │ ├── eval-kl.lsp │ ├── string-to-n.lsp │ ├── get-time.lsp │ ├── globals.lsp │ ├── pos.lsp │ ├── open.lsp │ ├── equal.lsp │ ├── arith.lsp │ ├── LICENSE │ └── str.lsp ├── shen-tk.bat └── README.txt ├── compiled ├── .gitignore ├── compile-to-go.shen ├── bctogo.shen └── script.kl ├── .gitignore ├── go.mod ├── cmd ├── kl │ ├── runtests.shen │ ├── runtests.kl │ └── main.go └── shen │ └── main.go ├── Dockerfile ├── Makefile ├── .github └── workflows │ └── go.yml ├── kl ├── stub_test.kl ├── primitives_test.go ├── reader_test.go ├── library_test.go ├── library.go ├── reader.go └── eval_test.go ├── LICENSE ├── src └── compiler.shen └── README.md /go.sum: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /S39/prf.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /S39/shen-to-tcl.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /S39/tcl-to-shen.txt: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /compiled/.gitignore: -------------------------------------------------------------------------------- 1 | *.bc 2 | *.tmp -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.so 2 | *.bc 3 | shen 4 | *.exe -------------------------------------------------------------------------------- /go.mod: -------------------------------------------------------------------------------- 1 | module github.com/tiancaiamao/shen-go 2 | 3 | go 1.25 4 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Encrypt/az.txt: -------------------------------------------------------------------------------- 1 | the quick brown fox jumped over the lazy dog -------------------------------------------------------------------------------- /S39/Test Programs/runme.shen: -------------------------------------------------------------------------------- 1 | (load "harness.shen") 2 | (load "kerneltests.shen") -------------------------------------------------------------------------------- /S39/logo3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tiancaiamao/shen-go/HEAD/S39/logo3.png -------------------------------------------------------------------------------- /S39/KLambda/trace.lsp: -------------------------------------------------------------------------------- 1 | (DEFUN trace (F) (EVAL (READ-FROM-STRING (FORMAT NIL "(TRACE ~A)" F)))) -------------------------------------------------------------------------------- /S39/Lib/README.txt: -------------------------------------------------------------------------------- 1 | to install the extended library, cd in Shen to this directory and enter install.shen -------------------------------------------------------------------------------- /S39/Lib/StLib/README.txt: -------------------------------------------------------------------------------- 1 | to install the standard library, cd in Shen to this directory and enter install.shen -------------------------------------------------------------------------------- /S39/Lib/StLib/Encrypt/tbos.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/tiancaiamao/shen-go/HEAD/S39/Lib/StLib/Encrypt/tbos.txt -------------------------------------------------------------------------------- /S39/Sources/README.txt: -------------------------------------------------------------------------------- 1 | To generate the KLambda files; enter Shen and load the file 'make.shen'. 2 | 3 | Then type (make) -------------------------------------------------------------------------------- /S39/Primitives/hd.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN hd (X) (CAR X)) -------------------------------------------------------------------------------- /S39/Primitives/tl.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN tl (X) (CDR X)) -------------------------------------------------------------------------------- /S39/Primitives/cons.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN cons (X Y) (CONS X Y)) -------------------------------------------------------------------------------- /S39/Primitives/set.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN set (X Y) (SET X Y)) -------------------------------------------------------------------------------- /S39/shen-tk.bat: -------------------------------------------------------------------------------- 1 | START /B sbcl-shen+tk.exe 2 | C:\ActiveTcl\bin\wish.exe "C:\Users\drmta\OneDrive\Desktop\Shen\S39\Lib\Tk\root.tcl" 3 | 4 | -------------------------------------------------------------------------------- /S39/Primitives/value.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN value (X) (SYMBOL-VALUE X)) -------------------------------------------------------------------------------- /S39/Primitives/close.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN close (Stream) (CLOSE Stream) NIL) -------------------------------------------------------------------------------- /S39/Primitives/intern.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN intern (String) (INTERN String)) -------------------------------------------------------------------------------- /S39/Primitives/let.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO let (X Y Z) `(LET ((,X ,Y)) ,Z)) -------------------------------------------------------------------------------- /S39/Primitives/iscons.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN cons? (X) (IF (CONSP X) 'true 'false)) -------------------------------------------------------------------------------- /S39/Primitives/freeze.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO freeze (X) `(FUNCTION (LAMBDA () ,X))) -------------------------------------------------------------------------------- /S39/Primitives/read-byte.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN read-byte (S) 6 | (READ-BYTE S NIL -1)) -------------------------------------------------------------------------------- /S39/Primitives/write-byte.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN write-byte (Byte S) (WRITE-BYTE Byte S)) -------------------------------------------------------------------------------- /S39/Primitives/and.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO and (X Y) `(if ,X (if ,Y 'true 'false) 'false)) -------------------------------------------------------------------------------- /S39/Primitives/isabsvector.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN absvector? (X) (IF (ARRAYP X) 'true 'false)) -------------------------------------------------------------------------------- /S39/Primitives/isstring.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN string? (S) (IF (STRINGP S) 'true 'false)) 6 | -------------------------------------------------------------------------------- /S39/Primitives/lambda.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO lambda (X Y) `(FUNCTION (LAMBDA (,X) ,Y))) -------------------------------------------------------------------------------- /S39/Primitives/simple-error.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN simple-error (String) (ERROR "~A" String)) -------------------------------------------------------------------------------- /S39/Primitives/address-get.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN <-address (Vector N) (SVREF Vector N)) 6 | 7 | -------------------------------------------------------------------------------- /S39/Primitives/cn.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN cn (Str1 Str2) (CONCATENATE 'STRING Str1 Str2)) 6 | 7 | -------------------------------------------------------------------------------- /S39/Primitives/or.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO or (X Y) `(if ,X 'true (if ,Y 'true 'false))) 6 | 7 | -------------------------------------------------------------------------------- /S39/Primitives/type.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN type (X MyType) (DECLARE (IGNORE MyType)) X) 6 | 7 | -------------------------------------------------------------------------------- /S39/Test Programs/README: -------------------------------------------------------------------------------- 1 | This directory contains test programs for testing the Shen kernel. 2 | To run it; cd to this directory within Shen and enter 3 | 4 | (load "runme.shen") -------------------------------------------------------------------------------- /S39/Lib/package-stlib.shen: -------------------------------------------------------------------------------- 1 | (package stlib (mapcan (fn external) 2 | [list string maths vector symbol 3 | tuple file print]) 4 | void) -------------------------------------------------------------------------------- /S39/Primitives/absvector.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN absvector (N) (MAKE-ARRAY (LIST N) :INITIAL-ELEMENT 'shen.fail!)) -------------------------------------------------------------------------------- /S39/Primitives/address-send.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN address-> (Vector N Value) (SETF (SVREF Vector N) Value) Vector) -------------------------------------------------------------------------------- /S39/Test Programs/findall.shen: -------------------------------------------------------------------------------- 1 | (defprolog enjoys 2 | mark chocolate <--; 3 | mark tea <--;) 4 | 5 | (defprolog fads 6 | X <-- (findall Y (enjoys X Y) Likes) (return Likes);) -------------------------------------------------------------------------------- /S39/Lib/StLib/package-stlib.shen: -------------------------------------------------------------------------------- 1 | (package stlib (mapcan (fn external) 2 | [list string maths vector symbol 3 | tuple file print]) 4 | void) -------------------------------------------------------------------------------- /S39/Lib/StLib/Strings/macros.shen: -------------------------------------------------------------------------------- 1 | (defmacro string-macros 2 | [s-op1 F S] -> [s-op1 F S [/. (protect X) (protect X)]] 3 | [s-op2 F S1 S2] -> [s-op2 F S1 S2 [/. (protect X) (protect X)]]) 4 | -------------------------------------------------------------------------------- /cmd/kl/runtests.shen: -------------------------------------------------------------------------------- 1 | (set *saved-home* (value *home-directory*)) 2 | (set *home-directory* (cn (value *saved-home*) "/S31/Test Programs")) 3 | \\(cd "../../S31/Test Programs") 4 | (load "runme.shen") 5 | -------------------------------------------------------------------------------- /S39/Primitives/char-stoutput.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN shen.char-stoutput? (Stream) 6 | (IF (EQ Stream *stoutput*) 'true 'false)) 7 | -------------------------------------------------------------------------------- /S39/Primitives/read-unit-string.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN shen.read-unit-string (Stream) (COERCE (LIST (READ-CHAR Stream)) 'STRING)) -------------------------------------------------------------------------------- /S39/Test Programs/mutual.shen: -------------------------------------------------------------------------------- 1 | (define even*? 2 | 1 -> false 3 | X -> (odd*? (- X 1))) 4 | 5 | (define odd*? 6 | 1 -> true 7 | X -> (even*? (- X 1))) 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Symbols/symbols2.shen: -------------------------------------------------------------------------------- 1 | (package symbol [newv | (external symbol)] 2 | 3 | (define newv 4 | {--> symbol} 5 | -> (gensym (protect X))) 6 | 7 | 8 | 9 | ) 10 | -------------------------------------------------------------------------------- /S39/Primitives/tlstr.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN tlstr (X) (trap-error (SUBSEQ X 1) (LAMBDA (E) (ERROR "~S is not a non-empty string~%" X)))) -------------------------------------------------------------------------------- /S39/Primitives/trap-error.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO trap-error (X F) 6 | `(HANDLER-CASE ,X (ERROR (Condition) (FUNCALL ,F Condition)))) 7 | -------------------------------------------------------------------------------- /S39/Primitives/n-to-string.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN n->string (N) (trap-error (FORMAT NIL "~C" (CODE-CHAR N)) (ERROR "~A is not a natural number~%" N))) -------------------------------------------------------------------------------- /S39/Test Programs/nreverseprolog.shen: -------------------------------------------------------------------------------- 1 | (defprolog nreverse 2 | [] [] <--; 3 | [X | Y] R <-- (nreverse Y RY) (nappend RY [X] R);) 4 | 5 | (defprolog nappend 6 | [] X X <--; 7 | [X | Y] Z [X | W] <-- (nappend Y Z W);) -------------------------------------------------------------------------------- /S39/Lib/Tk/loadme.shen: -------------------------------------------------------------------------------- 1 | (load "package.shen") 2 | (factorise +) 3 | (load "macros.shen") 4 | (factorise -) 5 | (map (fn load) ["interface.shen" "widgets.shen" "types.shen"]) 6 | (tc +) 7 | (load "web.shen") 8 | (tc -) -------------------------------------------------------------------------------- /S39/Primitives/write-string.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN shen.write-string (String Stream) 6 | (WRITE-STRING String Stream) 7 | (FORCE-OUTPUT Stream) 8 | String) 9 | 10 | -------------------------------------------------------------------------------- /S39/Primitives/error-to-string.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN error-to-string (E) 6 | (IF (TYPEP E 'CONDITION) 7 | (FORMAT NIL "~A" E) 8 | (ERROR "~S is not an exception~%" E))) -------------------------------------------------------------------------------- /S39/Test Programs/prime.shen: -------------------------------------------------------------------------------- 1 | (define prime*? 2 | X -> (prime* X (/ X 2) 2)) 3 | 4 | (define prime* 5 | X Max Div -> false where (integer? (/ X Div)) 6 | X Max Div -> true where (> Div Max) 7 | X Max Div -> (prime* X Max (+ 1 Div))) 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /S39/Primitives/if.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFMACRO if (X Y Z) 6 | `(LET ((*C* ,X)) 7 | (COND ((EQ *C* 'true) ,Y) 8 | ((EQ *C* 'false) ,Z) 9 | (T (ERROR "~S is not a boolean~%" *C*))))) -------------------------------------------------------------------------------- /S39/Test Programs/fork.shen: -------------------------------------------------------------------------------- 1 | 2 | (defprolog g1 3 | a <--;) 4 | 5 | (defprolog h 6 | b <--;) 7 | 8 | (defprolog i 9 | a <--; 10 | b <--;) 11 | 12 | (defprolog j 13 | b <--;) 14 | 15 | (defprolog f 16 | X <-- (g1 X) (fork [(h X) (i X) (j X)]);) -------------------------------------------------------------------------------- /S39/Primitives/char-stinput.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | #+SBCL 6 | (DEFUN shen.char-stinput? (Stream) 'false) 7 | 8 | #+CLISP 9 | (DEFUN shen.char-stinput? (Stream) 10 | (IF (EQ Stream *stinput*) 'true 'false)) 11 | -------------------------------------------------------------------------------- /S39/Lib/Tk/Samples/wo-types.shen: -------------------------------------------------------------------------------- 1 | (package calc (external calc) 2 | 3 | (declare evaluate-display [label --> [string --> string]]) 4 | 5 | (define evaluate-display 6 | Display DisplayText -> (let Result (str (eval (read-from-string DisplayText))) 7 | (tk.putw Display -text Result))) ) -------------------------------------------------------------------------------- /S39/Primitives/eval-kl.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN eval-kl (X) 6 | (LET ((E (EVAL (cl.kl-to-lisp X)))) 7 | (IF (AND (CONSP X) (EQ (CAR X) 'defun)) 8 | (COMPILE E) 9 | E))) 10 | 11 | -------------------------------------------------------------------------------- /S39/Lib/StLib/IO/delete-file.shen: -------------------------------------------------------------------------------- 1 | (define delete-file 2 | {string --> (list A)} 3 | File -> (cases (= (language) "Common Lisp") (lisp.delete-file File) 4 | true (close (open File out)))) 5 | 6 | (declare delete-file [string --> [list A]]) 7 | -------------------------------------------------------------------------------- /S39/Test Programs/powerset.shen: -------------------------------------------------------------------------------- 1 | (define powerset* 2 | [] -> [[]] 3 | [X | Y] -> (let Powerset (powerset* Y) 4 | (append (cons-X-to-each-set X Powerset) Powerset))) 5 | 6 | (define cons-X-to-each-set 7 | _ [ ] -> [ ] 8 | X [Y | Z] -> [[X | Y] | (cons-X-to-each-set X Z)]) 9 | 10 | 11 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/r.shen: -------------------------------------------------------------------------------- 1 | (package rational (append [r-reduce r= r< r> r>= r<= r+ r- r* r/ r-expr +-inverse *-inverse 2 | r-expt r->n r->pair n->r maths.n->r r-approx maths.lcd-loop 3 | r-op1 r-op2] 4 | (external maths)) 5 | 6 | a) -------------------------------------------------------------------------------- /S39/Primitives/string-to-n.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN string->n (S) (LET ((L (COERCE S 'LIST))) 6 | (IF (= (LIST-LENGTH L) 1) 7 | (CHAR-CODE (CAR L)) 8 | (ERROR "~S is not a unit string.~%" S)))) -------------------------------------------------------------------------------- /S39/Test Programs/call.shen: -------------------------------------------------------------------------------- 1 | (defprolog mapit 2 | _ [] [] <--; 3 | Pred [X | Y] [W | Z] <-- (call (Pred X W)) (mapit Pred Y Z);) 4 | 5 | (defprolog consit 6 | X [1 X] <--;) 7 | 8 | (defprolog different 9 | X Y <-- (not! (is X Y));) 10 | 11 | (defprolog not! 12 | P <-- (call P) ! (when false); 13 | _ <--;) 14 | 15 | -------------------------------------------------------------------------------- /S39/Test Programs/bubble version 2.shen: -------------------------------------------------------------------------------- 1 | (define bubble-sort 2 | X -> (fix (fn bubble) X)) 3 | 4 | (define bubble 5 | [] -> [] 6 | [X] -> [X] 7 | [X Y | Z] -> [Y | (bubble [X | Z])] where (> Y X) 8 | [X Y | Z] -> [X | (bubble [Y | Z])]) 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Symbols/symbols1.shen: -------------------------------------------------------------------------------- 1 | (package symbol [concat*] 2 | 3 | (define concat* 4 | S1 S2 -> (let S1+S2 (concat S1 S2) 5 | (if (symbol? S1+S2) 6 | S1+S2 7 | (error "'~A' is not a symbol~%" S1+S2)))) 8 | 9 | (declare concat* [A --> [B --> symbol]]) ) 10 | 11 | -------------------------------------------------------------------------------- /S39/Test Programs/propcalcprolog.shen: -------------------------------------------------------------------------------- 1 | (defprolog mapit 2 | _ [] [] <--; 3 | Pred [X | Y] [W | Z] <-- (call (Pred X W)) (mapit Pred Y Z);) 4 | 5 | (defprolog consit 6 | X [1 X] <--;) 7 | 8 | (defprolog different 9 | X Y <-- (not! (is X Y));) 10 | 11 | (defprolog not! 12 | P <-- (call P) ! (when false); 13 | _ <--;) 14 | 15 | -------------------------------------------------------------------------------- /S39/Test Programs/cartprod.shen: -------------------------------------------------------------------------------- 1 | (define cartesian-product 2 | [ ] _ -> [ ] 3 | [X | Y] Z -> (append (all-pairs-using-X X Z) (cartesian-product Y Z))) 4 | 5 | (define all-pairs-using-X 6 | _ [ ] -> [ ] 7 | X [Y | Z] -> [[X Y] | (all-pairs-using-X X Z)]) 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /S39/Test Programs/cut.shen: -------------------------------------------------------------------------------- 1 | (defprolog a 2 | X <-- (b X) (c X);) 3 | 4 | (defprolog b 5 | 1 <--; 6 | 4 <--;) 7 | 8 | (defprolog c 9 | X <-- (d X) ! (e* X); 10 | X <-- (f X);) 11 | 12 | (defprolog d 13 | X <-- (g* X); 14 | X <-- (h X);) 15 | 16 | (defprolog e* 17 | 3 <--;) 18 | 19 | (defprolog f 20 | 4 <--;) 21 | 22 | (defprolog g* 23 | 2 <--;) 24 | 25 | (defprolog h 26 | 1 <--;) -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM golang:alpine 2 | 3 | RUN apk update 4 | RUN apk upgrade 5 | RUN apk add alpine-sdk git upx 6 | 7 | ENV GOPATH /usr/local 8 | ADD ./ /usr/local/src/github.com/tiancaiamao/shen-go 9 | WORKDIR /usr/local/src/github.com/tiancaiamao/shen-go 10 | RUN CGO_ENABLED=0 GOOS=linux go build -a -ldflags '-extldflags "-static"' -o shen cmd/shen/*.go 11 | RUN upx -9 --ultra-brute ./shen 12 | RUN install ./shen /usr/local/bin/ 13 | -------------------------------------------------------------------------------- /S39/Primitives/get-time.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN get-time (Time) 6 | (COND ((EQ Time 'run) 7 | (* 1.0 (/ (GET-INTERNAL-RUN-TIME) 8 | INTERNAL-TIME-UNITS-PER-SECOND))) 9 | ((EQ Time 'unix) 10 | (- (GET-UNIVERSAL-TIME) 2208988800)) 11 | (T (ERROR "get-time does not understand the parameter ~A~%" Time)))) -------------------------------------------------------------------------------- /S39/Primitives/globals.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (SETQ *language* "Common Lisp" 6 | *implementation* (LISP-IMPLEMENTATION-TYPE) 7 | *porters* "Mark Tarver" 8 | *port* "3.3" 9 | *os* (SOFTWARE-TYPE) 10 | *stinput* *STANDARD-INPUT* 11 | *stoutput* *STANDARD-OUTPUT*) 12 | 13 | #+SBCL 14 | (SETQ *release* "2.0.0") 15 | 16 | #+CLISP 17 | (SETQ *release* "2.49") -------------------------------------------------------------------------------- /S39/Primitives/pos.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN pos (X N) (trap-error (COERCE (LIST (CHAR X N)) 'STRING) 6 | (LAMBDA (E) 7 | (IF (NOT (STRINGP X)) 8 | (ERROR "~A is not a string~%" X) 9 | (ERROR "~A is not a natural number less than the length of the string~%" 10 | N))))) 11 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all kl shen docker test 2 | 3 | all: kl shen 4 | 5 | kl: 6 | go install github.com/tiancaiamao/shen-go/cmd/kl 7 | 8 | shen: 9 | go build -o shen github.com/tiancaiamao/shen-go/cmd/shen 10 | 11 | shen-exe: 12 | go build -o shen.exe github.com/tiancaiamao/shen-go/cmd/shen 13 | 14 | 15 | 16 | docker: 17 | docker build -t shen-go . 18 | docker run -i -t --rm -v /tmp:/tmp shen-go \ 19 | /bin/sh -c 'cp -a /usr/local/bin/shen /tmp/' 20 | cp -a /tmp/shen ./shen 21 | 22 | test: 23 | cd kl; go test -v 24 | 25 | -------------------------------------------------------------------------------- /S39/Test Programs/change.shen: -------------------------------------------------------------------------------- 1 | (define count-change 2 | Amount -> (count-change* Amount 200)) 3 | 4 | (define count-change* 5 | 0 _ -> 1 6 | _ 0 -> 0 7 | Amount _ -> 0 where (> 0 Amount) 8 | Amount Fst_Denom 9 | -> (+ (count-change* (- Amount Fst_Denom) Fst_Denom) 10 | (count-change* Amount (next-denom Fst_Denom)))) 11 | 12 | (define next-denom 13 | 200 -> 100 14 | 100 -> 50 15 | 50 -> 20 16 | 20 -> 10 17 | 10 -> 5 18 | 5 -> 2 19 | 2 -> 1 20 | 1 -> 0) 21 | 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /S39/Lib/install.shen: -------------------------------------------------------------------------------- 1 | (tc -) 2 | (if (= (language) "Scheme") (load "patches-scheme.shen") skip) 3 | 4 | (cd "Lib/StLib") 5 | (load "install.shen") 6 | 7 | (cd "Lib/Tk") 8 | (load "loadme.shen") 9 | 10 | (tc -) 11 | (cd "Lib/Concurrency") 12 | (load "concurrency.dtype") 13 | (tc +) 14 | (load "concurrency.shen") 15 | 16 | (tc -) 17 | (cd "Lib/IDE") 18 | (load "idedec.shen") 19 | (tc +) 20 | (load "ide.shen") 21 | (tk.types -) 22 | 23 | (preclude-all-but []) 24 | (set shen.*userdefs* []) 25 | (cd "") 26 | (tc -) 27 | (if (= (language) "Scheme") (ide.myIDE) skip) 28 | 29 | -------------------------------------------------------------------------------- /S39/Test Programs/streams.shen: -------------------------------------------------------------------------------- 1 | (datatype progression 2 | 3 | X : (A * (A --> A) * (A --> boolean)); 4 | ====================================== 5 | X : (progression A);) 6 | 7 | (define delay 8 | {(progression A) --> (progression A)} 9 | (@p X F E) -> (if (not (E X)) 10 | (@p (F X) F E) 11 | (error "progression exhausted!~%"))) 12 | 13 | (define force 14 | {(progression A) --> A} 15 | (@p X F E) -> X) 16 | 17 | (define end? 18 | {(progression A) --> boolean} 19 | (@p X _ E) -> (E X)) 20 | 21 | -------------------------------------------------------------------------------- /S39/Test Programs/bubble version 1.shen: -------------------------------------------------------------------------------- 1 | (define bubble-sort 2 | \* bubble again if you need to *\ 3 | X -> (bubble-again-perhaps (bubble X) X)) 4 | 5 | (define bubble 6 | [] -> [] 7 | [X] -> [X] 8 | [X Y | Z] -> [Y | (bubble [X | Z])] where (> Y X) 9 | [X Y | Z] -> [X | (bubble [Y | Z])]) 10 | 11 | (define bubble-again-perhaps 12 | \* no change as a result of bubbling - then the job is done *\ 13 | X X -> X 14 | \* else bubble again *\ 15 | X _ -> (bubble-sort X)) 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /S39/Test Programs/parseprolog.shen: -------------------------------------------------------------------------------- 1 | (defprolog pparse 2 | S Grammar <-- (parsing [[s + 0] = [S + 0]] Grammar);) 3 | 4 | (defprolog parsing 5 | [X = X] _ <--; 6 | [[X + Y] = [X + Z]] Grammar <-- ! (parsing [Y = Z] Grammar); 7 | [[[X + Y] + Z] = W] Grammar <-- ! (parsing [[X + [Y + Z]] = W] Grammar); 8 | [W = [[X + Y] + Z]] Grammar <-- ! (parsing [W = [X + [Y + Z]]] Grammar); 9 | [[X + Y] = Z] Grammar <-- (member [X = W] Grammar) (parsing [[W + Y] = Z] Grammar);) 10 | 11 | (defprolog member 12 | X [X | _] <--; 13 | X [_ | Y] <-- (member X Y);) 14 | 15 | 16 | 17 | -------------------------------------------------------------------------------- /cmd/kl/runtests.kl: -------------------------------------------------------------------------------- 1 | 2 | (load-file "S39/KLambda/toplevel.kl") 3 | (load-file "S39/KLambda/core.kl") 4 | (load-file "S39/KLambda/sys.kl") 5 | (load-file "S39/KLambda/sequent.kl") 6 | (load-file "S39/KLambda/yacc.kl") 7 | (load-file "S39/KLambda/reader.kl") 8 | (load-file "S39/KLambda/prolog.kl") 9 | (load-file "S39/KLambda/track.kl") 10 | (load-file "S39/KLambda/load.kl") 11 | (load-file "S39/KLambda/writer.kl") 12 | (load-file "S39/KLambda/macros.kl") 13 | (load-file "S39/KLambda/declarations.kl") 14 | (load-file "S39/KLambda/t-star.kl") 15 | (load-file "S39/KLambda/types.kl") 16 | (shen.shen) 17 | -------------------------------------------------------------------------------- /S39/Test Programs/binary.shen: -------------------------------------------------------------------------------- 1 | (datatype binary 2 | 3 | if (element? X [0 1]) 4 | _____________ 5 | X : zero-or-one; 6 | 7 | X : zero-or-one; 8 | ________________ 9 | [X] : binary; 10 | 11 | X : zero-or-one; Y : binary; 12 | ____________________________ 13 | [X | Y] : binary; 14 | 15 | X : zero-or-one, [Y | Z] : binary >> P; 16 | ________________________________________ 17 | [X Y | Z] : binary >> P;) 18 | 19 | (define complement 20 | {binary --> binary} 21 | [0] -> [1] 22 | [1] -> [0] 23 | [1 N | X] -> [0 | (complement [N | X])] 24 | [0 N | X] -> [1 | (complement [N | X])]) 25 | -------------------------------------------------------------------------------- /S39/Test Programs/proplog version 1.shen: -------------------------------------------------------------------------------- 1 | (define backchain 2 | Conc Assumptions -> (backchain* [Conc] Assumptions Assumptions)) 3 | 4 | (define backchain* 5 | [] _ _ -> proved 6 | [[P & Q] | Goals] _ Assumptions 7 | -> (backchain* [P Q | Goals] Assumptions Assumptions) 8 | [P | Goals] [[P <= | Subgoal] | _] Assumptions 9 | <- (backchain* (append Subgoal Goals) Assumptions Assumptions) 10 | Goals [_ | Rest] Assumptions -> (backchain* Goals Rest Assumptions) 11 | _ _ _ -> (fail)) 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /S39/Test Programs/proplog version 2.shen: -------------------------------------------------------------------------------- 1 | (define backchain 2 | Conc Assumptions -> (backchain* Conc Assumptions Assumptions)) 3 | 4 | (define backchain* 5 | P [P | _] _ -> true 6 | [P & Q] _ Assumptions 7 | -> (and (backchain* P Assumptions Assumptions) 8 | (backchain* Q Assumptions Assumptions)) 9 | P [[P <= Q] | _] Assumptions 10 | <- (fail-if (/. X (= X false)) (backchain* Q Assumptions Assumptions)) 11 | P [_ | Rest] Assumptions -> (backchain* P Rest Assumptions) 12 | _ _ _ -> false) 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | -------------------------------------------------------------------------------- /S39/Lib/IDE/idedec.shen: -------------------------------------------------------------------------------- 1 | (package ide [tk.font titlefont tk.class tk.putw tk.root -bg] 2 | 3 | (declare read-number [string --> [number --> number]]) 4 | (declare shen.prompt [--> string]) 5 | (declare pluginlist [--> [list [string * [list string]]]]) 6 | 7 | (define read-number 8 | S N -> (let M (trap-error (hd (read-from-string S)) (/. E skip)) 9 | (if (number? M) 10 | M 11 | N))) 12 | 13 | (put titlefont tk.class tk.font) 14 | 15 | (define toplevel 16 | -> (do (myIDE) (tk.putw (tk.root) -bg (bg)) (shen.shen))) ) -------------------------------------------------------------------------------- /S39/Test Programs/calculator.shen: -------------------------------------------------------------------------------- 1 | (datatype arith-expr 2 | 3 | X : number; 4 | ==================== 5 | [num X] : arith-expr; 6 | 7 | if (element? Op [+ - * /]) 8 | X : arith-expr; Y : arith-expr; 9 | =============================== 10 | [X Op Y] : arith-expr;) 11 | 12 | (define do-calculation 13 | {arith-expr --> number} 14 | [X + Y] -> (+ (do-calculation X) (do-calculation Y)) 15 | [X - Y] -> (- (do-calculation X) (do-calculation Y)) 16 | [X * Y] -> (* (do-calculation X) (do-calculation Y)) 17 | [X / Y] -> (/ (do-calculation X) (do-calculation Y)) 18 | [num X] -> X) 19 | 20 | 21 | 22 | -------------------------------------------------------------------------------- /.github/workflows/go.yml: -------------------------------------------------------------------------------- 1 | # This workflow will build a golang project 2 | # For more information see: https://docs.github.com/en/actions/automating-builds-and-tests/building-and-testing-go 3 | 4 | name: Go 5 | 6 | on: 7 | push: 8 | branches: [ "master" ] 9 | pull_request: 10 | branches: [ "master" ] 11 | 12 | jobs: 13 | 14 | build: 15 | runs-on: ubuntu-latest 16 | steps: 17 | - uses: actions/checkout@v3 18 | 19 | - name: Set up Go 20 | uses: actions/setup-go@v3 21 | with: 22 | go-version: 1.18 23 | 24 | - name: Build 25 | run: make 26 | 27 | - name: Test 28 | run: make test 29 | -------------------------------------------------------------------------------- /S39/Primitives/open.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN open (String Direction) 6 | (LET ((Path (FORMAT NIL "~A~A" *home-directory* String))) 7 | (cl.openh Path Direction))) 8 | 9 | (DEFUN cl.openh (Path Direction) 10 | (COND ((EQ Direction 'in) 11 | (OPEN Path :DIRECTION :INPUT 12 | :ELEMENT-TYPE '(UNSIGNED-BYTE 8))) 13 | ((EQ Direction 'out) 14 | (OPEN Path :DIRECTION :OUTPUT 15 | :ELEMENT-TYPE '(UNSIGNED-BYTE 8) 16 | :IF-EXISTS :SUPERSEDE)) 17 | (T (ERROR "invalid direction")))) -------------------------------------------------------------------------------- /kl/stub_test.kl: -------------------------------------------------------------------------------- 1 | (defun f () (+ 1 (trap-error (+ 2 (simple-error "xxx")) (lambda e 2)))) 2 | 3 | (defun recur (n) 4 | (if (= n 0) 5 | n 6 | (recur (- n 1)))) 7 | 8 | (defun fact0 (sum n) 9 | (if (= n 0) 10 | sum 11 | (fact0 (* sum n) (- n 1)))) 12 | 13 | (defun fact (n) 14 | (fact0 1 n)) 15 | 16 | (defun reverse-help (res l) 17 | (if (= l ()) 18 | res 19 | (reverse-help (cons (hd l) res) (tl l)))) 20 | 21 | (defun reverse (l) 22 | (reverse-help () l)) 23 | 24 | (defun map-help (res f l) 25 | (if (cons? l) 26 | (map-help (cons (f (hd l)) res) f (tl l)) 27 | (reverse res))) 28 | 29 | (defun map (f l) 30 | (map-help () f l)) 31 | -------------------------------------------------------------------------------- /S39/Test Programs/totalprolog.shen: -------------------------------------------------------------------------------- 1 | (defprolog lived 2 | "Adam" 930 <--; 3 | "Seth" 912 <--; 4 | "Enos" 905 <--; 5 | "Ca-i'nan" 910 <--; 6 | "Mahal'aleel" 895 <--; 7 | "Jared" 962 <--; 8 | "Enoch" 365 <--; 9 | "Methu'selah" 969 <--; 10 | "Lamech" 777 <--;) 11 | 12 | (defprolog begat 13 | "Adam" "Seth" <--; 14 | "Seth" "Enos" <--; 15 | "Enos" "Ca-i'nan" <--; 16 | "Ca-i'nan" "Mahal'aleel" <--; 17 | "Mahal'aleel" "Jared" <--; 18 | "Jared" "Enoch" <--; 19 | "Enoch" "Methu'selah" <--; 20 | "Methu'selah" "Lamech" <--;) 21 | 22 | (prolog? (findall Age (lived Person Age) Ages) 23 | (return (sum Ages))) 24 | 25 | (defprolog total 26 | [] 0 <--; 27 | [X | Y] N <-- (total Y M) (is N (+ M X));) 28 | 29 | -------------------------------------------------------------------------------- /S39/Test Programs/stack.shen: -------------------------------------------------------------------------------- 1 | (declare empty-stack [A --> [stack B]]) 2 | 3 | (declare push [A --> [stack A] --> [stack A]]) 4 | 5 | (declare top [[stack A] --> A]) 6 | 7 | (declare pop [[stack A] --> [stack A]]) 8 | 9 | (define empty-stack 10 | _ -> (/. X (if (or (= X pop) (= X top)) 11 | (error "this stack is empty~%") 12 | (error "~A is not an operation on stacks.~%" X)))) 13 | 14 | (define push 15 | X S -> (/. Y (if (= Y pop) 16 | S 17 | (if (= Y top) 18 | X 19 | (error "~A is not an operation on stacks.~%" Y))))) 20 | 21 | (define top 22 | S -> (S top)) 23 | 24 | (define pop 25 | S -> (S pop)) 26 | 27 | 28 | -------------------------------------------------------------------------------- /S39/Sources/make.shen: -------------------------------------------------------------------------------- 1 | \\ Copyright (c) 2010-2019, Mark Tarver 2 | \\ All rights reserved. 3 | 4 | (define make 5 | -> (let ResePrintSize (set *maximum-print-sequence-size* 10000) 6 | ResetGensym (set shen.*gensym* 0) 7 | MainBoot (map (fn bootstrap) 8 | ["yacc.shen" "core.shen" "load.shen" 9 | "prolog.shen" "reader.shen" "sequent.shen" "sys.shen" "t-star.shen" 10 | "toplevel.shen" "track.shen" "types.shen" "writer.shen" "backend.shen" 11 | "declarations.shen" ]) 12 | Factor+ (factorise +) 13 | MacroBoot (bootstrap "macros.shen") 14 | Factor- (factorise -) 15 | ResePrintSize (set *maximum-print-sequence-size* 20) 16 | done)) -------------------------------------------------------------------------------- /S39/Test Programs/depth.shen: -------------------------------------------------------------------------------- 1 | (define depth 2 | {A --> (A --> (list A)) --> (A --> boolean) --> (A --> boolean) --> (list A)} 3 | State Successors Goal? Fail? -> (depth-help [State] Successors Goal? Fail? [])) 4 | 5 | (define depth-help 6 | {(list A) --> (A --> (list A)) --> (A --> boolean) --> (A --> boolean) --> (list A) --> (list A)} 7 | [State | _] _ Goal? _ Path -> (reverse [State | Path]) where (Goal? State) 8 | [State | _] _ _ Fail? _ -> [] where (Fail? State) 9 | [State | _] Successors Goal? Fail? Path <- (fail-if (fn empty?) 10 | (depth-help (Successors State) 11 | Successors Goal? Fail? [State | Path])) 12 | [_ | States] Successors Goal? Fail? Path -> (depth-help States Successors Goal? Fail? Path) 13 | _ _ _ _ _ -> []) 14 | 15 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Data/data.shen: -------------------------------------------------------------------------------- 1 | (package file [read-data eval-data] 2 | 3 | (declare read-data [string --> [list unit]]) 4 | (declare eval-data [string -->[list unit]]) 5 | 6 | (define read-data 7 | File -> (let In (open File in) 8 | (read-data-loop (trap-read In) In []))) 9 | 10 | (define read-data-loop 11 | eof! In Acc -> (do (close In) (reverse Acc)) 12 | Read In Acc -> (read-data-loop (trap-read In) In [Read | Acc])) 13 | 14 | (define trap-read 15 | In -> (trap-error (read In) (/. E eof!))) 16 | 17 | (define eval-data 18 | File -> (let In (open File in) 19 | (eval-data-loop (trap-eval In) In []))) 20 | 21 | (define eval-data-loop 22 | eof! In Acc -> (do (close In) (reverse Acc)) 23 | Read In Acc -> (eval-data-loop (trap-eval In) In [Read | Acc])) 24 | 25 | (define trap-eval 26 | In -> (trap-error (eval (read In)) (/. E eof!))) ) -------------------------------------------------------------------------------- /S39/Primitives/equal.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN cl.equal? (X Y) 6 | (IF (cl.ABSEQUAL X Y) 'true 'false)) 7 | 8 | (DEFUN cl.ABSEQUAL (X Y) 9 | (COND ((AND (CONSP X) (CONSP Y) (cl.ABSEQUAL (CAR X) (CAR Y))) 10 | (cl.ABSEQUAL (CDR X) (CDR Y))) 11 | ((AND (STRINGP X) (STRINGP Y)) (STRING= X Y)) 12 | ((AND (NUMBERP X) (NUMBERP Y)) (= X Y)) 13 | ((AND (ARRAYP X) (ARRAYP Y)) (CF-VECTORS X Y (LENGTH X) (LENGTH Y))) 14 | (T (EQUAL X Y)))) 15 | 16 | (DEFUN CF-VECTORS (X Y LX LY) 17 | (AND (= LX LY) 18 | (CF-VECTORS-HELP X Y 0 (1- LX)))) 19 | 20 | (DEFUN CF-VECTORS-HELP (X Y COUNT MAX) 21 | (COND ((= COUNT MAX) (cl.ABSEQUAL (AREF X MAX) (AREF Y MAX))) 22 | ((cl.ABSEQUAL (AREF X COUNT) (AREF Y COUNT)) (CF-VECTORS-HELP X Y (1+ COUNT) MAX)) 23 | (T NIL))) -------------------------------------------------------------------------------- /cmd/kl/main.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "flag" 5 | "fmt" 6 | "io" 7 | "net/http" 8 | _ "net/http/pprof" 9 | "os" 10 | 11 | "github.com/tiancaiamao/shen-go/kl" 12 | ) 13 | 14 | var pprof bool 15 | 16 | func init() { 17 | flag.BoolVar(&pprof, "pprof", false, "enable pprof") 18 | } 19 | 20 | func main() { 21 | flag.Parse() 22 | 23 | if pprof { 24 | go http.ListenAndServe(":8080", nil) 25 | } 26 | 27 | var ctl kl.ControlFlow 28 | kl.BindSymbolFunc(kl.MakeSymbol("bc->go"), bcToGo) 29 | kl.BindSymbolFunc(kl.MakeSymbol("make-code-generator"), makeCodeGenerator) 30 | 31 | r := kl.NewSexpReader(os.Stdin, false) 32 | for i := 0; ; i++ { 33 | fmt.Printf("%d #> ", i) 34 | sexp, err := r.Read() 35 | if err != nil { 36 | if err != io.EOF { 37 | fmt.Println("read error:", err) 38 | } 39 | break 40 | } 41 | res := kl.Eval(&ctl, sexp) 42 | fmt.Println(kl.ObjString(res)) 43 | } 44 | } 45 | -------------------------------------------------------------------------------- /compiled/compile-to-go.shen: -------------------------------------------------------------------------------- 1 | (load "../src/compiler.shen") 2 | (set *maximum-print-sequence-size* 100000) 3 | (compile-file "../S39/KLambda/sys.kl" "sys.tmp") 4 | (compile-file "../S39/KLambda/writer.kl" "writer.tmp") 5 | (compile-file "../S39/KLambda/core.kl" "core.tmp") 6 | (compile-file "../S39/KLambda/reader.kl" "reader.tmp") 7 | (compile-file "../S39/KLambda/declarations.kl" "declarations.tmp") 8 | (compile-file "../S39/KLambda/toplevel.kl" "toplevel.tmp") 9 | (compile-file "../S39/KLambda/macros.kl" "macros.tmp") 10 | (compile-file "../S39/KLambda/load.kl" "load.tmp") 11 | (compile-file "../S39/KLambda/prolog.kl" "prolog.tmp") 12 | (compile-file "../S39/KLambda/sequent.kl" "sequent.tmp") 13 | (compile-file "../S39/KLambda/track.kl" "track.tmp") 14 | (compile-file "../S39/KLambda/t-star.kl" "t-star.tmp") 15 | (compile-file "../S39/KLambda/yacc.kl" "yacc.tmp") 16 | (compile-file "../S39/KLambda/types.kl" "types.tmp") 17 | 18 | -------------------------------------------------------------------------------- /S39/Test Programs/unification.shen: -------------------------------------------------------------------------------- 1 | (define unify 2 | X Y -> (unify-loop X Y [])) 3 | 4 | (define unify-loop 5 | X X MGU -> MGU 6 | X Y MGU -> [[X | Y] | MGU] where (and (variable? X) (occurs-check? X Y)) 7 | X Y MGU -> [[Y | X] | MGU] where (and (variable? Y) (occurs-check? Y X)) 8 | [X | Y] [W | Z] MGU -> (let NewMGU (unify-loop X W MGU) 9 | (unify-loop (deref Y NewMGU) 10 | (deref Z NewMGU) 11 | NewMGU)) 12 | _ _ _ -> (error "unification failure")) 13 | 14 | (define occurs-check? 15 | X X -> false 16 | X [Y | Z] -> (and (occurs-check? X Y) (occurs-check? X Z)) 17 | _ _ -> true) 18 | 19 | (define deref 20 | [X | Y] MGU -> (map (/. Term (deref Term MGU)) [X | Y]) 21 | X MGU -> (let Binding (assoc X MGU) 22 | (if (empty? Binding) 23 | X 24 | (deref (tl Binding) MGU)))) 25 | -------------------------------------------------------------------------------- /S39/Lib/Tk/Samples/loadme.shen: -------------------------------------------------------------------------------- 1 | (package calc 2 | 3 | (append (external tk) (internal tk) 4 | [ide.bg .below.f1 .calculator .calculator.buttons .calculator.display 5 | .calculator.buttons.b0 .calculator.buttons.b1 .calculator.buttons.b2 6 | .calculator.buttons.b3 .calculator.buttons.b4 .calculator.buttons.b5 7 | .calculator.buttons.b6 .calculator.buttons.b7 .calculator.buttons.b8 8 | .calculator.buttons.b9 .calculator.buttons.bdot .calculator.buttons.+ 9 | .calculator.buttons.- .calculator.buttons.* .calculator.buttons./ 10 | .calculator.buttons.sqrt .calculator.buttons.cancel .calculator.buttons.lparen 11 | .calculator.buttons.rparen .calculator.buttons.=]) 12 | 13 | (tc -) 14 | (load "C:/Users/shend/OneDrive/Desktop/Shen/S39/Lib/Tk/Samples/wo-types.shen") 15 | (tk.types +) 16 | (tc +) 17 | (load "C:/Users/shend/OneDrive/Desktop/Shen/S39/Lib/Tk/Samples/calculator.shen") 18 | (tk.types -)) -------------------------------------------------------------------------------- /S39/Test Programs/semantic net.shen: -------------------------------------------------------------------------------- 1 | (define query 2 | [is Object Concept] -> (if (belongs? Object Concept) yes no)) 3 | 4 | (define belongs? 5 | Object Concept -> (element? Concept (fix (fn spread-activation) [Object]))) 6 | 7 | (define spread-activation 8 | [] -> [] 9 | [Vertex | Vertices] -> (union (accessible-from Vertex) 10 | (spread-activation Vertices))) 11 | 12 | (define accessible-from 13 | Vertex -> [Vertex | (union (is_links Vertex) (type_links Vertex))]) 14 | 15 | (define is_links 16 | Vertex -> (get-prop Vertex is_a [])) 17 | 18 | (define type_links 19 | Vertex -> (get-prop Vertex type_of [])) 20 | 21 | (define assert 22 | [Object is_a Type] -> (put Object is_a [Type | (is_links Object)]) 23 | [Type1 type_of Type2] -> (put Type1 type_of [Type2 | (type_links Type1)])) 24 | 25 | (define get-prop 26 | Ob Pointer Default -> (trap-error (get Ob Pointer) (/. E Default))) 27 | 28 | (define clear 29 | Ob -> (put Ob is_a (put Ob type_of []))) 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/complex.dtype: -------------------------------------------------------------------------------- 1 | (package complex [c# complex? real imaginary complex] 2 | 3 | (define c# 4 | R I -> (let C (absvector 3) 5 | PrintF (address-> C 0 print-complex) 6 | Rumerator (address-> C 1 R) 7 | Ienominator (address-> C 2 I) 8 | C) where (and (number? R) (number? I)) 9 | R I -> (error "real ~A and imaginary ~A must be numbers~%" R I)) 10 | 11 | (define print-complex 12 | C -> (make-string (cn "(c" "# ~A ~A)") (<-address C 1) (<-address C 2))) 13 | 14 | (define complex? 15 | C -> (trap-error (and (absvector? C) 16 | (= (<-address C 0) print-complex) 17 | (number? (<-address C 1)) 18 | (number? (<-address C 2))) (/. E false))) 19 | 20 | (define real 21 | C -> (<-address C 1)) 22 | 23 | (define imaginary 24 | C -> (<-address C 2)) 25 | 26 | (declare c# [number --> [number --> complex]]) 27 | (declare complex? [A --> boolean]) 28 | (declare real [complex --> number]) 29 | (declare imaginary [complex --> number]) ) 30 | 31 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Tuples/tuples.shen: -------------------------------------------------------------------------------- 1 | (package tuple [pairoff assocp cartprodp assocp-if assocp-if-not] 2 | 3 | (define pairoff 4 | {(list A) --> (list B) --> (list (A * B))} 5 | [] _ -> [] 6 | _ [] -> [] 7 | [X | Y] [W | Z] -> [(@p X W) | (pairoff Y Z)]) 8 | 9 | (define assocp 10 | {A --> (list (A * B)) --> (A * B)} 11 | _ [] -> (error "pair not found~%") 12 | X [(@p X Y) | _] -> (@p X Y) 13 | X [_ | Pairs] -> (assocp X Pairs)) 14 | 15 | (define cartprodp 16 | {(list A) --> (list B) --> (list (A * B))} 17 | [] _ -> [] 18 | [X | Y] Z -> (append (map (/. W (@p X W)) Z) (cartprodp Y Z))) 19 | 20 | (define assocp-if 21 | {(A --> boolean) --> (list (A * B)) --> (A * B)} 22 | _ [] -> (error "pair not found~%") 23 | F? [(@p X Y) | _] -> (@p X Y) where (F? X) 24 | F? [_ | Pairs] -> (assocp-if F? Pairs)) 25 | 26 | (define assocp-if-not 27 | {(A --> boolean) --> (list (A * B)) --> (A * B)} 28 | _ [] -> (error "pair not found~%") 29 | F? [(@p X Y) | _] -> (@p X Y) where (not (F? X)) 30 | F? [_ | Pairs] -> (assocp-if-not F? Pairs)) ) -------------------------------------------------------------------------------- /cmd/shen/main.go: -------------------------------------------------------------------------------- 1 | package main 2 | 3 | import ( 4 | "flag" 5 | "fmt" 6 | "net/http" 7 | _ "net/http/pprof" 8 | 9 | "github.com/tiancaiamao/shen-go/kl" 10 | ) 11 | 12 | var pprof bool 13 | 14 | func init() { 15 | flag.BoolVar(&pprof, "pprof", false, "enable pprof") 16 | } 17 | 18 | func regist(e *kl.ControlFlow) { 19 | for _, init := range []kl.Obj{ 20 | TopLevelMain, 21 | CoreMain, 22 | SysMain, 23 | SequentMain, 24 | YaccMain, 25 | ReaderMain, 26 | PrologMain, 27 | TrackMain, 28 | LoadMain, 29 | WriterMain, 30 | MacrosMain, 31 | DeclarationsMain, 32 | TStarMain, 33 | TypesMain, 34 | } { 35 | res := kl.Call(e, init) 36 | if kl.IsError(res) { 37 | fmt.Println("load ...fail") 38 | } 39 | } 40 | } 41 | 42 | var ns2_1set kl.Obj 43 | var try_1catch kl.Obj 44 | 45 | func main() { 46 | flag.Parse() 47 | 48 | if pprof { 49 | go http.ListenAndServe(":8080", nil) 50 | } 51 | 52 | ns2_1set = kl.PrimFunc(kl.MakeSymbol("defun")) 53 | try_1catch = kl.PrimFunc(kl.MakeSymbol("try-catch")) 54 | 55 | var e kl.ControlFlow 56 | regist(&e) 57 | kl.Eval(&e, kl.Cons(kl.MakeSymbol("shen.shen"), kl.Nil)) 58 | } 59 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/rationals.dtype: -------------------------------------------------------------------------------- 1 | (package rational [r# rational? rational numerator denominator] 2 | 3 | (define r# 4 | N D -> (let V (absvector 3) 5 | PrintF (address-> V 0 print-rational) 6 | Numerator (address-> V 1 N) 7 | Denominator (address-> V 2 D) 8 | V) where (and (integer? N) (integer? D)) 9 | N D -> (error "numerator ~S and divisor ~S must be integers~%" N D)) 10 | 11 | (define print-rational 12 | V -> (make-string "~S/~S" (<-address V 1) (<-address V 2))) 13 | 14 | (define rational? 15 | R -> (trap-error (and (absvector? R) 16 | (= (<-address R 0) print-rational) 17 | (integer? (<-address R 1)) 18 | (integer? (<-address R 2))) (/. E false))) 19 | 20 | (define numerator 21 | V -> (<-address V 1)) 22 | 23 | (define denominator 24 | V -> (<-address V 2)) 25 | 26 | (declare r# [number --> [number --> rational]]) 27 | (declare rational? [A --> boolean]) 28 | (declare numerator [rational --> number]) 29 | (declare denominator [rational --> number]) ) 30 | 31 | -------------------------------------------------------------------------------- /S39/Primitives/arith.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN cl.double-precision (X) 6 | (IF (INTEGERP X) X (COERCE X 'DOUBLE-FLOAT))) 7 | 8 | (DECLAIM (INLINE cl.double-precision)) 9 | 10 | (DEFUN cl.multiply (X Y) 11 | (IF (OR (ZEROP X) (ZEROP Y)) 12 | 0 13 | (* (cl.double-precision X) (cl.double-precision Y)))) 14 | 15 | (DEFUN cl.add (X Y) 16 | (+ (cl.double-precision X) (cl.double-precision Y))) 17 | 18 | (DEFUN cl.subtract (X Y) 19 | (- (cl.double-precision X) (cl.double-precision Y))) 20 | 21 | (DEFUN cl.divide (X Y) 22 | (LET ((Div (/ (cl.double-precision X) 23 | (cl.double-precision Y)))) 24 | (IF (INTEGERP Div) 25 | Div 26 | (* (COERCE 1.0 'DOUBLE-FLOAT) Div)))) 27 | 28 | (DEFUN cl.greater? (X Y) (IF (> X Y) 'true 'false)) 29 | 30 | (DEFUN cl.less? (X Y) (IF (< X Y) 'true 'false)) 31 | 32 | (DEFUN cl.greater-than-or-equal-to? (X Y) 33 | (IF (>= X Y) 'true 'false)) 34 | 35 | (DEFUN cl.less-than-or-equal-to? (X Y) 36 | (IF (<= X Y) 'true 'false)) 37 | 38 | (DEFUN number? (N) (IF (NUMBERP N) 'true 'false)) -------------------------------------------------------------------------------- /compiled/bctogo.shen: -------------------------------------------------------------------------------- 1 | ;; generate go file from bytecode 2 | (put bc->go arity 5) 3 | (let Cg (make-code-generator) 4 | (do 5 | (bc->go Cg "SysMain" false "sys.tmp" "../cmd/shen/sys.go") 6 | (bc->go Cg "WriterMain" false "writer.tmp" "../cmd/shen/writer.go") 7 | (bc->go Cg "CoreMain" false "core.tmp" "../cmd/shen/core.go") 8 | (bc->go Cg "ReaderMain" false "reader.tmp" "../cmd/shen/reader.go") 9 | (bc->go Cg "DeclarationsMain" false "declarations.tmp" "../cmd/shen/declarations.go") 10 | (bc->go Cg "TopLevelMain" false "toplevel.tmp" "../cmd/shen/toplevel.go") 11 | (bc->go Cg "MacrosMain" false "macros.tmp" "../cmd/shen/macros.go") 12 | (bc->go Cg "LoadMain" false "load.tmp" "../cmd/shen/load.go") 13 | (bc->go Cg "PrologMain" false "prolog.tmp" "../cmd/shen/prolog.go") 14 | (bc->go Cg "SequentMain" false "sequent.tmp" "../cmd/shen/sequent.go") 15 | (bc->go Cg "TrackMain" false "track.tmp" "../cmd/shen/track.go") 16 | (bc->go Cg "TStarMain" false "t-star.tmp" "../cmd/shen/t-star.go") 17 | (bc->go Cg "YaccMain" false "yacc.tmp" "../cmd/shen/yacc.go") 18 | (bc->go Cg "TypesMain" true "types.tmp" "../cmd/shen/types.go"))) -------------------------------------------------------------------------------- /S39/Lib/StLib/install.shen: -------------------------------------------------------------------------------- 1 | 2 | (load "Symbols/symbols1.shen") 3 | (tc +) 4 | (load "Symbols/symbols2.shen") 5 | (tc +) 6 | (load "Maths/macros.shen") 7 | (load "Maths/maths.shen") 8 | (tc -) 9 | (load "Maths/rationals.dtype") 10 | (tc +) 11 | (load "Maths/rationals.shen") 12 | (tc -) 13 | (load "Maths/complex.dtype") 14 | (tc +) 15 | (load "Maths/complex.shen") 16 | (tc -) 17 | (load "Maths/numerals.dtype") 18 | (tc +) 19 | (load "Maths/numerals.shen") 20 | (load "Lists/lists.shen") 21 | (load "Strings/macros.shen") 22 | (load "Strings/strings.shen") 23 | (tc -) 24 | (load "Strings/smart.shen") 25 | (load "Vectors/macros.shen") 26 | (load "Encrypt/encrypt.shen") 27 | (tc +) 28 | (load "Vectors/vectors.shen") 29 | (load "IO/prettyprint.shen") 30 | (tc -) 31 | (load "IO/delete-file.shen") 32 | (tc +) 33 | (load "IO/files.shen") 34 | (load "Tuples/tuples.shen") 35 | (tc -) 36 | (load "package-stlib.shen") 37 | 38 | \\ all external functions of the standard library are declared as system functions 39 | (let External (external stlib) 40 | ExternalF (filter (/. X (> (arity X) -1)) External) 41 | Systemf (map (fn systemf) ExternalF) 42 | ok) 43 | 44 | (preclude-all-but []) 45 | (set shen.*userdefs* []) 46 | (cd "") 47 | (tc -) 48 | 49 | -------------------------------------------------------------------------------- /S39/Lib/Tk/macros.shen: -------------------------------------------------------------------------------- 1 | (package tk (external tk) 2 | 3 | (defmacro tk-macro 4 | [widget Widget Class | Slots] -> [my-widget Widget Class (shen.cons-form Slots)] 5 | [pack Widgets | Options] -> [my-pack Widgets (shen.cons-form Options)] 6 | [grid Widgets | Options] -> [my-grid Widgets (shen.cons-form Options)] 7 | [openfile | Options] -> [my-openfile (shen.cons-form Options)] 8 | [opencolour | Options] -> [my-opencolour (shen.cons-form Options)] 9 | [savefile | Options] -> [my-savefile (shen.cons-form Options)] 10 | [messagebox | Options] -> [my-messagebox (shen.cons-form Options)] 11 | [draw Canvas Shape Coordinates | Options] 12 | -> (if (element? -tag Options) 13 | [my-draw Canvas Shape Coordinates (shen.cons-form Options)] 14 | [my-draw Canvas Shape Coordinates 15 | (shen.cons-form [-tag (gensym shape) | Options])]) 16 | [tk-input+ Type] -> [my-tk-input+ (shen.cons-form Type)] 17 | [image Symbol Path | Options] -> [my-image Symbol Path (shen.cons-form Options)] 18 | [font Font | Options] -> [my-font Font (shen.cons-form Options)])) -------------------------------------------------------------------------------- /S39/Test Programs/tableauprolog.shen: -------------------------------------------------------------------------------- 1 | (defprolog prop 2 | A C <-- (proph [[~ C] | A]);) 3 | 4 | (defprolog proph 5 | A <-- (inconsistent A) !; 6 | A <-- (consistent A) ! (when false); 7 | (- [[P & Q] | A]) <-- ! (proph (append A [P Q])); 8 | (- [[P <=> Q] | A]) <-- ! (proph [[P => Q] [Q => P] | A]); 9 | (- [[P => Q] | A]) <-- ! (proph [[[~ P] v Q] | A]); 10 | (- [[P v Q] | A]) <-- ! (proph (append A [P])) ! (proph (append A [Q])); 11 | (- [[~ [~ P]] | A]) <-- ! (proph (append A [P])); 12 | (- [[~ [P v Q]] | A]) <-- ! (proph (append A [[~ P] [~ Q]])); 13 | (- [[~ [P & Q]] | A]) <-- ! (proph [[[~ P] v [~ Q]] | A]); 14 | (- [[~ [P => Q]] | A]) <-- ! (proph (append A [P [~ Q]])); 15 | (- [[~ [P <=> Q]] | A]) <-- ! (proph [[~ [[P => Q] & [Q => P]]] | A]); 16 | (- [P | Ps]) <-- ! (proph (append Ps [P]));) 17 | 18 | (defprolog inconsistent 19 | [P | Ps] <-- (complement P NotP) (member NotP Ps) !; 20 | [_ | Ps] <-- (inconsistent Ps);) 21 | 22 | (defprolog consistent 23 | [] <--; 24 | [P | Ps] <-- (when (symbol? P)) ! (consistent Ps); 25 | [[~ P] | Ps] <-- (when (symbol? P)) (consistent Ps);) 26 | 27 | (defprolog complement 28 | [~ P] P <-- !; 29 | P [~ P] <--;) 30 | 31 | (defprolog member 32 | X (- [X | _]) <--; 33 | X (- [_ | Y]) <-- (member X Y);) -------------------------------------------------------------------------------- /S39/Test Programs/secd1.shen: -------------------------------------------------------------------------------- 1 | (synonyms stack (list ob) 2 | environment (list (symbol * ob)) 3 | control (list ob) 4 | dump (list (stack * environment * control))) 5 | 6 | (datatype ob 7 | 8 | E : environment; X : symbol; Y : ob; 9 | ==================================== 10 | [closure E X Y] : ob; 11 | 12 | X : symbol; Y : ob; 13 | =================== 14 | [lambda X Y] : ob; 15 | 16 | X : ob; Y : ob; 17 | =============== 18 | [X Y] : ob; 19 | 20 | X : symbol; 21 | ___________ 22 | X : ob;) 23 | 24 | (define evaluate 25 | {ob --> ob} 26 | X -> (secd [] [] [X] [])) 27 | 28 | (define secd 29 | {stack --> environment --> control --> dump --> ob} 30 | [V] E [] [] -> V 31 | [V] _ [] [(@p S E C) | D] -> (secd [V | S] E C D) 32 | S E [[lambda X Y] | C] D -> (secd [[closure E X Y] | S] E C D) 33 | S E [[X Y] | C] D -> (secd S E [Y X @ | C] D) 34 | [[closure E* X Y] Z | S] E [@ | C] D -> (secd [] [(@p X Z) | E*] [Y] [(@p S E C) | D]) 35 | S E [X | C] D ->(if (bnd? X E) (secd [(lookup X E) | S] E C D) (secd [X | S] E C D))) 36 | 37 | (define bnd? 38 | {ob --> environment --> boolean} 39 | X [] -> false 40 | X [(@p Y _) | _] -> true where (== X Y) 41 | X [_ | Y] -> (bnd? X Y)) 42 | 43 | (define lookup 44 | {ob --> environment --> ob} 45 | X [] -> X 46 | X [(@p Y Z) | _] -> Z where (== X Y) 47 | X [_ | Y] -> (lookup X Y)) 48 | 49 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017-2020 Arthur Mao 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions 6 | are met: 7 | 1. Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 2. Redistributions in binary form must reproduce the above copyright 10 | notice, this list of conditions and the following disclaimer in the 11 | documentation and/or other materials provided with the distribution. 12 | 3. The name of the author may not be used to endorse or promote products 13 | derived from this software without specific prior written permission. 14 | 15 | THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR 16 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES 17 | OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. 18 | IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, 19 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 20 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 21 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 22 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 23 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF 24 | THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /S39/Test Programs/spreadsheet.shen: -------------------------------------------------------------------------------- 1 | (define assess-spreadsheet 2 | Spreadsheet -> (map (/. Row (assign-fixed-values Row Spreadsheet)) 3 | Spreadsheet)) 4 | 5 | (define assign-fixed-values 6 | [Index | Cells] Spreadsheet 7 | -> [Index | (map (/. Cell (assign-cell-value Cell Spreadsheet)) Cells)]) 8 | 9 | (define assign-cell-value 10 | [Attribute Value] _ -> [Attribute Value] where (fixed-value? Value) 11 | [Attribute Value] Spreadsheet -> [Attribute (Value Spreadsheet)]) 12 | 13 | (define fixed-value? 14 | \* number?, symbol? and string? are system functions - see appendix A *\ 15 | Value -> (or (number? Value) (or (symbol? Value) (string? Value)))) 16 | 17 | (define get' 18 | \* spreads the spreadsheet! *\ 19 | Index Attribute Spreadsheet 20 | -> (get-row Index Attribute Spreadsheet Spreadsheet)) 21 | 22 | (define get-row 23 | \* looks for the right row using the index *\ 24 | Index Attribute [[Index | Cells] | _] Spreadsheet 25 | -> (get-cell Attribute Cells Spreadsheet) 26 | Index Attribute [_ | Rows] Spreadsheet 27 | -> (get-row Index Attribute Rows Spreadsheet) 28 | Index _ _ _ -> (error "Index ~A not found" Index)) 29 | 30 | (define get-cell 31 | Attribute [[Attribute Value] | _] Spreadsheet 32 | -> (if (fixed-value? Value) Value (Value Spreadsheet)) 33 | Attribute [_ | Cells] Spreadsheet 34 | -> (get-cell Attribute Cells Spreadsheet) 35 | Attribute _ _ -> (error "Attribute ~A not found" Attribute)) -------------------------------------------------------------------------------- /S39/Test Programs/einsteins-riddle.shen: -------------------------------------------------------------------------------- 1 | (defprolog riddle 2 | <-- (house A) (house B) (house C) (house D) (house E) (is Houses [A B C D E]) 3 | (member [brit _ _ _ red] Houses) 4 | (member [swede dog _ _ _] Houses) 5 | (member [dane _ _ tea _] Houses) 6 | (left [_ _ _ _ green] [_ _ _ _ white] Houses) 7 | (member [_ _ _ coffee green] Houses) 8 | (member [_ bird pallmall _ _] Houses) 9 | (member [_ _ dunhill _ yellow] Houses) 10 | (is C [_ _ _ milk _]) 11 | (is A [norwegian _ _ _ _]) 12 | (next [_ _ blends _ _] [_ cat _ _ _] Houses) 13 | (next [_ horse _ _ _] [_ _ dunhill _ _] Houses) 14 | (member [_ _ bluemaster beer _] Houses) 15 | (member [german _ prince _ _] Houses) 16 | (next [norwegian _ _ _ _] [_ _ _ _ blue] Houses) 17 | (next [_ _ blends _ _] [_ _ _ water _] Houses) 18 | (who-owns-the-fish? Nationality Houses);) 19 | 20 | (defprolog member 21 | X (- [X | _]) <--; 22 | X (- [_ | Z]) <-- (member X Z);) 23 | 24 | (defprolog house 25 | [Nationality Pet Cigarette Drink Colour] <--;) 26 | 27 | (defprolog next 28 | X Y List <-- (left X Y List); 29 | X Y List <-- (left Y X List);) 30 | 31 | 32 | (defprolog left 33 | L R (- [L R | _]) <--; 34 | L R (- [_ | Houses]) <-- (left L R Houses);) 35 | 36 | (defprolog who-owns-the-fish? 37 | Nationality Houses <-- (member [Nationality fish _ _ _] Houses) 38 | (return Nationality);) -------------------------------------------------------------------------------- /S39/Test Programs/lisp.shen: -------------------------------------------------------------------------------- 1 | (defcc 2 | {(list number) ==> (list sexpr)} 3 | := [ | ]; 4 | := [];) 5 | 6 | (defcc 7 | {(list number) ==> sexpr} 8 | := ; 9 | ;) 10 | 11 | (defcc 12 | {(list number) ==> symbol} 13 | 40 := skip;) 14 | 15 | (defcc 16 | {(list number) ==> symbol} 17 | 41 := skip;) 18 | 19 | (defcc 20 | {(list number) ==> symbol} 21 | := skip; 22 | := skip;) 23 | 24 | (defcc 25 | {(list number) ==> symbol} 26 | 9 := skip; 27 | 10 := skip; 28 | 13 := skip; 29 | 32 := skip;) 30 | 31 | (defcc 32 | {(list number) ==> atom} 33 | ; ; ;) 34 | 35 | (defcc 36 | {(list number) ==> string} 37 | := ;) 38 | 39 | (defcc 40 | {(list number) ==> string} 41 | := (cn ); 42 | := "";) 43 | 44 | (defcc 45 | {(list number) ==> string} 46 | Byte := (n->string Byte) where (not (= Byte 34));) 47 | 48 | (defcc 49 | {(list number) ==> string} 50 | Byte := (n->string Byte) where (not (= Byte 34));) 51 | 52 | 53 | (datatype sexpr 54 | 55 | S : string; 56 | ____________ 57 | S : sexpr; 58 | 59 | S : symbol; 60 | ___________ 61 | S : sexpr; 62 | 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /S39/README.txt: -------------------------------------------------------------------------------- 1 | To install under SBCL/Windows *without* TCL/tk 2 | ____________________________________________ 3 | 4 | Start SBCL 5 | 6 | Enter (load "install.lsp"). 7 | 8 | The executable sbcl-shen.exe will be created. 9 | 10 | To install under SBCL/Windows *with* TCL/tk 11 | ____________________________________________ 12 | 13 | To run Shen/tk under Windows; install TCL/tk. 14 | 15 | Enter (load "install-tk.lsp"). 16 | 17 | The executable sbcl-shen+tk.exe will be created. 18 | 19 | Edit the file shen-tk.bat and replace the pathnames in 20 | the second line to those suitable for your installation. 21 | **Click on this batch file to invoke Shen/tk.** 22 | 23 | Now go to Lib and look in the file Tk/root.tcl. You will see two lines. 24 | 25 | set in {C:/Users/shend/OneDrive/Desktop/Shen/S39/shen-to-tcl.txt} 26 | set out {C:/Users/shend/OneDrive/Desktop/Shen/S39/tcl-to-shen.txt} 27 | 28 | Change the pathnames to your installation. 29 | 30 | IMPORTANT! 31 | ******************************************************* 32 | Note before quitting Shen/tk you should click on the 33 | exit button in the IDE and confirm you want to exit 34 | before shutting down the command window and root window. 35 | This will give a clean shutdown. 36 | ******************************************************* 37 | 38 | Failure to do this will leave a zombie TCL process that 39 | will definitely interfere with your next session. In 40 | that event you will have to kill that process in the task 41 | manager. -------------------------------------------------------------------------------- /S39/Sources/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2021, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. The name of Mark Tarver may not be used to endorse or promote products 14 | derived from this software without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 17 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 20 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 23 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /S39/Primitives/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2010-2021, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. The name of Mark Tarver may not be used to endorse or promote products 14 | derived from this software without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 17 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 20 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 23 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.c#34; -------------------------------------------------------------------------------- /S39/Lib/LICENSE: -------------------------------------------------------------------------------- 1 | Shen Library 2.0; Copyright (c) 2010-2021, Mark Tarver 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 2. Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in the 12 | documentation and/or other materials provided with the distribution. 13 | 3. The name of Mark Tarver may not be used to endorse or promote products 14 | derived from this software without specific prior written permission. 15 | 16 | THIS SOFTWARE IS PROVIDED BY Mark Tarver ''AS IS'' AND ANY 17 | EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 18 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 19 | DISCLAIMED. IN NO EVENT SHALL Mark Tarver BE LIABLE FOR ANY 20 | DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES 21 | (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; 22 | LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND 23 | ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 24 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 25 | SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/complex.shen: -------------------------------------------------------------------------------- 1 | (package complex (append [c+ c- c* c/] (external complex) (external maths)) 2 | 3 | (define c+ 4 | {complex --> complex --> complex} 5 | C1 C2 -> (let A (real C1) 6 | B (imaginary C1) 7 | C (real C2) 8 | D (imaginary C2) 9 | (c# (+ A C) (+ B D)))) 10 | 11 | (define c- 12 | {complex --> complex --> complex} 13 | C1 C2 -> (let A (real C1) 14 | B (imaginary C1) 15 | C (real C2) 16 | D (imaginary C2) 17 | (c# (- A C) (- B D)))) 18 | 19 | (define c* 20 | {complex --> complex --> complex} 21 | C1 C2 -> (let A (real C1) 22 | B (imaginary C1) 23 | C (real C2) 24 | D (imaginary C2) 25 | (c# (- (* A C) (* B D)) (+ (* B C) (* A D))))) 26 | 27 | (define c/ 28 | {complex --> complex --> complex} 29 | C1 C2 -> (let A (real C1) 30 | B (imaginary C1) 31 | C (real C2) 32 | D (imaginary C2) 33 | (c# (/ (+ (* A C) (* B D)) 34 | (+ (* C C) (* D D))) 35 | (/ (- (* B C) (* A D)) 36 | (+ (* C C) (* D D)))))) 37 | 38 | ) -------------------------------------------------------------------------------- /S39/Test Programs/n queens.shen: -------------------------------------------------------------------------------- 1 | (package n-queens [n-queens] 2 | 3 | (define n-queens 4 | {number --> (list (list number))} 5 | N -> (n-queens-loop N (initialise N))) 6 | 7 | (define initialise 8 | {number --> (list number)} 9 | 0 -> [] 10 | N -> [1 | (initialise (- N 1))]) 11 | 12 | (define n-queens-loop 13 | {number --> (list number) --> (list (list number))} 14 | N Config -> [] where (all_Ns? N Config) 15 | N Config -> [Config | (n-queens-loop N (next_n N Config))] 16 | where (and (ok_row? Config) (ok_diag? Config)) 17 | N Config -> (n-queens-loop N (next_n N Config))) 18 | 19 | (define all_Ns? 20 | {number --> (list number) --> boolean} 21 | _ [] -> true 22 | N [N | Ns] -> (all_Ns? N Ns) 23 | _ _ -> false) 24 | 25 | (define next_n 26 | {number --> (list number) --> (list number)} 27 | N [N | Ns] -> [1 | (next_n N Ns)] 28 | _ [N | Ns] -> [(+ 1 N) | Ns]) 29 | 30 | (define ok_row? 31 | {(list number) --> boolean} 32 | [] -> true 33 | [N | Ns] -> false where (element? N Ns) 34 | [_ | Ns] -> (ok_row? Ns)) 35 | 36 | (define ok_diag? 37 | {(list number) --> boolean} 38 | [] -> true 39 | [N | Ns] -> (and (ok_diag_N? (+ N 1) (- N 1) Ns) 40 | (ok_diag? Ns))) 41 | 42 | (define ok_diag_N? 43 | {number --> number --> (list number) --> boolean} 44 | _ _ [] -> true 45 | Up Down [Up | _] -> false 46 | Up Down [Down | _] -> false 47 | Up Down [_ | Ns] -> (ok_diag_N? (+ 1 Up) (- Down 1) Ns))) 48 | -------------------------------------------------------------------------------- /S39/Test Programs/n queens-r.shen: -------------------------------------------------------------------------------- 1 | (package n-queens [n-queens] 2 | 3 | (define n-queens 4 | {number --> (list (list number))} 5 | N -> (n-queens-loop N (initialise N))) 6 | 7 | (define initialise 8 | {number --> (list number)} 9 | 0 -> [] 10 | N -> [1 | (initialise (- N 1))]) 11 | 12 | (define n-queens-loop 13 | {number --> (list number) --> (list (list number))} 14 | N Config -> [] where (all_Ns? N Config) 15 | N Config -> [Config | (n-queens-loop N (next_n N Config))] 16 | where (and (ok_row? Config) (ok_diag? Config)) 17 | N Config -> (n-queens-loop N (next_n N Config))) 18 | 19 | (define all_Ns? 20 | {number --> (list number) --> boolean} 21 | _ [] -> true 22 | N [N | Ns] -> (all_Ns? N Ns) 23 | _ _ -> false) 24 | 25 | (define next_n 26 | {number --> (list number) --> (list number)} 27 | N [N | Ns] -> [1 | (next_n N Ns)] 28 | _ [N | Ns] -> [(+ 1 N) | Ns]) 29 | 30 | (define ok_row? 31 | {(list number) --> boolean} 32 | [] -> true 33 | [N | Ns] -> false where (element? N Ns) 34 | [_ | Ns] -> (ok_row? Ns)) 35 | 36 | (define ok_diag? 37 | {(list number) --> boolean} 38 | [] -> true 39 | [N | Ns] -> (and (ok_diag_N? (+ N 1) (- N 1) Ns) 40 | (ok_diag? Ns))) 41 | 42 | (define ok_diag_N? 43 | {number --> number --> (list number) --> boolean} 44 | _ _ [] -> true 45 | Up Down [Up | _] -> false 46 | Up Down [Down | _] -> false 47 | Up Down [_ | Ns] -> (ok_diag_N? (+ 1 Up) (- Down 1) Ns)) 48 | 49 | ) 50 | -------------------------------------------------------------------------------- /S39/Primitives/str.lsp: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2021, Mark Tarver 2 | 3 | 3 clause BSD; see license" 4 | 5 | (DEFUN str (X) 6 | (COND ((NULL X) (ERROR "[] is not an atom in cl; str cannot convert it to a string.~%")) 7 | ((SYMBOLP X) 8 | (cl.process-string (SYMBOL-NAME X))) 9 | ((NUMBERP X) 10 | (cl.process-number (FORMAT NIL "~A" X))) 11 | ((STRINGP X) (FORMAT NIL "~S" X)) 12 | ((STREAMP X) (FORMAT NIL "~A" X)) 13 | ((FUNCTIONP X) (FORMAT NIL "~A" X)) 14 | (T (ERROR "~S is not an atom, stream or closure; str cannot convert it to a string.~%" X)))) 15 | 16 | (DEFUN cl.process-number (S) 17 | (COND ((STRING-EQUAL S "") "") 18 | ((STRING-EQUAL (pos S 0) "d") 19 | (IF (STRING-EQUAL (pos S 1) "0") 20 | "" 21 | (cn "e" (tlstr S)))) 22 | (T (cn (pos S 0) (cl.process-number (tlstr S)))))) 23 | 24 | (DEFUN cl.process-string (X) 25 | (COND ((STRING-EQUAL X "") X) 26 | ((AND (> (LENGTH X) 8) 27 | (STRING-EQUAL X "_hash1957" :END1 9)) 28 | (cn "#" (cl.process-string (SUBSEQ X 9)))) 29 | ((AND (> (LENGTH X) 9) 30 | (STRING-EQUAL X "_quote1957" :END1 10)) 31 | (cn "'" (cl.process-string (SUBSEQ X 10)))) 32 | ((AND (> (LENGTH X) 13) 33 | (STRING-EQUAL X "_backquote1957" :END1 14)) 34 | (cn "`" (cl.process-string (SUBSEQ X 14)))) 35 | ((AND (> (LENGTH X) 7) 36 | (STRING-EQUAL X "bar!1957" :END1 8)) 37 | (cn "|" (cl.process-string (SUBSEQ X 8)))) 38 | (T (cn (pos X 0) (cl.process-string (tlstr X)))))) -------------------------------------------------------------------------------- /S39/Test Programs/strings.shen: -------------------------------------------------------------------------------- 1 | (define subst-string 2 | {string --> string --> string --> string} 3 | _ _ "" -> "" 4 | Rep (@s S Ss) (@s S Ss') <- (fail-if (= "failed!") (subst-string' Rep Ss Ss')) 5 | Rep Rem (@s S Ss) -> (@s S (subst-string Rep Rem Ss))) 6 | 7 | (define subst-string' 8 | {string --> string --> string --> string} 9 | Rep "" Ss -> (@s Rep Ss) 10 | Rep (@s S Ss) (@s S Ss') -> (subst-string' Rep Ss Ss') 11 | _ _ _ -> "failed!") 12 | 13 | (define rwilli 14 | {string --> string} 15 | "" -> "" 16 | (@s "Willi" Ss) -> (rwilli Ss) 17 | (@s _ Ss) -> (rwilli Ss)) 18 | 19 | (define strlen 20 | {string --> number} 21 | "" -> 0 22 | (@s _ S) -> (+ 1 (strlen S))) 23 | 24 | (define trim-string-left 25 | {(list string) --> string --> string} 26 | _ "" -> "" 27 | Trim (@s S Ss) -> (@s S Ss) where (not (element? S Trim)) 28 | Trim (@s _ Ss) -> (trim-string-left Trim Ss)) 29 | 30 | (define trim-string-right 31 | {(list string) --> string --> string} 32 | Trim S -> (reverse-string (trim-string-left Trim (reverse-string S)))) 33 | 34 | (define trim-string 35 | {(list string) --> string --> string} 36 | Trim S -> (reverse-string (trim-string-left Trim (reverse-string (trim-string-left Trim S))))) 37 | 38 | (define reverse-string 39 | {string --> string} 40 | "" -> "" 41 | (@s S Ss) -> (@s (reverse-string Ss) S)) 42 | 43 | (define alldigits? 44 | {string --> boolean} 45 | "" -> true 46 | (@s S Ss) -> (and (digit? S) (alldigits? Ss))) 47 | 48 | (define digit? 49 | {string --> boolean} 50 | S -> (element? S ["0" "1" "2" "3" "4" "5" "6" "7" "8" "9"])) -------------------------------------------------------------------------------- /S39/Test Programs/n queens.kl: -------------------------------------------------------------------------------- 1 | (defun n-queens (V13470) (n-queens.n-queens-loop V13470 (n-queens.initialise V13470))) 2 | 3 | (defun n-queens.initialise (V13471) (cond ((= 0 V13471) ()) (true (cons 1 (n-queens.initialise (- V13471 1)))))) 4 | 5 | (defun n-queens.n-queens-loop (V13472 V13473) (cond ((n-queens.all_Ns? V13472 V13473) ()) ((and (n-queens.ok_row? V13473) (n-queens.ok_diag? V13473)) (cons V13473 (n-queens.n-queens-loop V13472 (n-queens.next_n V13472 V13473)))) (true (n-queens.n-queens-loop V13472 (n-queens.next_n V13472 V13473))))) 6 | 7 | (defun n-queens.all_Ns? (V13481 V13482) (cond ((= () V13482) true) ((and (cons? V13482) (= V13481 (hd V13482))) (n-queens.all_Ns? (hd V13482) (tl V13482))) (true false))) 8 | 9 | (defun n-queens.next_n (V13486 V13487) (cond ((and (cons? V13487) (= V13486 (hd V13487))) (cons 1 (n-queens.next_n (hd V13487) (tl V13487)))) ((cons? V13487) (cons (+ 1 (hd V13487)) (tl V13487))) (true (shen.f-error n-queens.next_n)))) 10 | 11 | (defun n-queens.ok_row? (V13490) (cond ((= () V13490) true) ((and (cons? V13490) (element? (hd V13490) (tl V13490))) false) ((cons? V13490) (n-queens.ok_row? (tl V13490))) (true (shen.f-error n-queens.ok_row?)))) 12 | 13 | (defun n-queens.ok_diag? (V13491) (cond ((= () V13491) true) ((cons? V13491) (and (n-queens.ok_diag_N? (+ (hd V13491) 1) (- (hd V13491) 1) (tl V13491)) (n-queens.ok_diag? (tl V13491)))) (true (shen.f-error n-queens.ok_diag?)))) 14 | 15 | (defun n-queens.ok_diag_N? (V13504 V13505 V13506) (cond ((= () V13506) true) ((and (cons? V13506) (= V13504 (hd V13506))) false) ((and (cons? V13506) (= V13505 (hd V13506))) false) ((cons? V13506) (n-queens.ok_diag_N? (+ 1 V13504) (- V13505 1) (tl V13506))) (true (shen.f-error n-queens.ok_diag_N?)))) 16 | 17 | -------------------------------------------------------------------------------- /S39/Test Programs/classes-untyped.shen: -------------------------------------------------------------------------------- 1 | (define defclass 2 | Class Attributes 3 | -> (let Assoc (map (/. Attribute [Attribute | fail]) Attributes) 4 | ClassDef [[class | Class] | Assoc] 5 | Store (put Class classdef ClassDef) 6 | Class)) 7 | 8 | (define make-instance 9 | Class -> (let ClassDef (trap-error (get Class classdef) (/. E [])) 10 | (if (empty? ClassDef) 11 | (error "class ~A does not exist~%" Class) 12 | ClassDef))) 13 | 14 | (define get-value 15 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 16 | (get-value-test LookUp))) 17 | 18 | (define get-value-test 19 | [ ] -> (error "no such attribute!~%") 20 | [_ | fail] -> (error "no such value!~%") 21 | [_ | Value] -> Value) 22 | 23 | (define has-value? 24 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 25 | (has-value-test LookUp))) 26 | 27 | (define has-value-test 28 | [ ] -> (error "no such attribute!~%") 29 | [_ | fail] -> false 30 | _ -> true) 31 | 32 | (define has-attribute? 33 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 34 | (not (empty? LookUp)))) 35 | 36 | (define change-value 37 | _ class _ -> (error "cannot change the class of an instance!~%") 38 | [ ] _ _ -> (error "no such attribute!~%") 39 | [[Attribute | _] | Instance] Attribute Value 40 | -> [[Attribute | Value] | Instance] 41 | [Slot | Instance] Attribute Value 42 | -> [Slot | (change-value Instance Attribute Value)]) 43 | 44 | (define instance-of 45 | [[class | Class] | _] -> Class 46 | _ -> (error "not a class instance!")) 47 | -------------------------------------------------------------------------------- /S39/Lib/patches-scheme.shen: -------------------------------------------------------------------------------- 1 | (put shen shen.external-symbols (difference (get shen shen.external-symbols) 2 | [warn included datatypes tracked userdefs tc? spy? step? occurs? factorise? hush? optimise? system-S?] )) 3 | (declare p.cores [--> number]) 4 | 5 | (declare thread [[lazy A] --> thread]) 6 | (declare tc? [--> boolean]) 7 | (declare spy? [--> boolean]) 8 | (declare step? [--> boolean]) 9 | (declare occurs? [--> boolean]) 10 | (declare factorise? [--> boolean]) 11 | (declare hush? [--> boolean]) 12 | (declare optimise? [--> boolean]) 13 | (declare system-S? [--> boolean]) 14 | (declare userdefs [--> [list symbol]]) 15 | (declare tracked [--> [list symbol]]) 16 | (declare datatypes [--> [list symbol]]) 17 | (declare included [--> [list symbol]]) 18 | (declare step? [--> boolean]) 19 | 20 | (define datatypes 21 | -> (map (/. X (shen.typename X)) (value shen.*alldatatypes*))) 22 | 23 | (define included 24 | -> (map (/. X (shen.typename X)) (value shen.*datatypes*))) 25 | 26 | (define userdefs 27 | -> (value shen.*userdefs*)) 28 | 29 | (define optimise? 30 | -> (value shen.*optimise*)) 31 | 32 | (define hush? 33 | -> (value *hush*)) 34 | 35 | (define system-S? 36 | -> (value shen.*shen-type-theory-enabled?*)) 37 | 38 | (define tc? 39 | -> (value shen.*tc*)) 40 | 41 | (define occurs? 42 | -> (value shen.*occurs*)) 43 | 44 | (define factorise? 45 | -> (value shen.*factorise?*)) 46 | 47 | (define tracked 48 | -> (value shen.*tracking*)) 49 | 50 | (define spy? 51 | -> (value shen.*spy*)) 52 | 53 | (define step? 54 | -> (value shen.*step*)) 55 | 56 | (map (fn systemf) [included datatypes tracked userdefs tc? spy? step? occurs? factorise? hush? optimise? system-S? step?]) -------------------------------------------------------------------------------- /S39/Test Programs/parser.shen: -------------------------------------------------------------------------------- 1 | (define parse 2 | Sentence -> (let Parse (sent [Sentence []]) 3 | (if (parsed? Parse) 4 | (output_parse Parse) 5 | ungrammatical))) 6 | 7 | (define parsed? 8 | [[] _] -> true 9 | _ -> false) 10 | 11 | (define output_parse 12 | [_ Parse_Rules] -> (reverse Parse_Rules)) 13 | 14 | (define sent 15 | [Input Output] <- (vp (np [Input [[sent --> np vp] | Output]])) 16 | _ -> (fail)) 17 | 18 | (define np 19 | [Input Output] <- (n (det [Input [[np --> det n] | Output]])) 20 | [Input Output] <- (name [Input [[np --> name] | Output]]) 21 | _ -> (fail)) 22 | 23 | (define name 24 | [["John" | Input] Output] -> [Input [[name --> "John"] | Output]] 25 | [["Bill" | Input] Output] -> [Input [[name --> "Bill"] | Output]] 26 | _ -> (fail)) 27 | 28 | (define det 29 | [["the" | Input] Output] -> [Input [[det --> "the"] | Output]] 30 | [["a" | Input] Output] -> [Input [[det --> "a"] | Output]] 31 | [["that" | Input] Output] -> [Input [[det --> "that"] | Output]] 32 | [["this" | Input] Output] -> [Input [[det --> "this"] | Output]] 33 | _ -> (fail)) 34 | 35 | (define n 36 | [["boy" | Input] Output] -> [Input [[n --> "boy"] | Output]] 37 | [["girl" | Input] Output] -> [Input [[n --> "girl"] | Output]] 38 | _ -> (fail)) 39 | 40 | (define vp 41 | [Input Output] <- (np (vtrans [Input [[vp --> vtrans np] | Output]])) 42 | [Input Output] <- (vp [Input [[vp --> vintrans] | Output]]) 43 | _ -> (fail)) 44 | 45 | (define vtrans 46 | [["kicks" | Input] Output] -> [Input [[vtrans --> "kicks"] | Output]] 47 | [["likes" | Input] Output] -> [Input [[vtrans --> "likes"] | Output]] 48 | _ -> (fail)) 49 | 50 | (define vintrans 51 | [["jumps" | Input] Output] -> [Input [[vintrans --> "jumps"] | Output]] 52 | _ -> (fail)) -------------------------------------------------------------------------------- /S39/Test Programs/prolog.shen: -------------------------------------------------------------------------------- 1 | (defprolog prop 2 | A C <-- (proph [[~ C] | A]);) 3 | 4 | (defprolog proph 5 | A <-- (mem [~ P] A) (mem P A) !; 6 | A <-- (consistent A) ! (when false); 7 | (mode [[P & Q] | A] -) <-- ! (proph [P Q | A]); 8 | (mode [[P <=> Q] | A] -) <-- ! (proph [[P => Q] [Q => P] | A]); 9 | (mode [[P => Q] | A] -) <-- ! (proph [[[~ P] v Q] | A]); 10 | (mode [[~ [P v Q]] | A] -) <-- ! (proph [[~ P] [~ Q] | A]); 11 | (mode [[~ [P & Q]] | A] -) <-- ! (proph [[[~ P] v [~ Q]] | A]); 12 | (mode [[~ [P => Q]] | A] -) <-- ! (proph [P [~ Q] | A]); 13 | (mode [[~ [P <=> Q]] | A] -) <-- ! (proph [[~ [[P => Q] v [~ [Q => P]]]] | A]); 14 | (mode [[P & Q] | A] -) <-- ! (proph [P Q | A]); 15 | (mode [[P v Q] | A] -) <-- ! (proph [P | A]) ! (proph [Q | A]); 16 | (mode [P | Ps] -) <-- (app Ps [P] Qs) ! (proph Qs);) 17 | 18 | (defprolog consistent 19 | [] <--; 20 | [P | Ps] <-- (when (symbol? P)) ! (consistent Ps); 21 | [[~ P] | Ps] <-- (when (symbol? P)) ! (consistent Ps);) 22 | 23 | (defprolog app 24 | [] X X <--; 25 | (mode [X | Y] -) W [X | Z] <-- (app Y W Z);) 26 | 27 | (defprolog mem 28 | X (mode [X | _] -) <--; 29 | X (mode [_ | Y] -) <-- (mem X Y);) 30 | 31 | (defprolog mapit 32 | _ [] [] <--; 33 | Pred [X | Y] [W | Z] <-- (call (Pred X W)) (mapit Pred Y Z);) 34 | 35 | (defprolog consit 36 | X [1 X] <--;) 37 | 38 | (defprolog different 39 | X Y <-- (not! (is X Y));) 40 | 41 | (defprolog not! 42 | P <-- (call P) ! (when false); 43 | _ <--;) 44 | 45 | (defprolog likes 46 | john X <-- (tall X) (pretty X);) 47 | 48 | (defprolog tall 49 | mary <--;) 50 | 51 | (defprolog pretty 52 | mary <--;) -------------------------------------------------------------------------------- /S39/Test Programs/structures-untyped.shen: -------------------------------------------------------------------------------- 1 | (define defstruct 2 | Name Attributes -> (let Selectors (selectors Name Attributes) 3 | Constructor (constructor Name Attributes) 4 | Recognisor (recognisor Name) 5 | Name)) 6 | 7 | (define selectors 8 | Name Attributes -> (map (/. A (selector Name A)) Attributes)) 9 | 10 | (define selector 11 | Name Attribute 12 | -> (let SelectorName (concat Name (concat - Attribute)) 13 | (eval [define SelectorName 14 | (protect Structure) -> [let (protect LookUp) [assoc Attribute (protect Structure)] 15 | [if [empty? (protect LookUp)] 16 | [error "~A is not an attribute of ~A.~%" 17 | Attribute Name] 18 | [tail (protect LookUp)]]]]))) 19 | 20 | (define constructor 21 | Name Attributes 22 | -> (let ConstructorName (concat make- Name) 23 | Parameters (params Attributes) 24 | (eval [define ConstructorName | 25 | (append Parameters 26 | [-> [cons [cons structure Name] 27 | (make-association-list Attributes 28 | Parameters)]])]))) 29 | 30 | (define params 31 | [] -> [] 32 | [_ | Attributes] -> [(gensym (protect X)) | (params Attributes)]) 33 | 34 | (define make-association-list 35 | [] [] -> [] 36 | [A | As] [P | Ps] -> [cons [cons A P] (make-association-list As Ps)]) 37 | 38 | (define recognisor 39 | Name -> (let RecognisorName (concat Name ?) 40 | (eval [define RecognisorName 41 | [cons [cons structure Name] _] -> true 42 | _ -> false]))) -------------------------------------------------------------------------------- /S39/Lib/Tk/root.tcl: -------------------------------------------------------------------------------- 1 | # TCL event loop 2 | 3 | set in {C:/Users/drmta/OneDrive/Desktop/Shen/S39/shen-to-tcl.txt} 4 | set out {C:/Users/drmta/OneDrive/Desktop/Shen/S39/tcl-to-shen.txt} 5 | set myloop 1 6 | 7 | proc eventloop {File} { 8 | global myloop 9 | while { $myloop } { 10 | after 10 11 | if { [newcommand? $File] } { 12 | enact $File } 13 | update }} 14 | 15 | proc newcommand? {File} { 16 | set Source [open $File r] 17 | set Data [read $Source] 18 | set Verdict [eot? $Data] 19 | close $Source 20 | return $Verdict} 21 | 22 | proc eot? {S} { 23 | return [ string match *eot $S ] 24 | } 25 | 26 | proc enact {File} { 27 | set Source [open $File r] 28 | set Data [read $Source] 29 | close $Source 30 | set Command [trim $Data] 31 | if { [catch $Command result] != 0 } then { 32 | err $result} 33 | overwrite $File} 34 | 35 | proc overwrite {File} { 36 | set Sink [open $File w] 37 | puts -nonewline $Sink "" 38 | flush $Sink 39 | close $Sink} 40 | 41 | proc trim {S} { 42 | return [string map {"eot" ""} $S] 43 | } 44 | 45 | proc mysend {String} { 46 | global out 47 | set Sink [open $out w] 48 | puts $Sink [concat $String "eot"] 49 | close $Sink} 50 | 51 | proc err {String} { 52 | set Format [myformat $String] 53 | mysend [concat "(error \"" $Format "\")"]} 54 | 55 | proc url {String} { 56 | set data [url_help $String] 57 | #set result [format "\"%s\"" $data] 58 | mysend $data} 59 | 60 | proc url_help {String} { 61 | package require http 62 | package require tls 63 | ::http::register https 443 [list ::tls::socket -request 1 -ssl2 0 -ssl3 0 -tls1 1 -cafile VeriSignClass3SecureServerCA-G3.crt] 64 | set token [::http::geturl $String] 65 | upvar #0 $token state 66 | set result $state(body) 67 | ::http::cleanup $token 68 | return $result} 69 | 70 | proc myformat {String} { 71 | return [string map {\" ""} $String]} 72 | 73 | overwrite $in 74 | overwrite $out 75 | eventloop $in -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/numerals.dtype: -------------------------------------------------------------------------------- 1 | (package numerals (append (external maths) [numeral? numeral radix n#->ns n# n#->n]) 2 | 3 | (define n# 4 | N Radix -> (let Vector (absvector 4) 5 | PrintV (address-> Vector 0 print-numeral) 6 | NumbersV (address-> Vector 1 (n->numeral N Radix)) 7 | BaseV (address-> Vector 2 Radix) 8 | NV (address-> Vector 3 N) 9 | Vector) where (and (natural? N) (natural? Radix) (> Radix 0)) 10 | N Radix -> (error "N = ~A, Radix = ~A; N and Radix must be natural numbers where Radix > 0~%" 11 | N Radix)) 12 | 13 | (define radix 14 | Numeral -> (<-address Numeral 2)) 15 | 16 | (define numerals 17 | Numeral -> (<-address Numeral 1)) 18 | 19 | (define n#->n 20 | Numeral -> (<-address Numeral 3)) 21 | 22 | (declare radix [numeral --> number]) 23 | (declare n#->ns [numeral --> [list number]]) 24 | (declare n#->n [numeral --> number]) 25 | (declare n# [number --> [number --> numeral]]) 26 | (declare numeral? [A --> boolean]) 27 | 28 | (define n#->ns 29 | Numeral -> (<-address Numeral 1)) 30 | 31 | (define print-numeral 32 | Numeral -> (let Base (radix Numeral) 33 | Ns (numerals Numeral) 34 | (@s (numeric->string Ns Base) "#" (str Base)))) 35 | 36 | (define numeric->string 37 | {(list number) --> number --> string} 38 | [] _ -> "" 39 | [N | Ns] Base -> (let Char (cases (< N 10) (str N) 40 | (> Base 36) (cn (str N) " ") 41 | true (n->string (+ N 55))) 42 | (cn Char (numeric->string Ns Base)))) 43 | 44 | (define numeral? 45 | Num -> (and (absvector? Num) (= print-numeral (<-address Num 0)))) 46 | 47 | ) -------------------------------------------------------------------------------- /S39/Lib/StLib/Strings/smart.shen: -------------------------------------------------------------------------------- 1 | (package string [render-file render string->list file-extension whitespace?] 2 | 3 | (declare render [string --> string]) 4 | (declare render-file [string --> [string --> string]]) 5 | 6 | (define render-file 7 | File Extension -> (let Bytes (read-file-as-bytelist File) 8 | Strings (bytes->strings Bytes []) 9 | Render (compile (fn ) Strings) 10 | Out (file-extension File Extension) 11 | Write (write-to-file Out Render) 12 | Out)) 13 | 14 | (define bytes->strings 15 | [] Strings -> (reverse Strings) 16 | [Byte | Bytes] Strings -> (bytes->strings Bytes [(n->string Byte) | Strings])) 17 | 18 | (define render 19 | String -> (compile (fn ) (string->list String))) 20 | 21 | (define rendered? 22 | "" -> true 23 | (@s "{" _) -> false 24 | (@s _ S) -> (rendered? S)) 25 | 26 | (defcc 27 | "{" "}" := (cn (recapply (fn (intern )) ) ); 28 | "{" "}" := (cn ((intern )) ); 29 | := (cn ); 30 | := "";) 31 | 32 | (defcc 33 | S := S where (and (not (= S "}")) (not (= S "\")));) 34 | 35 | (define recapply 36 | X [] -> X 37 | Fn [X | Y] -> (recapply (Fn X) Y)) 38 | 39 | (defcc 40 | "\" := [ | ]; 41 | := [];) 42 | 43 | (defcc 44 | ;) 45 | 46 | (defcc 47 | Char := Char where (and (not (= Char "}")) 48 | (not (= Char "\")));) 49 | 50 | (defcc 51 | W := skip where (whitespace? W);) 52 | 53 | (defcc 54 | := (cn ); 55 | := "";) 56 | 57 | (defcc 58 | Char := Char where (and (not (= Char "}")) 59 | (not (= Char "\")) 60 | (not (whitespace? Char)));)) -------------------------------------------------------------------------------- /S39/Test Programs/qmachine.shen: -------------------------------------------------------------------------------- 1 | (datatype progression 2 | 3 | X : A; S : (A --> A); E : (A --> boolean); 4 | ========================================== 5 | [X S E] : (progression A);) 6 | 7 | (define force 8 | {(progression A) --> A} 9 | [X S E] -> X) 10 | 11 | (define delay 12 | {(progression A) --> (progression A)} 13 | [X S E] -> [(S X) S E]) 14 | 15 | (define end? 16 | {(progression A) --> boolean} 17 | [X S E] -> (E X)) 18 | 19 | (define push 20 | {A --> (progression A) --> (progression A)} 21 | X [Y S E] -> [X (/. Z (if (= Z X) Y (S Z))) E]) 22 | 23 | (define forall 24 | {(progression A) --> (A --> boolean) --> boolean} 25 | [X S E] P -> (if (E X) true (and (P X) (forall [(S X) S E] P)))) 26 | 27 | (define exists 28 | {(progression A) --> (A --> boolean) --> boolean} 29 | [X S E] P -> (if (E X) false (or (P X) (exists [(S X) S E] P)))) 30 | 31 | (define super 32 | {(progression A) --> (A --> B) --> (B --> C --> C) --> C --> C} 33 | [X S E] P F Y -> (if (E X) Y (F (P X) (super [(S X) S E] P F Y)))) 34 | 35 | (define forall 36 | {(progression A) --> (A --> boolean) --> boolean} 37 | Progression P -> (super Progression P (fn and) true)) 38 | 39 | (define exists 40 | {(progression A) --> (A --> boolean) --> boolean} 41 | Progression P -> (super Progression P (fn or) false)) 42 | 43 | (define for* 44 | {(progression A) --> (A --> B) --> number} 45 | Progression P -> (super Progression P (fn progn) 0)) 46 | 47 | (define progn 48 | {A --> B --> B} 49 | X Y -> Y) 50 | 51 | (define filter* 52 | {(progression A) --> (A --> boolean) --> (list A)} 53 | Progression P -> (super Progression (/. X (if (P X) [X] [])) (fn append) [])) 54 | 55 | (define next-prime 56 | {number --> number} 57 | N -> (if (prime*? (+ N 1)) (+ N 1) (next-prime (+ N 1)))) 58 | 59 | (define prime*? 60 | {number --> boolean} 61 | X -> (prime-help X (/ X 2) 2)) 62 | 63 | (define prime-help 64 | {number --> number --> number --> boolean} 65 | X Max Div -> false where (integer? (/ X Div)) 66 | X Max Div -> true where (> Div Max) 67 | X Max Div -> (prime-help X Max (+ 1 Div))) -------------------------------------------------------------------------------- /S39/Lib/StLib/Strings/smartmem.shen: -------------------------------------------------------------------------------- 1 | (package string [render-file render string->list file-extension whitespace?] 2 | 3 | (declare render [string --> string]) 4 | (declare render-file [string --> [string --> string]]) 5 | 6 | (define render-file 7 | File Extension -> (let Bytes (read-file-as-bytelist File) 8 | Strings (bytes->strings Bytes []) 9 | Render (compile (fn ) Strings) 10 | Out (file-extension File Extension) 11 | Write (write-to-file Out Render) 12 | Out)) 13 | 14 | (define bytes->strings 15 | [] Strings -> (reverse Strings) 16 | [Byte | Bytes] Strings -> (bytes->strings Bytes [(n->string Byte) | Strings])) 17 | 18 | (define render 19 | String -> (let L (string->list String) 20 | (if (element? "{" L) 21 | (compile (fn ) L) 22 | String))) 23 | 24 | (define rendered? 25 | "" -> true 26 | (@s "{" _) -> false 27 | (@s _ S) -> (rendered? S)) 28 | 29 | (defcc 30 | "{" "}" := (cn (render (recapply (fn (intern )) )) ); 31 | "{" "}" := (cn (render ((intern ))) ); 32 | := (cn ); 33 | := "";) 34 | 35 | (defcc 36 | S := S where (and (not (= S "}")) (not (= S "\")));) 37 | 38 | (define recapply 39 | X [] -> X 40 | Fn [X | Y] -> (recapply (Fn X) Y)) 41 | 42 | (defcc 43 | "\" := [ | ]; 44 | := [];) 45 | 46 | (defcc 47 | ;) 48 | 49 | (defcc 50 | Char := Char where (and (not (= Char "}")) 51 | (not (= Char "\")));) 52 | 53 | (defcc 54 | W := skip where (whitespace? W);) 55 | 56 | (defcc 57 | := (cn ); 58 | := "";) 59 | 60 | (defcc 61 | Char := Char where (and (not (= Char "}")) 62 | (not (= Char "\")) 63 | (not (whitespace? Char)));)) -------------------------------------------------------------------------------- /kl/primitives_test.go: -------------------------------------------------------------------------------- 1 | package kl 2 | 3 | import ( 4 | "bytes" 5 | // "fmt" 6 | "testing" 7 | ) 8 | 9 | func TestReadByte(t *testing.T) { 10 | var kl ControlFlow 11 | fn := kl.Global(MakeSymbol("read-byte")) 12 | buf := bytes.NewBufferString("a") 13 | stream := MakeStream(buf) 14 | b := Call(&kl, fn, stream) 15 | if mustInteger(b) != 97 { 16 | t.Error("should be 97") 17 | } 18 | 19 | b = Call(&kl, fn, stream) 20 | if mustInteger(b) != -1 { 21 | t.Error("read EOF should return -1") 22 | } 23 | } 24 | 25 | func TestIntern(t *testing.T) { 26 | var kl ControlFlow 27 | fn := kl.Global(MakeSymbol("intern")) 28 | if Call(&kl, fn, MakeString("true")) != True { 29 | t.Error("intern(true) should be boolean") 30 | } 31 | if Call(&kl, fn, MakeString("false")) != False { 32 | t.Error("intern(false) should be boolean") 33 | } 34 | if equal(Call(&kl, fn, MakeString("asdf")), MakeSymbol("asdf")) != True { 35 | t.FailNow() 36 | } 37 | } 38 | 39 | func TestStr(t *testing.T) { 40 | // str primitive prints the viewable format of a object. 41 | // shen symbol? defun rely on this function contain non-alpha chars. 42 | var alphaTable [256]bool 43 | for _, c := range []byte{'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', 'K', 'L', 'M', 44 | 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 45 | 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 46 | 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z', 47 | '=', '*', '/', '+', '-', '_', '?', '$', '!', '@', '~', '>', '<', 48 | '&', '%', '{', '}', ':', ';', '`', '#', '\'', '.'} { 49 | alphaTable[c] = true 50 | } 51 | allAlpha := func(str string) bool { 52 | for i := 0; i < len(str); i++ { 53 | c := str[i] 54 | if alphaTable[c] != true { 55 | return false 56 | } 57 | } 58 | return true 59 | } 60 | 61 | var kl ControlFlow 62 | fn := kl.Global(MakeSymbol("str")) 63 | str := Call(&kl, fn, makeProcedure(MakeSymbol("x"), MakeSymbol("x"), Nil)) 64 | if allAlpha(mustString(str)) { 65 | t.Error("str of procedure should not be all alpha") 66 | } 67 | } 68 | 69 | func TestFixnum(t *testing.T) { 70 | n := MakeNumber(3000001) 71 | if PrimIsPair(n) != False { 72 | t.Error("3000000 should not be a cons") 73 | } 74 | } 75 | -------------------------------------------------------------------------------- /S39/Test Programs/harness.shen: -------------------------------------------------------------------------------- 1 | (package test-harness [report reset ok passed failed] 2 | 3 | (define reset 4 | -> (set *passed* (set *failed* 0))) 5 | 6 | (defmacro exec-macro 7 | [exec Name Expr Prediction] -> [trap-error [let (protect Output) [output "~%~A: ~R = ~S~%" Name (rcons Expr) Prediction] 8 | (protect Result) [time Expr] 9 | [if [= (protect Result) Prediction] [passed] [failed (protect Result)]]] 10 | [/. (protect E) [err (protect E)]]]) 11 | 12 | (define rcons 13 | [X | Y] -> [cons (rcons X) (rcons Y)] 14 | X -> X) 15 | 16 | (define passed 17 | -> (do (trap-error (set *passed* (+ 1 (value *passed*))) (/. E (set *passed* 1))) 18 | (print passed))) 19 | 20 | (define failed 21 | Result -> (let Fail+ (trap-error (set *failed* (+ 1 (value *failed*))) (/. E (set *failed* 1))) 22 | ShowResult (output "~S returned~%" Result) 23 | (if (y-or-n? "failed; continue?") ok (error "kill")))) 24 | 25 | (define err 26 | E -> (error "") where (= (error-to-string E) "kill") 27 | E -> (do (trap-error (set *failed* (+ 1 (value *failed*))) (/. E (set *failed* 1))) 28 | (output "~%failed with error ~A~%" (error-to-string E)) 29 | (if (y-or-n? "failed; continue?") ok (error "kill")))) 30 | 31 | (defmacro report-results-macro 32 | [report Name | Tests] -> (let NewTests (create-tests Name Tests) 33 | [do | NewTests])) 34 | 35 | (define create-tests 36 | Name [] -> [[results] ok] 37 | Name [Test Prediction | Tests] -> [[exec Name Test Prediction] | (create-tests Name Tests)]) 38 | 39 | (define results 40 | -> (let Passed (trap-error (value *passed*) (/. E 0)) 41 | Failed (trap-error (value *failed*) (/. E 0)) 42 | Percent (* (/ Passed (+ Passed Failed)) 100) 43 | (output "~%passed ... ~A~%failed ... ~A~%pass rate ... ~A%~%~%" Passed Failed Percent))) ) -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/macros.shen: -------------------------------------------------------------------------------- 1 | (package maths [expt =r gcd lcd isqrt sqrt nthrt floor ceiling round mod lcm random min max 2 | reseed ~ positive? negative? natural? converge series odd? even? 3 | cos sin tan radians pi e tan30 cos30 cos45 sin45 sqrt2 tan60 sin120 4 | tan120 sin135 cos135 cos150 tan150 cos210 tan210 sin225 cos225 sin240 5 | tan240 sin300 tan300 sin315 cos315 cos330 tan330 sinh cosh tanh sech 6 | csch power factorial prime? unix div modf product summation set-tolerance tolerance 7 | coth for sq cube newv abs approx log log2 loge log10 g] 8 | 9 | (defmacro maths-macro 10 | [log10 N] -> [log10 N [tolerance]] 11 | [log2 N] -> [log2 N [tolerance]] 12 | [loge N] -> [loge N [tolerance]] 13 | [log M N] -> [log M N [tolerance]] 14 | [sin N] -> [sin N [tolerance]] 15 | [tan N] -> [tan N [tolerance]] 16 | [cos N] -> [cos N [tolerance]] 17 | [tanh N] -> [tanh N [tolerance]] 18 | [cosh N] -> [cosh N [tolerance]] 19 | [sinh N] -> [sinh N [tolerance]] 20 | [sech N] -> [sech N [tolerance]] 21 | [csch N] -> [csch N [tolerance]] 22 | [coth N] -> [coth N [tolerance]] 23 | [nthrt N Root] -> [nthrt N Root [tolerance]] 24 | [sqrt N] -> [sqrt N [tolerance]] 25 | [expt M N] -> [expt M N [tolerance]] 26 | [max W X Y | Z] -> [max W [max X Y | Z]] 27 | [min W X Y | Z] -> [min W [min X Y | Z]] 28 | [tolerance N] -> [tolerance=n N] 29 | [for X = N Loop Do Step and] 30 | -> (let LBind (/. X Y (if (> (occurrences X Y) 0) [/. X Y] Y)) 31 | [lazyfor-and N (LBind X Loop) (LBind X Do) Step]) 32 | [for X = N Loop Do Step or] 33 | -> (let LBind (/. X Y (if (> (occurrences X Y) 0) [/. X Y] Y)) 34 | [lazyfor-or N (LBind X Loop) (LBind X Do) Step]) 35 | [for X = N Loop Do Step Acc] -> (let LBind (/. X Y (if (> (occurrences X Y) 0) [/. X Y] Y)) 36 | [for N (LBind X Loop) (LBind X Do) Step Acc]) 37 | [for X = N Loop Do Step] -> (let LBind (/. X Y (if (> (occurrences X Y) 0) [/. X Y] Y)) 38 | [for N (LBind X Loop) (LBind X Do) Step [fn do]]) 39 | [for X = N Loop Do] -> (let LBind (/. X Y (if (> (occurrences X Y) 0) [/. X Y] Y)) 40 | [for N (LBind X Loop) [/. X Do] [+ 1] [fn do]])) ) -------------------------------------------------------------------------------- /S39/Test Programs/search.shen: -------------------------------------------------------------------------------- 1 | (define breadth-first 2 | {state --> (state --> (list state)) --> (state --> boolean) --> boolean} 3 | Start F Test -> (b* F Test (F Start))) 4 | 5 | (define b* 6 | {(state --> (list state)) --> (state --> boolean) --> (list state) --> boolean} 7 | F Test States -> true where (some Test States) 8 | F Test States -> (let NewStates (mapcan F States) 9 | (if (empty? NewStates) 10 | false 11 | (b* F Test NewStates)))) 12 | 13 | (define some 14 | {(A --> boolean) --> (list A) --> boolean} 15 | Test [] -> false 16 | Test [X|Y] -> (or (Test X) (some Test Y))) 17 | 18 | (define depth 19 | {state --> (state --> (list state)) --> (state --> boolean) --> boolean} 20 | Start _ Test -> true where (Test Start) 21 | Start F Test -> (d* F Test (F Start))) 22 | 23 | (define d* 24 | {(state --> (list state)) --> (state --> boolean) --> (list state) --> boolean} 25 | _ Test [State | _] -> true where (Test State) 26 | F Test [State | States] <- (fail-if (= false) (d* F Test (F State))) 27 | F Test [_ | States] -> (d* F Test States) 28 | _ _ _ -> false) 29 | 30 | (define hill 31 | {(state --> number) --> state --> (state --> (list state)) --> (state --> boolean) --> boolean} 32 | _ Start _ Test -> true where (Test Start) 33 | E Start F Test -> (h* E F Test (order_states E (F Start)))) 34 | 35 | (define h* 36 | {(state --> number) --> (state --> (list state)) --> (state --> boolean) --> (list state) --> boolean} 37 | _ _ Test [State | _] -> true where (Test State) 38 | E F Test [State | States] 39 | <- (fail-if (/. X (= X false)) (h* E F Test (order_states E (F State)))) 40 | E F Test [_ | States] -> (h* E F Test States) 41 | _ _ _ _ -> false) 42 | 43 | (define order_states 44 | {(state --> number) --> (list state) --> (list state)} 45 | E States -> (bsort (/. S1 (/. S2 (> (E S1) (E S2)))) States)) 46 | 47 | (define bsort 48 | {(A --> (A --> boolean)) --> (list A) --> (list A)} 49 | R X -> (fix (/. Y (bsort* R Y)) X)) 50 | 51 | (define bsort* 52 | {(A --> A --> boolean) --> (list A) --> (list A)} 53 | _ [] -> [] 54 | _ [X] -> [X] 55 | R [X Y | Z] -> [Y | (bsort* R [X | Z])] where (R Y X) 56 | R [X Y | Z] -> [X | (bsort* R [Y | Z])]) -------------------------------------------------------------------------------- /S39/Test Programs/montague.shen: -------------------------------------------------------------------------------- 1 | (datatype t 2 | 3 | if (not (element? t [~ v & => <=> e! a!])) 4 | T : symbol; 5 | ________ 6 | T : t; 7 | _______________ 8 | (gensym v) : t;) 9 | 10 | (datatype f 11 | 12 | F : t; T : (list t); 13 | ____________________ 14 | [F | T] : f; 15 | 16 | (not (= F ~)) : verified; 17 | F : t, T : t >> P; 18 | ___________________ 19 | [F T] : f >> P; 20 | 21 | (not (element? C [v & => <=>])) : verified; 22 | (not (element? F [e! a!])) : verified; 23 | F : t, T1 : t, T2 : t >> P; 24 | ____________________________ 25 | [F T1 T2] : f >> P; 26 | 27 | P : f; 28 | ========== 29 | [~ P] : f; 30 | 31 | if (element? C [v & => <=>]) 32 | P : f; Q : f; 33 | ============= 34 | [P C Q] : f; 35 | 36 | X : t; P : f; 37 | ============= 38 | [e! X P] : f; 39 | 40 | X : t; P : f; 41 | ============= 42 | [a! X P] : f;) 43 | 44 | (defcc 45 | {(list t) ==> f} 46 | := ( );) 47 | 48 | (defcc 49 | {(list t) ==> ((t --> f) --> f)} 50 | Name := (/. P (P Name)) where (name? Name); 51 | := ( ); 52 | := ( );) 53 | 54 | (define name? 55 | {t --> boolean} 56 | Name -> (variable? Name)) 57 | 58 | (defcc 59 | {(list t) ==> (t --> f)} 60 | CN := (/. X [CN X]) where (common-noun? CN);) 61 | 62 | (define common-noun? 63 | {t --> boolean} 64 | CN -> (element? CN [girl boy dog cat])) 65 | 66 | (defcc 67 | {(list t) ==> (t --> f)} 68 | that := (/. X [( X) & ( X)]); 69 | that := (/. X [( X) & ( (/. Y ( Y X)))]);) 70 | 71 | (defcc 72 | {(list t) ==> (t --> f)} 73 | ; 74 | := (/. X ( (/. Y ( X Y))));) 75 | 76 | (defcc 77 | {(list t) ==> (t --> f)} 78 | Intrans := (/. X [Intrans X]) where (intrans? Intrans);) 79 | 80 | (define intrans? 81 | {t --> boolean} 82 | Intrans -> (element? Intrans [runs jumps walks])) 83 | 84 | (defcc 85 | {(list t) ==> (t --> t --> f)} 86 | Trans := (/. X Y [Trans X Y]) where (trans? Trans);) 87 | 88 | (define trans? 89 | {t --> boolean} 90 | Trans -> (element? Trans [likes greets admires])) 91 | 92 | (defcc 93 | {(list t) ==> ((t --> f) --> ((t --> f) --> f))} 94 | some := (let V (type (gensym v) t) (/. P Q [e! V [(P V) & (Q V)]])); 95 | every := (let V (type (gensym v) t) (/. P Q [a! V [(P V) => (Q V)]])); 96 | no := (let V (type (gensym v) t) (/. P Q [a! V [(P V) => [~ (Q V)]]]));) -------------------------------------------------------------------------------- /kl/reader_test.go: -------------------------------------------------------------------------------- 1 | package kl 2 | 3 | import ( 4 | "io" 5 | "strings" 6 | "testing" 7 | ) 8 | 9 | func TestSexpReader(t *testing.T) { 10 | IF := MakeSymbol("if") 11 | tests := []struct { 12 | input string 13 | expect Obj 14 | }{ 15 | {"1234", MakeInteger(1234)}, 16 | {`"string"`, MakeString("string")}, 17 | {"symbol", MakeSymbol("symbol")}, 18 | {"()", Nil}, 19 | {"(1 2)", cons(MakeInteger(1), cons(MakeInteger(2), Nil))}, 20 | {"true", True}, 21 | {"false", False}, 22 | {"(if true (if false 1 2) 3)", cons(IF, cons(True, 23 | cons( 24 | cons(IF, cons(False, cons(MakeInteger(1), cons(MakeInteger(2), Nil)))), 25 | cons(MakeInteger(3), Nil))))}, 26 | {`"abc 27 | de"`, MakeString("abc\nde")}, 28 | } 29 | for _, test := range tests { 30 | r := NewSexpReader(strings.NewReader(test.input), false) 31 | o, err := r.Read() 32 | if err != nil && err != io.EOF { 33 | t.Error("read error", err) 34 | } 35 | if equal(o, test.expect) == False { 36 | t.Errorf("%s fail, expect: %#v, but get: %#v\n", test.input, (*scmHead)(test.expect), (*scmHead)(o)) 37 | } 38 | } 39 | 40 | r := NewSexpReader(strings.NewReader("(if true 1 false) 2"), false) 41 | o1, err := r.Read() 42 | if err != nil && err != io.EOF { 43 | t.Fatal("read error", err) 44 | } 45 | if equal(o1, cons(MakeSymbol("if"), cons(True, cons(MakeInteger(1), cons(False, Nil))))) == False { 46 | t.Errorf("if true... %#v", (*scmHead)(o1)) 47 | } 48 | 49 | o2, err := r.Read() 50 | if err != nil && err != io.EOF { 51 | t.Fatal(err) 52 | } 53 | if equal(o2, MakeInteger(2)) == False { 54 | t.Error("read another sexp") 55 | } 56 | } 57 | 58 | func TestReaderMacro(t *testing.T) { 59 | a, _ := NewSexpReader(strings.NewReader("'(a b c)"), true).Read() 60 | b, _ := NewSexpReader(strings.NewReader("(quote (a b c))"), false).Read() 61 | if equal(a, b) == False { 62 | t.Error("fail:", ObjString(a), ObjString(b)) 63 | } 64 | 65 | a, err1 := NewSexpReader(strings.NewReader("[a b c]"), true).Read() 66 | b, err2 := NewSexpReader(strings.NewReader("(list a b c)"), true).Read() 67 | if err1 != nil || err2 != nil { 68 | t.Error("fail:", err1, err2) 69 | } 70 | if equal(a, b) == False { 71 | t.Error("fail:", ObjString(a), ObjString(b)) 72 | } 73 | 74 | a, err1 = NewSexpReader(strings.NewReader("[a b . c]"), true).Read() 75 | b, err2 = NewSexpReader(strings.NewReader("(list-rest a b c)"), true).Read() 76 | if err1 != nil || err2 != nil { 77 | t.Error("fail:", err1, err2) 78 | } 79 | if equal(a, b) == False { 80 | t.Error("fail:", ObjString(a), ObjString(b)) 81 | } 82 | } 83 | -------------------------------------------------------------------------------- /S39/Lib/Tk/interface.shen: -------------------------------------------------------------------------------- 1 | (package tk (external tk) 2 | 3 | (set *out* "shen-to-tcl.txt") 4 | (set *in* "tcl-to-shen.txt") 5 | (set *suspend?* false) 6 | 7 | (define shen->tcl 8 | String -> (let Sink (open-absolute (value *out*) out) 9 | Write (pr (cn String " eot") Sink) 10 | Close (close Sink) 11 | String) where (ready?) 12 | String -> (shen->tcl String)) 13 | 14 | (define ready? 15 | -> (empty? (read-file-absolute (value *out*)))) 16 | 17 | (define open-absolute 18 | File Direction -> (let Home (value *home-directory*) 19 | NewHome (set *home-directory* "") 20 | Open (open File Direction) 21 | ReSet (set *home-directory* Home) 22 | Open)) 23 | 24 | (define read-file-absolute 25 | File -> (let Home (value *home-directory*) 26 | NewHome (set *home-directory* "") 27 | Read (read-file File) 28 | ReSet (set *home-directory* Home) 29 | Read)) 30 | 31 | (define tcl->shen 32 | -> (tcl->shen-loop (tcl->shen-no-hang))) 33 | 34 | (define tcl->shen-loop 35 | skip -> (tcl->shen-loop (tcl->shen-no-hang)) 36 | X -> (eval X)) 37 | 38 | (define tcl->shen-no-hang 39 | -> (let Command (strip-eot (read-file-absolute (value *in*))) 40 | (if (empty? Command) 41 | skip 42 | (let Flush (flush) 43 | Command)))) 44 | 45 | (define flush 46 | -> (let Sink (open-absolute (value *in*) out) 47 | Write (pr "" Sink) 48 | (close Sink))) 49 | 50 | (define event-loop 51 | -> (event-loop-help (tcl->shen))) 52 | 53 | (define event-loop-help 54 | _ -> (event-loop-help skip) where (value *suspend?*) 55 | _ -> (event-loop-help (tcl->shen))) 56 | 57 | (define suspend 58 | -> (set *suspend?* true)) 59 | 60 | (define resume 61 | -> (set *suspend?* false)) 62 | 63 | (define strip-eot 64 | [X eot] -> X 65 | _ -> []) 66 | 67 | (define check-error 68 | -> (check-error-loop (ready?))) 69 | 70 | (define check-error-loop 71 | true -> (check-error-message (tcl->shen-no-hang)) 72 | _ -> (check-error-loop (ready?))) 73 | 74 | (define check-error-message 75 | [simple-error S] -> (simple-error S) 76 | _ -> skip) 77 | 78 | (define exit 79 | -> (do (shen->tcl "global myloop; set myloop 0") exited)) ) -------------------------------------------------------------------------------- /S39/Lib/StLib/Vectors/jnk.shen: -------------------------------------------------------------------------------- 1 | (package vector [for error overwrite insert ignore depopulate populate vector->list v-op1 v-op2 array] 2 | 3 | (defmacro vector-macros 4 | [:= V [cons I J]] -> [<-array V [cons I J]] 5 | [:= V [cons I J] insert X] -> [trap-error [<-array V [cons I J]] [/. (protect E) X]] 6 | [V [cons I [cons J K]] := | Rest] -> [vector-> V I [V [cons J K] := | Rest]] 7 | [V1 [cons I []] := V2 [cons J K]] -> [vector-> V1 I [<-array V2 [cons J K]]] 8 | [V1 [cons I []] := V2 [cons J K] error] -> [vector-> V1 I [<-array V2 [cons J K]]] 9 | [V1 [cons I []] := X] -> [vector-> V1 I X] 10 | [V1 [cons I []] := X error] -> [vector-> V1 I X] 11 | [V1 [cons I []] := V2 [cons J K] ignore] -> [trap-error [vector-> V1 I [<-array V2 [cons J K]]] 12 | [/. (protect E) V1]] 13 | [V1 [cons I []] := X ignore] -> [trap-error [vector-> V1 I X] [/. (protect E) V1]] 14 | [V1 [cons I []] := V2 [cons J K] insert X] -> [vector-> V1 I [trap-error [<-array V2 [cons J K]] 15 | [/. (protect E) X]]] 16 | [V1 [cons I []] := X insert Y] -> [trap-error [vector-> V1 I X] [trap-error X 17 | [/. (protect E) Y]]] 18 | [V1 [cons I []] := V2 [J | K] overwrite] -> [trap-error [vector-> V1 I [<-array V2 [cons J K]]] 19 | [/. (protect E) [depopulate V1 I]]] 20 | [V1 [cons I []] := X overwrite] -> [trap-error [vector-> V1 I X] 21 | [/. (protect E) [depopulate V1 I]]] 22 | [<-array V [cons I []]] -> [<-vector V I] 23 | [<-array V [cons I J]] -> [<-array [<-vector V I] J] 24 | [array [cons I []]] -> [vector I] 25 | [array [cons I J]] -> (let N (protect K) 26 | V (protect V) 27 | [let V [vector I] 28 | [for N = 1 [<= N I] [vector-> V N [array J]]]]) 29 | [vector->list V] -> [vector->list V []] 30 | [v-op1 F V] -> [v-op1 F V []] 31 | [v-op2 F V1 V2] -> [v-op2 F V1 V2 []]) 32 | 33 | (define depopulate 34 | V I -> (address-> V I (fail))) 35 | 36 | (declare depopulate [[vector A] --> [number --> [vector A]]]) 37 | (declare populate [[number --> A] --> [number --> [vector A]]]) 38 | 39 | (define populate 40 | F I -> (let V (absvector (+ I 1)) 41 | StV (address-> V 0 I) 42 | (for N = 1 (<= N (+ I 1)) (vector-> V N (F N))))) 43 | 44 | ) -------------------------------------------------------------------------------- /compiled/script.kl: -------------------------------------------------------------------------------- 1 | ;; generate bytecode 2 | ;; mkdir -p compiled 3 | ;; cd compiled 4 | ;; kl 5 | (load-file "../S39/KLambda/toplevel.kl") 6 | (load-file "../S39/KLambda/core.kl") 7 | (load-file "../S39/KLambda/sys.kl") 8 | (load-file "../S39/KLambda/sequent.kl") 9 | (load-file "../S39/KLambda/yacc.kl") 10 | (load-file "../S39/KLambda/reader.kl") 11 | (load-file "../S39/KLambda/prolog.kl") 12 | (load-file "../S39/KLambda/track.kl") 13 | (load-file "../S39/KLambda/load.kl") 14 | (load-file "../S39/KLambda/writer.kl") 15 | (load-file "../S39/KLambda/macros.kl") 16 | (load-file "../S39/KLambda/declarations.kl") 17 | (load-file "../S39/KLambda/t-star.kl") 18 | (load-file "../S39/KLambda/types.kl") 19 | (shen.shen) 20 | 21 | (load "../src/compiler.shen") 22 | (set *maximum-print-sequence-size* 100000) 23 | (compile-file "../S39/KLambda/sys.kl" "sys.tmp") 24 | (compile-file "../S39/KLambda/writer.kl" "writer.tmp") 25 | (compile-file "../S39/KLambda/core.kl" "core.tmp") 26 | (compile-file "../S39/KLambda/reader.kl" "reader.tmp") 27 | (compile-file "../S39/KLambda/declarations.kl" "declarations.tmp") 28 | (compile-file "../S39/KLambda/toplevel.kl" "toplevel.tmp") 29 | (compile-file "../S39/KLambda/macros.kl" "macros.tmp") 30 | (compile-file "../S39/KLambda/load.kl" "load.tmp") 31 | (compile-file "../S39/KLambda/prolog.kl" "prolog.tmp") 32 | (compile-file "../S39/KLambda/sequent.kl" "sequent.tmp") 33 | (compile-file "../S39/KLambda/track.kl" "track.tmp") 34 | (compile-file "../S39/KLambda/t-star.kl" "t-star.tmp") 35 | (compile-file "../S39/KLambda/yacc.kl" "yacc.tmp") 36 | (compile-file "../S39/KLambda/types.kl" "types.tmp") 37 | 38 | 39 | ;; generate go file from bytecode 40 | (put bc->go arity 5) 41 | (let Cg (make-code-generator) 42 | (do 43 | (bc->go Cg "SysMain" false "sys.tmp" "../cmd/shen/sys.go") 44 | (bc->go Cg "WriterMain" false "writer.tmp" "../cmd/shen/writer.go") 45 | (bc->go Cg "CoreMain" false "core.tmp" "../cmd/shen/core.go") 46 | (bc->go Cg "ReaderMain" false "reader.tmp" "../cmd/shen/reader.go") 47 | (bc->go Cg "DeclarationsMain" false "declarations.tmp" "../cmd/shen/declarations.go") 48 | (bc->go Cg "TopLevelMain" false "toplevel.tmp" "../cmd/shen/toplevel.go") 49 | (bc->go Cg "MacrosMain" false "macros.tmp" "../cmd/shen/macros.go") 50 | (bc->go Cg "LoadMain" false "load.tmp" "../cmd/shen/load.go") 51 | (bc->go Cg "PrologMain" false "prolog.tmp" "../cmd/shen/prolog.go") 52 | (bc->go Cg "SequentMain" false "sequent.tmp" "../cmd/shen/sequent.go") 53 | (bc->go Cg "TrackMain" false "track.tmp" "../cmd/shen/track.go") 54 | (bc->go Cg "TStarMain" false "t-star.tmp" "../cmd/shen/t-star.go") 55 | (bc->go Cg "YaccMain" false "yacc.tmp" "../cmd/shen/yacc.go") 56 | (bc->go Cg "TypesMain" true "types.tmp" "../cmd/shen/types.go"))) -------------------------------------------------------------------------------- /S39/Lib/StLib/IO/prettyprint.shen: -------------------------------------------------------------------------------- 1 | (package print (append (external maths) 2 | [pps pprint pretty-string linelength indentation set-linelength set-indentation]) 3 | 4 | (datatype print 5 | 6 | _______________________________ 7 | (value *indentation*) : number; 8 | 9 | _______________________________ 10 | (value *linelength*) : number;) 11 | 12 | (defmacro pprint-macro 13 | [pprint X] -> [pprint X [stoutput]] 14 | [pps F] -> [pps F [stoutput]]) 15 | 16 | (set *indentation* 1) 17 | (set *linelength* 60) 18 | 19 | (define linelength 20 | {--> number} 21 | -> (value *linelength*)) 22 | 23 | (define indentation 24 | {--> number} 25 | -> (value *indentation*)) 26 | 27 | (define set-linelength 28 | {number --> number} 29 | N -> (set *linelength* N) where (and (positive? N) (integer? N)) 30 | N -> (error "line length must be a positive integer~%")) 31 | 32 | (define set-indentation 33 | {number --> number} 34 | N -> (set *indentation* N) where (and (positive? N) (integer? N)) 35 | N -> (error "indentation must be a positive integer~%")) 36 | 37 | (define pps 38 | {symbol --> (stream out) --> symbol} 39 | F Sink -> (let Code (ps F) 40 | Ugly (make-string "~R" Code) 41 | Pretty (pretty-string Ugly) 42 | PrettyPrint (pr Pretty Sink) 43 | NL (nl) 44 | F)) 45 | 46 | (define pprint 47 | {A --> (stream out) --> A} 48 | X Stream -> (let Ugly (make-string "~S" X) 49 | Pretty (pretty-string Ugly) 50 | PrettyPrint (pr Pretty Stream) 51 | NL (nl) 52 | X)) 53 | 54 | (define pretty-string 55 | {string --> string} 56 | S -> (pretty-string-h S 0 0)) 57 | 58 | (define pretty-string-h 59 | {string --> number --> number --> string} 60 | "" _ _ -> "" 61 | (@s "[" Ss) Depth Length -> (@s (indent Depth) "[" (pretty-string-h Ss (+ Depth 1) 0)) 62 | (@s "(" Ss) Depth Length -> (@s (indent Depth) "(" (pretty-string-h Ss (+ Depth 1) 0)) 63 | (@s "]" Ss) Depth Length -> (@s "]" (pretty-string-h Ss (- Depth 1) 0)) 64 | (@s ")" Ss) Depth Length -> (@s ")" (pretty-string-h Ss (- Depth 1) 0)) 65 | (@s " " Ss) Depth Length -> (@s (indent Depth) (pretty-string-h Ss Depth 0)) where (> Length (linelength)) 66 | (@s S Ss) Depth Length -> (@s S (pretty-string-h Ss Depth (+ Length 1)))) 67 | 68 | (define indent 69 | {number --> string} 70 | 0 -> "" 71 | N -> (@s "c#10;" (indent-h N))) 72 | 73 | (define indent-h 74 | {number --> string} 75 | 0 -> "" 76 | N -> (cn (n-space (indentation)) (indent-h (- N 1)))) 77 | 78 | (define n-space 79 | {number --> string} 80 | 0 -> "" 81 | N -> (cn " " (n-space (- N 1)))) 82 | 83 | (preclude [print])) -------------------------------------------------------------------------------- /S39/Test Programs/yacc.shen: -------------------------------------------------------------------------------- 1 | (defcc 2 | {(list symbol) ==> (list symbol)} 3 | ;) 4 | 5 | (defcc 6 | {(list symbol) ==> (list symbol)} 7 | the; a;) 8 | 9 | (defcc 10 | {(list symbol) ==> (list symbol)} 11 | ; 12 | ;) 13 | 14 | (defcc 15 | {(list symbol) ==> (list symbol)} 16 | cat; dog;) 17 | 18 | (defcc 19 | {(list symbol) ==> (list symbol)} 20 | X := [X] where (element? X [bill ben]);) 21 | 22 | (defcc 23 | {(list symbol) ==> (list symbol)} 24 | ;) 25 | 26 | (defcc 27 | {(list symbol) ==> (list symbol)} 28 | likes; chases;) 29 | 30 | (defcc 31 | [] [] := (append );) 32 | 33 | (defcc 34 | {(list symbol) ==> (list symbol)} 35 | d ; 36 | d;) 37 | 38 | (defcc 39 | e ; 40 | e;) 41 | 42 | (defcc 43 | := (question );) 44 | 45 | (define question 46 | NP VP -> (append [is it true that your father] VP [?])) 47 | 48 | (defcc bs> 49 | a bs> := [b | bs>]; 50 | a := [b];) 51 | 52 | (defcc 53 | := ; 54 | := ; 55 | X := ;) 56 | 57 | (defcc 58 | X ; 59 | X;) 60 | 61 | (defcc 62 | 0; 1; 2; 3; 4; 5; 6; 7; 8; 9;) 63 | 64 | (defcc 65 | ; 66 | := ; 67 | X := ;) 68 | 69 | (defcc 70 | ;) 71 | 72 | (defcc 73 | a ; 74 | a;) 75 | 76 | (defcc 77 | b ; 78 | b; 79 | ;) 80 | 81 | (defcc 82 | c ; 83 | c;) 84 | 85 | (defcc 86 | ;) 87 | 88 | (defcc 89 | b ; 90 | b; 91 | ;) 92 | 93 | (defcc 94 | := ; 95 | := ; 96 | X := ;) 97 | 98 | (defcc 99 | X := X where (element? X [0 1 2 3 4 5 6 7 8 9]);) 100 | 101 | (defcc 102 | := (appendall [ ]) 103 | where (equal-length? [ ]);) 104 | 105 | (defcc 106 | a ; 107 | a;) 108 | 109 | (defcc 110 | b ; 111 | b;) 112 | 113 | (defcc 114 | c ; 115 | c;) 116 | 117 | (define equal-length? 118 | [] -> true 119 | [L] -> true 120 | [L1 L2 | Ls] -> (and (= (length L1) (length L2)) (equal-length? [L2 | Ls]))) 121 | 122 | (define appendall 123 | [] -> [] 124 | [L | Ls] -> (append L (appendall Ls))) 125 | 126 | (defcc 127 | [a] := a;) 128 | 129 | (defcc 130 | [b] b;) 131 | 132 | (defcc 133 | [] := []; 134 | c;) 135 | 136 | (defcc 137 | [] := [[] | ]; 138 | d := [d | ]; 139 | d := [d];) 140 | 141 | -------------------------------------------------------------------------------- /S39/Test Programs/structures-typed.shen: -------------------------------------------------------------------------------- 1 | (define defstruct 2 | Name Slots 3 | -> (let Attributes (map (fn fst) Slots) 4 | Types (map (fn snd) Slots) 5 | Selectors (selectors Name Attributes) 6 | Constructor (constructor Name Attributes) 7 | Recognisor (recognisor Name) 8 | ConstructorType (constructor-type Name Types) 9 | SelectorTypes (selector-types Name Attributes Types) 10 | RecognisorType (recognisor-type Name) 11 | Name)) 12 | 13 | (define selector-types 14 | _ [] [] -> (gensym (protect X)) 15 | Name [Attribute | Attributes] [Type | Types] 16 | -> (let Selector (concat Name (concat - Attribute)) 17 | SelectorType [Name --> Type] 18 | TypeDecl (declare Selector SelectorType) 19 | (selector-types Name Attributes Types))) 20 | 21 | (define recognisor-type 22 | Name -> (let Recognisor (concat Name ?) 23 | (declare Recognisor [Name --> boolean]))) 24 | 25 | (define constructor-type 26 | Name Types -> (let Constructor (concat make- Name) 27 | Type (assemble-type Types Name) 28 | (declare Constructor Type))) 29 | 30 | (define assemble-type 31 | [ ] Name -> Name 32 | [Type | Types] Name -> [Type --> (assemble-type Types Name)]) 33 | 34 | (declare defstruct [symbol --> [list [symbol * symbol]] --> symbol]) 35 | 36 | (define selectors 37 | Name Attributes -> (map (/. A (selector Name A)) Attributes)) 38 | 39 | (define selector 40 | Name Attribute 41 | -> (let SelectorName (concat Name (concat - Attribute)) 42 | (eval [define SelectorName 43 | (protect Structure) -> [let (protect LookUp) [assoc Attribute (protect Structure)] 44 | [if [empty? (protect LookUp)] 45 | [error "~A is not an attribute of ~A.~%" 46 | Attribute Name] 47 | [tail (protect LookUp)]]]]))) 48 | 49 | (define constructor 50 | Name Attributes 51 | -> (let ConstructorName (concat make- Name) 52 | Parameters (params Attributes) 53 | (eval [define ConstructorName | 54 | (append Parameters 55 | [-> [cons [cons structure Name] 56 | (make-association-list Attributes 57 | Parameters)]])]))) 58 | 59 | (define params 60 | [] -> [] 61 | [_ | Attributes] -> [(gensym (protect X)) | (params Attributes)]) 62 | 63 | (define make-association-list 64 | [] [] -> [] 65 | [A | As] [P | Ps] -> [cons [cons A P] (make-association-list As Ps)]) 66 | 67 | (define recognisor 68 | Name -> (let RecognisorName (concat Name ?) 69 | (eval [define RecognisorName 70 | [cons [cons structure Name] _] -> true 71 | _ -> false]))) 72 | -------------------------------------------------------------------------------- /S39/Test Programs/proof assistant.shen: -------------------------------------------------------------------------------- 1 | (synonyms 2 | 3 | proof (list step) 4 | step ((list sequent) * tactic) 5 | tactic ((list sequent) --> (list sequent)) 6 | sequent ((list wff) * wff)) 7 | 8 | (datatype globals 9 | 10 | _______________________ 11 | (value *proof*) : proof;) 12 | 13 | (define proof-assistant 14 | {A --> symbol} 15 | _ -> (let Assumptions (input-assumptions 1) 16 | Conclusion (input-conclusion _) 17 | Sequents [(@p Assumptions Conclusion)] 18 | Proof (time (proof-loop Sequents [])) 19 | (do (nl) proved))) 20 | 21 | (define input-assumptions 22 | {number --> (list wff)} 23 | N -> (let More? (y-or-n? "~%Input assumptions? ") 24 | (if More? 25 | (do (output "~%~A. " N) 26 | [(input+ wff) | (input-assumptions (+ N 1))]) 27 | [ ]))) 28 | 29 | (define input-conclusion 30 | {A --> wff} 31 | _ -> (do (output "~%Enter conclusion: ") (input+ wff))) 32 | 33 | (define proof-loop 34 | {(list sequent) --> proof --> proof} 35 | [ ] Proof -> (set *proof* (reverse Proof)) 36 | S Proof -> (let Show (show-sequent S (+ 1 (length Proof))) 37 | D (user-directive _) 38 | Step (@p S D) 39 | (if (= D (fn back)) 40 | (proof-loop (go-back Proof) (tail Proof)) 41 | (proof-loop (D S) [Step | Proof])))) 42 | 43 | (define show-proof 44 | {string --> symbol} 45 | S -> (show-proof-help (value *proof*) 1)) 46 | 47 | (define show-proof-help 48 | {proof --> number --> symbol} 49 | [ ] _ -> proved 50 | [(@p Sequents Tactic) | Proof] N -> (do (show-sequent Sequents N) 51 | (output "~%Tactic: ~A~%" Tactic) 52 | (show-proof-help Proof (+ N 1)))) 53 | 54 | (define show-sequent 55 | {(list sequent) --> number --> symbol} 56 | Sequents N -> (let Unsolved (length Sequents) 57 | Sequent (head Sequents) 58 | Wffs (fst Sequent) 59 | Wff (snd Sequent) 60 | (do (output "==============================~%") 61 | (output "Step ~A unsolved ~A~%~%" 62 | N Unsolved) 63 | (output "?- ~S~%~%" Wff) 64 | (enumerate Wffs 1)))) 65 | 66 | (define enumerate 67 | {(list A) --> number --> symbol} 68 | [] _ -> _ 69 | [X | Y] N -> (do (output "~A. ~S~%" N X) (enumerate Y (+ N 1)))) 70 | 71 | (define user-directive 72 | {A --> tactic} 73 | _ -> (do (output "~%Tactic: ") (input+ tactic))) 74 | 75 | (define back 76 | {(list sequent) --> (list sequent)} 77 | S -> S) 78 | 79 | (define go-back 80 | {proof --> (list sequent)} 81 | [(@p S _) | _] -> S) -------------------------------------------------------------------------------- /kl/library_test.go: -------------------------------------------------------------------------------- 1 | package kl 2 | 3 | import ( 4 | "testing" 5 | ) 6 | 7 | func TestReverse(t *testing.T) { 8 | if reverse(Nil) != Nil { 9 | t.FailNow() 10 | } 11 | 12 | l := cons(MakeInteger(1), cons(MakeInteger(2), cons(MakeInteger(3), Nil))) 13 | r := reverse(l) 14 | if mustInteger(car(r)) != 3 { 15 | t.FailNow() 16 | } 17 | if mustInteger(cadr(r)) != 2 { 18 | t.FailNow() 19 | } 20 | if mustInteger(caddr(r)) != 1 { 21 | t.FailNow() 22 | } 23 | if cdddr(r) != Nil { 24 | t.FailNow() 25 | } 26 | 27 | // (1 (1 2 3)) 28 | l1 := cons(MakeInteger(1), cons(l, Nil)) 29 | // ((1 2 3) 1) 30 | l2 := cons(l, cons(MakeInteger(1), Nil)) 31 | 32 | if equal(reverse(l1), l2) != True { 33 | t.Error("fuck1") 34 | } 35 | if equal(reverse(l2), l1) != True { 36 | t.Error("fuck2") 37 | } 38 | } 39 | 40 | func TestEqual(t *testing.T) { 41 | tests := []struct { 42 | x Obj 43 | y Obj 44 | expect Obj 45 | }{ 46 | {True, True, True}, 47 | {True, False, False}, 48 | {False, True, False}, 49 | {True, MakeNumber(10), False}, 50 | {Nil, Nil, True}, 51 | {Nil, False, False}, 52 | {MakeString("asd"), MakeString("abc"), False}, 53 | {MakeVector(1), MakeVector(2), False}, 54 | {MakeVector(0), MakeVector(0), True}, 55 | {MakeInteger(5), MakeInteger(fixnumCount + 3), False}, 56 | {MakeInteger(0), MakeInteger(5), False}, 57 | {MakeInteger(5), MakeInteger(5), True}, 58 | } 59 | 60 | for _, test := range tests { 61 | if equal(test.x, test.y) != test.expect { 62 | t.Error(test.x, test.y) 63 | } 64 | } 65 | } 66 | 67 | func TestVectorGet(t *testing.T) { 68 | var kl ControlFlow 69 | vecSet := kl.Global(MakeSymbol("address->")) 70 | vecGet := kl.Global(MakeSymbol("<-address")) 71 | vec := MakeVector(1) 72 | Call(&kl, vecSet, vec, MakeInteger(0), MakeNumber(42)) 73 | func() { 74 | defer func() { 75 | err := recover() 76 | val := err.(Obj) 77 | if *val != scmHeadError { 78 | t.Error("should be error out of range") 79 | } 80 | }() 81 | Call(&kl, vecGet, vec, MakeInteger(1)) 82 | }() 83 | if equal(Call(&kl, vecGet, vec, MakeInteger(0)), MakeNumber(42)) != True { 84 | t.Error("vector set or get wrong") 85 | } 86 | } 87 | 88 | func TestIsPreciseInteger(t *testing.T) { 89 | testPreciseInteger(t, 0.0, true) 90 | testPreciseInteger(t, 1.0, true) 91 | testPreciseInteger(t, 3, true) 92 | testPreciseInteger(t, 7.0, true) 93 | testPreciseInteger(t, -1.0, true) 94 | testPreciseInteger(t, 2251799813685248.0, true) 95 | 96 | testPreciseInteger(t, 2.14, false) 97 | testPreciseInteger(t, 0.14, false) 98 | testPreciseInteger(t, -0.14, false) 99 | testPreciseInteger(t, 1.1, false) 100 | testPreciseInteger(t, 1024.5, false) 101 | testPreciseInteger(t, 2251799813685248.5, false) 102 | } 103 | 104 | func testPreciseInteger(t *testing.T, f float64, expect bool) { 105 | if isPreciseInteger(f) != expect { 106 | t.Error("testPreciseInteger wrong:", f, expect) 107 | } 108 | } 109 | -------------------------------------------------------------------------------- /S39/Test Programs/classes-typed.shen: -------------------------------------------------------------------------------- 1 | (declare defclass [symbol --> [list [symbol * symbol]] --> symbol]) 2 | 3 | (define defclass 4 | Class ClassDef -> (let Attributes (map (fn fst) ClassDef) 5 | Types (record-attribute-types Class ClassDef) 6 | Assoc (map (/. Attribute [Attribute | fail]) Attributes) 7 | ClassDef [[class | Class] | Assoc] 8 | Store (put Class classdef ClassDef) 9 | RecordClass (axiom Class Class [class Class]) 10 | Class)) 11 | 12 | (define axiom 13 | DataType X A -> (eval [datatype DataType 14 | ________ 15 | X : A;])) 16 | 17 | (define record-attribute-types 18 | _ [] -> [] 19 | Class [(@p Attribute Type) | ClassDef] 20 | -> (let DataTypeName (concat Class Attribute) 21 | DataType (axiom DataTypeName Attribute [attribute Class Type]) 22 | (record-attribute-types Class ClassDef))) 23 | 24 | (declare make-instance [[class Class] --> [instance Class]]) 25 | 26 | (define make-instance 27 | Class -> (let ClassDef (trap-error (get Class classdef) (/. E [])) 28 | (if (empty? ClassDef) 29 | (error "class ~A does not exist~%" Class) 30 | ClassDef))) 31 | 32 | (declare get-value [[attribute Class A] --> [instance Class] --> A]) 33 | 34 | (define get-value 35 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 36 | (get-value-test LookUp))) 37 | 38 | (define get-value-test 39 | [ ] -> (error "no such attribute!~%") 40 | [_ | fail!] -> (error "no such value!~%") 41 | [_ | Value] -> Value) 42 | 43 | (declare has-value? [[attribute Class A] --> [instance Class] --> boolean]) 44 | 45 | (define has-value? 46 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 47 | (has-value-test LookUp))) 48 | 49 | (define has-value-test 50 | [ ] -> (error "no such attribute!~%") 51 | [_ | fail] -> false 52 | _ -> true) 53 | 54 | (declare has-attribute? [symbol --> [instance Class] --> boolean]) 55 | 56 | (define has-attribute? 57 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 58 | (not (empty? LookUp)))) 59 | 60 | (declare change-value [[instance Class] --> [attribute Class A] --> A --> [instance Class]]) 61 | 62 | (define change-value 63 | _ class _ -> (error "cannot change the class of an instance!~%") 64 | [ ] _ _ -> (error "no such attribute!~%") 65 | [[Attribute | _] | Instance] Attribute Value 66 | -> [[Attribute | Value] | Instance] 67 | [Slot | Instance] Attribute Value 68 | -> [Slot | (change-value Instance Attribute Value)]) 69 | 70 | (declare instance-of [[instance Class] --> [class Class]]) 71 | 72 | (define instance-of 73 | [[class | Class] | _] -> Class 74 | _ -> (error "not a class instance!")) 75 | -------------------------------------------------------------------------------- /S39/Test Programs/metaprog.shen: -------------------------------------------------------------------------------- 1 | (define parse 2 | D Sentence -> (let Parse (D [Sentence []]) 3 | (if (parsed? Parse) (output_parse Parse) ungrammatical))) 4 | 5 | (define parsed? 6 | [[] Output] -> true 7 | _ -> false) 8 | 9 | (define output_parse 10 | [_ Output] -> Output) 11 | 12 | (define generate_parser 13 | Grammar -> (map (/. X (compile_rules X)) (group_rules (parenthesise_rules Grammar)))) 14 | 15 | (define parenthesise_rules 16 | [S --> | Rest] -> (parenthesise_rules1 [S -->] Rest)) 17 | 18 | (define parenthesise_rules1 19 | Rule [] -> [Rule] 20 | Rule [S --> | Rest] -> [Rule | (parenthesise_rules1 [S -->] Rest)] 21 | Rule [X | Y] -> (parenthesise_rules1 (append Rule [X]) Y)) 22 | 23 | (define group_rules 24 | Rules -> (group_rules1 Rules [])) 25 | 26 | (define group_rules1 27 | [] Groups -> Groups 28 | [Rule | Rules] Groups -> (group_rules1 Rules (place_in_group Rule Groups))) 29 | 30 | (define place_in_group 31 | Rule [] -> [[Rule]] 32 | Rule [Group | Groups] -> [[Rule | Group] | Groups] 33 | where (belongs-in? Rule Group) 34 | Rule [Group | Groups] -> [Group | (place_in_group Rule Groups)]) 35 | 36 | (define belongs-in? 37 | [S | _] [[S | _] | _] -> true 38 | _ _ -> false) 39 | 40 | (define compile_rules 41 | Rules -> (if (lex? Rules) 42 | (generate_code_for_lex Rules) 43 | (generate_code_for_nonlex Rules))) 44 | 45 | (define lex? 46 | [[S --> Terminal] | _] -> (string? Terminal) 47 | _ -> false) 48 | 49 | (define generate_code_for_nonlex 50 | Rules -> (eval (append [define (get_characteristic_non_terminal Rules) 51 | | (mapapp (fn gcfn_help) Rules)] 52 | [(protect X) -> [fail]]))) 53 | 54 | (define mapapp 55 | _ [] -> [] 56 | F [X | Y] -> (append (F X) (mapapp F Y))) 57 | 58 | (define get_characteristic_non_terminal 59 | [[CNT | _] | _] -> CNT) 60 | 61 | (define gcfn_help 62 | Rule -> [(protect Parameter) 63 | <- 64 | (apply_expansion Rule 65 | [listit [head (protect Parameter)] 66 | [cons [listit | Rule] 67 | [head [tail (protect Parameter)]]]])]) 68 | 69 | (define apply_expansion 70 | [CNT --> | Expansion] Parameter -> (ae_help Expansion Parameter)) 71 | 72 | (define ae_help 73 | [] Code -> Code 74 | [NT | Expansion] Code -> (ae_help Expansion [NT Code])) 75 | 76 | (define generate_code_for_lex 77 | Rules -> (eval (append [define (get_characteristic_non_terminal Rules) 78 | (protect X) -> [fail] where [= (protect X) [fail]] 79 | | (mapapp (fn gcfl_help) Rules)] 80 | [(protect X) -> [fail]]))) 81 | 82 | (define gcfl_help 83 | [CNT --> Terminal] -> [[cons [cons Terminal (protect P)] [cons (protect Parse) []]] 84 | -> [listit (protect P) [cons [listit CNT --> Terminal] (protect Parse)]]]) 85 | 86 | -------------------------------------------------------------------------------- /S39/Lib/Concurrency/concurrency.shen: -------------------------------------------------------------------------------- 1 | (package p (external p) 2 | 3 | (define free-cores? 4 | {--> boolean} 5 | -> (> (- (cores) (processes)) 0)) 6 | 7 | (define p.<-! 8 | {(sproc A) --> A} 9 | Process -> (p.<- Process) where (terminated? Process) 10 | Process -> (p.<-! Process)) 11 | 12 | (define p-and-rotate 13 | {(list (sproc boolean)) --> boolean} 14 | [] -> true 15 | [P | Ps] -> (if (p.<- P) 16 | (p-and-rotate Ps) 17 | false) where (terminated? P) 18 | [P | Ps] -> (p-and-rotate (append Ps [P]))) 19 | 20 | (define p-or-rotate 21 | {(list (sproc boolean)) --> boolean} 22 | [] -> false 23 | [P | Ps] -> (if (p.<- P) 24 | true 25 | (p-or-rotate Ps)) where (terminated? P) 26 | [P | Ps] -> (p-or-rotate (append Ps [P]))) 27 | 28 | (define terminate-proc 29 | {(sproc A) --> thread} 30 | Proc -> (if (terminated? Proc) 31 | (thread-in Proc) 32 | (do (prccount-) (terminate (thread-in Proc))))) 33 | 34 | (define p-and-rotate! 35 | {(list (sproc boolean)) --> boolean} 36 | [] -> true 37 | [P | Ps] -> (if (p.<- P) 38 | (p-and-rotate! Ps) 39 | (do 40 | (map (fn terminate-proc) Ps) 41 | false)) where (terminated? P) 42 | [P | Ps] -> (p-and-rotate! (append Ps [P]))) 43 | 44 | (define p-or-rotate! 45 | {(list (sproc boolean)) --> boolean} 46 | [] -> false 47 | [P | Ps] -> (if (p.<- P) 48 | (do (map (fn terminate-proc) Ps) 49 | true) 50 | (p-or-rotate! Ps)) where (terminated? P) 51 | [P | Ps] -> (p-or-rotate! (append Ps [P]))) 52 | 53 | (define p-cases-h 54 | {(list ((sproc boolean) * (lazy A))) --> A} 55 | [] -> (error "case failure") 56 | [(@p Proc Result) | Cases] 57 | -> (if (p.<- Proc) 58 | (thaw Result) 59 | (p-cases-h Cases)) where (terminated? Proc) 60 | Cases -> (p-cases-h Cases)) 61 | 62 | (define terminate-case 63 | {((sproc A) * B) --> thread} 64 | (@p Proc _) -> (terminate-proc Proc)) 65 | 66 | (define p-anycases-h 67 | {(list ((sproc boolean) * (lazy A))) --> A} 68 | [] -> (error "case failure") 69 | [(@p Proc Result) | Cases] 70 | -> (if (p.<- Proc) 71 | (thaw Result) 72 | (p-cases-h Cases)) where (terminated? Proc) 73 | [Case | Cases] -> (p-cases-h (append Cases [Case]))) 74 | 75 | (define p-cases-h! 76 | {(list ((sproc boolean) * (lazy A))) --> A} 77 | [] -> (error "case failure") 78 | [(@p Proc Result) | Cases] 79 | -> (if (p.<- Proc) 80 | (do (map (fn terminate-case) Cases) 81 | (thaw Result)) 82 | (p-cases-h! Cases)) where (terminated? Proc) 83 | Cases -> (p-cases-h! Cases)) 84 | 85 | (define p-anycases-h! 86 | {(list ((sproc boolean) * (lazy A))) --> A} 87 | [] -> (error "case failure") 88 | [(@p Proc Result) | Cases] 89 | -> (if (p.<- Proc) 90 | (do (map (fn terminate-case) Cases) 91 | (thaw Result)) 92 | (p-cases-h! Cases)) where (terminated? Proc) 93 | [Case | Cases] -> (p-anycases-h! (append Cases [Case]))) ) -------------------------------------------------------------------------------- /S39/Lib/StLib/Vectors/macros.shen: -------------------------------------------------------------------------------- 1 | (package vector [newv for overwrite insert ignore depopulate populate populated? 2 | vector->list v-op1 v-op2 array] 3 | 4 | (defmacro vector-macros 5 | [:= V Is] -> (<-array V Is) 6 | [V Is := V* Is* | Key] -> (key V Is (array-> V Is (<-array V* Is*)) Key) 7 | [V Is := X | Key] -> (key V Is (array-> V Is X) Key) 8 | [array-> V Is X] -> (array-> V Is X) 9 | [array Is] -> (build-array Is) 10 | [populate F [cons I Is]] -> (unfold-populate F [cons I Is]) 11 | [vector->list V] -> [vector->list V []] 12 | [v-op1 F V] -> [v-op1 F V []] 13 | [v-op2 F V1 V2] -> [v-op2 F V1 V2 []]) 14 | 15 | (define key 16 | _ _ Assign [] -> Assign 17 | _ _ Assign [error] -> Assign 18 | V Is Assign [ignore] -> [trap-error Assign [/. (newv) V]] 19 | V Is Assign [insert X] -> [trap-error Assign [/. (newv) [V Is := X]]] 20 | V Is Assign [overwrite] -> [trap-error Assign [/. (newv) [depopulate V Is]]] 21 | _ _ _ Key -> (error "key not recognised ~A~%" Key)) 22 | 23 | (define build-array 24 | [cons I []] -> [vector I] 25 | [cons I J] -> (let N (newv) 26 | V (newv) 27 | [let V [vector I] 28 | [for N = 1 [<= N I] [vector-> V N (build-array J)]]]) 29 | X -> (error "array cannot macro expand the dimensional argument ~R~%" X)) 30 | 31 | (define depopulate 32 | V [I] -> (address-> V I (fail)) 33 | V [I | Is] -> (do (depopulate (<-vector V I) Is) V) 34 | _ X -> (error "depopulate cannot use the dimensional argument ~S~%" X)) 35 | 36 | (define populated? 37 | V [I] -> (not (= (<-address V I) (fail))) 38 | V [I | Is] -> (populated? (<-address V I) Is)) 39 | 40 | (declare depopulate [[vector A] --> [[list number] --> [vector A]]]) 41 | (declare populated? [[vector A] --> [[list number] --> boolean]]) 42 | (declare populate [[number --> A] --> [number --> [vector A]]]) 43 | 44 | (define unfold-populate 45 | F [cons I []] -> [populate F I] 46 | F [cons I Is] -> [populate [/. (newv) (unfold-populate F Is)] I]) 47 | 48 | (define populate 49 | F I -> (let V (absvector (+ I 1)) 50 | StV (address-> V 0 I) 51 | (for N = 1 (<= N I) (address-> V N (F N))))) 52 | 53 | (define <-array 54 | V [cons I []] -> [<-vector V I] 55 | V [cons I Is] -> (<-array [<-vector V I] Is) 56 | _ Dims -> (error "cannot macro expand the dimensional argument ~R~%" Dims)) 57 | 58 | (define array-> 59 | V [cons I []] X -> [vector-> V I X] 60 | V Is X -> (let Original (newv) 61 | [let Original V 62 | (unfold-vector-assignment Original Original Is X)])) 63 | 64 | (define unfold-vector-assignment 65 | Original V [cons I []] X -> (let NewVector (newv) 66 | [let NewVector [vector-> V I X] 67 | Original]) 68 | Original V [cons I J] X -> (let NewVector (newv) 69 | [let NewVector [<-vector V I] 70 | (unfold-vector-assignment Original NewVector J X)]) 71 | _ _ Dims _ -> (error "cannot macro expand the dimensional argument ~R~%" Dims)) ) -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/numerals.shen: -------------------------------------------------------------------------------- 1 | (package numerals [hex octal duodecimal binary 2 | n-op2 n-op1 n+ n- n* n/ 3 | | (append (external numerals) (external maths))] 4 | 5 | (defmacro numeral-macro 6 | [n-op2 Op M N] -> [n-op2 Op M N [radix M]] 7 | [n-op1 Op M] -> [n-op1 Op M [radix M]] 8 | [n+ M N] -> [n+ M N [radix M]] 9 | [n- M N] -> [n- M N [radix M]] 10 | [n* M N] -> [n* M N [radix M]] 11 | [n/ M N] -> [n/ M N [radix M]]) 12 | 13 | (define n-op2 14 | {(number --> number --> number) --> numeral --> numeral --> number --> numeral} 15 | Op M N Base -> (n# (Op (n#->n M) (n#->n N)) Base)) 16 | 17 | (define n-op1 18 | {(number --> number) --> numeral --> number --> numeral} 19 | Op M Base -> (n# (Op (n#->n M)) Base)) 20 | 21 | (define n+ 22 | {numeral --> numeral --> number --> numeral} 23 | M N Base -> (n-op2 (fn +) M N Base)) 24 | 25 | (define n* 26 | {numeral --> numeral --> number --> numeral} 27 | M N Base -> (n-op2 (fn *) M N Base)) 28 | 29 | (define n- 30 | {numeral --> numeral --> number --> numeral} 31 | M N Base -> (n-op2 (fn -) M N Base)) 32 | 33 | (define n/ 34 | {numeral --> numeral --> number --> numeral} 35 | M N Base -> (n-op2 (fn /) M N Base)) 36 | 37 | (define binary 38 | {number --> numeral} 39 | N -> (n# N 2)) 40 | 41 | (define hex 42 | {number --> numeral} 43 | N -> (n# N 16)) 44 | 45 | (define octal 46 | {number --> numeral} 47 | N -> (n# N 8)) 48 | 49 | (define duodecimal 50 | {number --> numeral} 51 | N -> (n# N 12)) 52 | 53 | (define n->numeral 54 | {number --> number --> (list number)} 55 | N Base -> [N] where (> Base N) 56 | N Base -> (let E (largest-expt N Base 0) 57 | Unit (power Base E) 58 | D (div N Unit) 59 | Numeral [D | (n-zeros E)] 60 | Remainder (- N (* D Unit)) 61 | (add Numeral (n->numeral Remainder Base) Base))) 62 | 63 | (define largest-expt 64 | {number --> number --> number --> number} 65 | N Base Expt -> (- Expt 1) where (> (power Base Expt) N) 66 | N Base Expt -> (largest-expt N Base (+ Expt 1))) 67 | 68 | (define n-zeros 69 | {number --> (list number)} 70 | 0 -> [] 71 | N -> [0 | (n-zeros (- N 1))]) 72 | 73 | (define add 74 | {(list number) --> (list number) --> number --> (list number)} 75 | L1 L2 Base -> (reverse (add-h (reverse L1) (reverse L2) Base 0))) 76 | 77 | (define add-h 78 | {(list number) --> (list number) --> number --> number --> (list number)} 79 | [] [] _ 0 -> [] 80 | [] [] _ Carry -> [Carry] 81 | [] L2 Base Carry -> (add-h [0] L2 Base Carry) 82 | L1 [] Base Carry -> (add-h L1 [0] Base Carry) 83 | [N1 | L1] [N2 | L2] Base Carry -> (let M (+ N1 N2 Carry) 84 | (if (< M Base) 85 | [M | (add-h L1 L2 Base 0)] 86 | [(- Base M) | (add-h L1 L2 Base 1)]))) 87 | 88 | ) 89 | 90 | 91 | -------------------------------------------------------------------------------- /kl/library.go: -------------------------------------------------------------------------------- 1 | package kl 2 | 3 | import ( 4 | "math" 5 | "os" 6 | "path" 7 | ) 8 | 9 | func PackagePath() string { 10 | gopath := os.Getenv("GOPATH") 11 | return path.Join(gopath, "src/github.com/tiancaiamao/shen-go") 12 | } 13 | 14 | func cadr(o Obj) Obj { 15 | return car(cdr(o)) 16 | } 17 | 18 | func caddr(o Obj) Obj { 19 | return car(cdr(cdr(o))) 20 | } 21 | 22 | func cdddr(o Obj) Obj { 23 | return cdr(cdr(cdr(o))) 24 | } 25 | 26 | func cadddr(o Obj) Obj { 27 | return car(cdr(cdr(cdr(o)))) 28 | } 29 | 30 | func reverse(o Obj) Obj { 31 | ret := Nil 32 | for o != Nil { 33 | ret = cons(car(o), ret) 34 | o = cdr(o) 35 | } 36 | return ret 37 | } 38 | 39 | func equal(x, y Obj) Obj { 40 | if x == y { 41 | return True 42 | } 43 | if *x != *y { 44 | return False 45 | } 46 | 47 | switch *x { 48 | case scmHeadNumber: 49 | if !isFixnum(x) && !isFixnum(y) { 50 | if mustNumber(x) == mustNumber(y) { 51 | return True 52 | } 53 | } 54 | // x == y is checked already 55 | return False 56 | case scmHeadString: 57 | if mustString(x) != mustString(y) { 58 | return False 59 | } 60 | case scmHeadBoolean: 61 | if x != y { 62 | return False 63 | } 64 | case scmHeadSymbol: 65 | if x != y { 66 | return False 67 | } 68 | case scmHeadNull: 69 | if *y != scmHeadNull { 70 | return False 71 | } 72 | case scmHeadPair: 73 | // TODO: maybe cycle exists! 74 | if x != y { 75 | if equal(car(x), car(y)) == False { 76 | return False 77 | } 78 | if equal(cdr(x), cdr(y)) == False { 79 | return False 80 | } 81 | } 82 | case scmHeadStream, scmHeadProcedure /* , scmHeadPrimitive */ : 83 | if x != y { 84 | return False 85 | } 86 | case scmHeadVector: 87 | v1 := mustVector(x) 88 | v2 := mustVector(y) 89 | if len(v1) != len(v2) { 90 | return False 91 | } 92 | for i := 0; i < len(v1); i++ { 93 | if v1[i] != nil || v2[i] != nil { 94 | if equal(v1[i], v2[i]) != True { 95 | return False 96 | } 97 | } 98 | } 99 | } 100 | 101 | return True 102 | } 103 | 104 | func listLength(l Obj) int { 105 | count := 0 106 | for *l == scmHeadPair { 107 | count++ 108 | l = cdr(l) 109 | } 110 | return count 111 | } 112 | 113 | func ListToSlice(l Obj) []Obj { 114 | var ret []Obj 115 | for *l == scmHeadPair { 116 | ret = append(ret, car(l)) 117 | l = cdr(l) 118 | } 119 | return ret 120 | } 121 | 122 | func Cadr(o Obj) Obj { 123 | return cadr(o) 124 | } 125 | 126 | func Car(o Obj) Obj { 127 | return car(o) 128 | } 129 | 130 | func Cdr(o Obj) Obj { 131 | return cdr(o) 132 | } 133 | 134 | func Cons(x, y Obj) Obj { 135 | return cons(x, y) 136 | } 137 | 138 | // isInteger determinate whether a float64 is actually a precise integer. 139 | // Judge is according to IEEE754 standard. 140 | func isPreciseInteger(f float64) bool { 141 | exp := math.Ilogb(f) 142 | if exp < 0 && exp != math.MinInt32 { 143 | return false 144 | } 145 | 146 | if exp >= 52 { 147 | return true 148 | } 149 | 150 | bits := math.Float64bits(f) 151 | return (bits << uint(12+exp)) == 0 152 | } 153 | 154 | func BindSymbolFunc(sym Obj, f Obj) { 155 | mustSymbol(sym).function = f 156 | } 157 | -------------------------------------------------------------------------------- /S39/Lib/Tk/web.shen: -------------------------------------------------------------------------------- 1 | (package tk (external stlib) 2 | 3 | (define wait-till-ready 4 | {string --> boolean} 5 | File -> true where (check-completion? (read-file-as-bytelist File)) 6 | File -> (wait-till-ready File)) 7 | 8 | (define read-ascii 9 | {(list number) --> string --> (list number)} 10 | ASCII _ -> ASCII where (check-completion? ASCII) 11 | ASCII In -> (read-ascii (read-file-as-bytelist In) In)) 12 | 13 | (define check-completion? 14 | {(list number) --> boolean} 15 | [101 111 116 | _] -> true 16 | [_ | X] -> (check-completion? X) 17 | [] -> false) 18 | 19 | (define url->text 20 | {(list number) --> (list string)} 21 | ASCII -> (clump (map (fn n->string) (remove-markup ASCII 1 [])) "")) 22 | 23 | (define remove-markup 24 | {(list number) --> number --> (list number) --> (list number)} 25 | [] _ Rev -> (reverse Rev) 26 | [62 | X] _ Rev -> (remove-markup X 1 Rev) 27 | [60 | X] _ Rev -> (remove-markup X 0 Rev) 28 | [_ | X] 0 Rev -> (remove-markup X 0 Rev) 29 | [X | Y] N Rev -> (remove-markup Y N [X | Rev])) 30 | 31 | (define clump 32 | {(list string) --> string --> (list string)} 33 | [] "" -> [] 34 | [] Word -> [Word] 35 | [WS | Strings] "" -> (clump Strings "") where (whitespace? WS) 36 | [WS | Strings] Word -> [Word | (clump Strings "")] where (whitespace? WS) 37 | [Punctuation | Strings] "" -> [Punctuation | (clump Strings "")] where (not (alphanum? Punctuation)) 38 | [Punctuation | Strings] Word -> [Word Punctuation | (clump Strings "")] where (not (alphanum? Punctuation)) 39 | [S | Strings] Word -> (clump Strings (cn Word S))) 40 | 41 | (define text->sentences 42 | {(list string) --> number --> (list (list string))} 43 | Text Max -> (text->sentences-h Text [] Max)) 44 | 45 | (define text->sentences-h 46 | {(list string) --> (list string) --> number --> (list (list string))} 47 | [] Sentence _ -> [Sentence] 48 | Text Sentence Max -> (text->sentences-h Text [] Max) where (> (length Sentence) Max) 49 | ["." (@s Cap Letters) | Text] Sentence Max 50 | -> (if (starts-in-uppercase? Sentence) 51 | [Sentence | (text->sentences-h [(@s Cap Letters) | Text] [] Max)] 52 | (text->sentences-h [(@s Cap Letters) | Text] [] Max)) where (uppercase? Cap) 53 | [Word | Text] Sentence Max -> (text->sentences-h Text (append Sentence [Word]) Max)) 54 | 55 | (define starts-in-uppercase? 56 | {(list string) --> boolean} 57 | [(@s Cap _) | _] -> (uppercase? Cap) 58 | _ -> false) 59 | 60 | (define links 61 | {(list number) --> (list string)} 62 | ASCII -> (links-h ASCII 0 [])) 63 | 64 | (define links-h 65 | {(list number) --> number --> (list number) --> (list string)} 66 | [] _ [] -> [] 67 | [34 | ASCII] 1 Link -> [(implode Link) | (links-h ASCII 0 [])] 68 | [34 104 116 116 112 | ASCII] 0 Link -> (links-h ASCII 1 [104 116 116 112]) 69 | [X | ASCII] 1 Link -> (links-h ASCII 1 (append Link [X])) 70 | [_ | ASCII] _ _ -> (links-h ASCII 0 [])) 71 | 72 | (define implode 73 | {(list number) --> string} 74 | [] -> "" 75 | [X | Y] -> (cn (n->string X) (implode Y))) ) -------------------------------------------------------------------------------- /S39/Sources/load.shen: -------------------------------------------------------------------------------- 1 | \\ Copyright (c) 2010-2019, Mark Tarver 2 | 3 | \\ All rights reserved. 4 | 5 | (package shen [] 6 | 7 | (define load 8 | File -> (let TC? (value *tc*) 9 | Load (time (load-help TC? (read-file File))) 10 | Infs (if TC? (output "~%typechecked in ~A inferences~%" (inferences)) skip) 11 | loaded)) 12 | 13 | (define load-help 14 | false Code -> (eval-and-print Code) 15 | _ Code -> (check-eval-and-print Code)) 16 | 17 | (define eval-and-print 18 | X -> (map (/. Y (output "~S~%" (eval-kl (shen->kl Y)))) X)) 19 | 20 | (define check-eval-and-print 21 | X -> (let Table (mapcan (/. Y (typetable Y)) X) 22 | Assume (trap-error (assumetypes Table) (/. E (unwind-types E Table))) 23 | (trap-error (work-through X) 24 | (/. E (unwind-types E Table))))) 25 | 26 | (define typetable 27 | [define F { | X] -> [F (rectify-type (type-F F X))] 28 | [define F | _] -> (error "missing { in ~A~%" F) 29 | _ -> []) 30 | 31 | (define type-F 32 | _ [} | _] -> [] 33 | F [X | Y] -> [X | (type-F F Y)] 34 | F _ -> (error "missing } in ~A~%" F)) 35 | 36 | (define assumetypes 37 | [] -> [] 38 | [F Type | Table] -> (do (declare F Type) (assumetypes Table)) 39 | _ -> (simple-error "implementation error in shen.assumetype")) 40 | 41 | (define unwind-types 42 | E [F _ | Table] -> (do (destroy F) (unwind-types E Table)) 43 | E _ -> (simple-error (error-to-string E))) 44 | 45 | (define work-through 46 | [] -> [] 47 | [X Colon A | Y] -> (let Check (typecheck X A) 48 | (if (= Check false) 49 | (type-error) 50 | (let Eval (eval-kl (shen->kl X)) 51 | Message (output "~S : ~R~%" Eval (pretty-type Check)) 52 | (work-through Y)))) where (= Colon (intern ":")) 53 | [X | Y] -> (work-through [X (intern ":") (protect A) | Y]) 54 | _ -> (simple-error "implementation error in shen.work-through")) 55 | 56 | (define pretty-type 57 | [[list A] --> [str [list A] B]] -> [[list A] ==> B] 58 | [X | Y] -> (map (/. Z (pretty-type Z)) [X | Y]) 59 | A -> A) 60 | 61 | (define type-error 62 | -> (error "type error~%")) 63 | 64 | (define bootstrap 65 | File -> (let KLFile (klfile File) 66 | Code (read-file File) 67 | Open (open KLFile out) 68 | KL (map (/. X (partial (shen->kl-h X))) Code) 69 | Write (write-kl KL Open) 70 | KLFile)) 71 | 72 | (define partial 73 | [f-error F] -> [simple-error (cn "partial function " (str F))] 74 | [X | Y] -> (map (/. Z (partial Z)) [X | Y]) 75 | X -> X) 76 | 77 | (define write-kl 78 | [] Open -> (close Open) 79 | [KL | KLs] Open -> (write-kl KLs (do (write-kl-h KL Open) 80 | Open)) where (cons? KL) 81 | [_ | KLs] Open -> (write-kl KLs Open)) 82 | 83 | (define write-kl-h 84 | [defun fail [] _] Open -> (pr "(defun fail () shen.fail!)" Open) 85 | KL Open -> (pr (make-string "~R~%~%" KL) Open)) 86 | 87 | (define klfile 88 | "" -> ".kl" 89 | ".shen" -> ".kl" 90 | (@s S Ss) -> (@s S (klfile Ss))) ) -------------------------------------------------------------------------------- /src/compiler.shen: -------------------------------------------------------------------------------- 1 | (define parse 2 | Env [] -> [$const []] 3 | Env X -> [$const X] where (or (number? X) (string? X) (boolean? X)) 4 | Env X -> (if (element? X Env) X [$const X]) where (symbol? X) 5 | Env [if X Y Z] -> [$if (parse Env X) (parse Env Y) (parse Env Z)] 6 | Env [do X Y] -> [$do (parse Env X) (parse Env Y)] 7 | Env [lambda X Y] -> [$lambda [X] (parse (cons X Env) Y)] 8 | 9 | Env [defun F X Y] -> [ns2-set [$const F] [$lambda X (parse X Y)]] 10 | Env [let X Y Z] -> [[$lambda [X] (parse (cons X Env) Z)] (parse Env Y)] 11 | Env [trap-error Body Handler] -> [try-catch [$lambda [] (parse Env Body)] (parse Env Handler)] 12 | 13 | Env [or X Y] -> (parse Env [if X true [if Y true false]]) 14 | Env [and X Y] -> (parse Env [if X [if Y true false] false]) 15 | Env [cond [true Action]] -> (parse Env Action) 16 | Env [cond [Case Action]] -> (parse Env [if Case Action [simple-error "no cond match"]]) 17 | Env [cond [Case Action] | More] -> (parse Env [if Case Action [cond | More]]) 18 | Env [freeze Body] -> [$lambda [] (parse Env Body)] 19 | Env [type Exp _] -> (parse Env Exp) 20 | 21 | Env [F | X] -> [(parse-app Env F) | (map (parse Env) X)] where (symbol? F) 22 | Env [F | X] -> (map (parse Env) [F | X])) 23 | 24 | 25 | (define parse-app 26 | Env F -> F where (element? F Env) 27 | _ F -> [$global F]) 28 | 29 | 30 | (define peval-t 31 | BC [$const X] -> (cons [return [$const X]] BC) 32 | BC [$global X] -> (cons [return [$global X]] BC) 33 | BC [$if X Y Z] -> (let Y1 (peval0 Y) 34 | Z1 (peval0 Z) 35 | Tmp (gensym ifres) 36 | (peval BC X (/. BC1 (/. REG1 37 | (cons [if REG1 Y1 Z1] BC1))))) 38 | BC [$do X Y] -> (peval BC X (/. BC1 (/. X1 39 | (peval-t (cons [ignore X1] BC1) Y)))) 40 | BC [$lambda Args Body] -> (cons [return [lambda Args (peval0 Body)]] BC) 41 | BC [F | Args] -> (peval-call BC [F | Args] [] 42 | (/. BC1 (/. REGS 43 | (cons [tailapply | REGS] BC1)))) 44 | BC X -> (cons [return X] BC)) 45 | 46 | (define peval 47 | BC [$const X] CC -> (CC BC [$const X]) 48 | BC [$global X] CC -> (CC BC [$global X]) 49 | BC [$if X Y Z] CC -> (let TMP (gensym ifres) 50 | (let Y1 (peval [] Y (/. BC1 (/. Y1 (cons block (reverse (cons [<- TMP Y1] BC1)))))) 51 | Z1 (peval [] Z (/. BC1 (/. Z1 (cons block (reverse (cons [<- TMP Z1] BC1)))))) 52 | (peval BC X (/. BC1 (/. REG1 53 | (CC [[if REG1 Y1 Z1] [var TMP] | BC1] TMP)))))) 54 | BC [$do X Y] CC -> (peval BC X (/. BC1 (/. X1 55 | (peval (cons [ignore X1] BC1) Y CC)))) 56 | BC [$lambda ARGS BODY] CC -> (let TMP (gensym tmp) 57 | (CC (cons [<= TMP [lambda ARGS (peval0 BODY)]] BC) TMP)) 58 | BC [F | ARGS] CC -> (peval-call BC [F | ARGS] [] 59 | (/. BC1 (/. REGS 60 | (let TMP (gensym tmp) 61 | (CC (cons [<= TMP [call | REGS]] BC1) TMP))))) 62 | BC X CC -> (CC BC X)) 63 | 64 | (define peval-call 65 | BC [] REGS CC -> (CC BC (reverse REGS)) 66 | BC [X | Xs] REGS CC -> (peval BC X (/. BC1 (/. X1 67 | (peval-call BC1 Xs (cons X1 REGS) CC))))) 68 | 69 | (define peval0 70 | Exp -> (let RET (reverse (peval-t [] Exp)) 71 | (if (= 1 (length RET)) 72 | (hd RET) 73 | (cons block RET)))) 74 | 75 | (define codegen 76 | Input -> (let Ast (parse () Input) (peval0 Ast))) 77 | 78 | (define compile-file 79 | Fin Fout -> (let Expr (read-file Fin) 80 | Expr1 (macroexpand [do | Expr]) 81 | (let BC (codegen Expr1) 82 | Str (make-string "~R" BC) 83 | (write-to-file Fout Str)))) 84 | -------------------------------------------------------------------------------- /S39/Lib/Tk/package.shen: -------------------------------------------------------------------------------- 1 | (package tk 2 | 3 | [-foreground -background -highlightthickness -type yesnocancel -activebackground -highlightcolor -cursor 4 | -anchor n ne e se s sw w nw -state normal active disabled -overrelief -compound center -insertofftime -insertontime 5 | -outline -color -arrow both first last -start -extent -wrap none char word -spacing1 -spacing2 -spacing3 -rmargin 6 | -overstrike -offset -underline -fg -command -text button label -selectbackground -selectborderwidth hollow 7 | entry text canvas line oval arc rectangle polygon -bg groove -activeforeground -disabledforeground 8 | cursor sunken flat raised side -fill -color left right top bottom x y -padx -pady -ipadx -takefocus solid 9 | -ipady -height -width -borderwidth -bd -repeatdelay -repeatinterval -justify -underline -wraplength -relief -family 10 | frame window -side -variable -font -label -message grey -image -size -bitmap -show -selectforeground 11 | (protect X_cursor) arrow based_arrow_down based_arrow_up boat bogosity bottom_left_corner rescale state 12 | -multiple -slant italic bold bottom_right_corner bottom_side bottom_tee box_spiral center_ptr circle clock 13 | coffee_mug cross cross_reverse crosshair diamond_cross dot dotbox double_arrow -setgrid -xscrollcommand exists 14 | draft_large draft_small draped_box exchange fleur gobbler gumby hand1 hand2 heart icon iron_cross left_ptr left_side 15 | left_tee leftbutton ll_angle lr_angle man middlebutton mouse pencil pirate plus question_arrow right_ptr right_side 16 | right_tee rightbutton rtl_logo sailboat sb_down_arrow sb_h_double_arrow sb_left_arrow sb_right_arrow sb_up_arrow 17 | sb_v_double_arrowshuttle sizing spider spraycan star target tcross top_left_arrow top_left_corner top_right_corner 18 | top_side top_tee trek ul_angle umbrella ur_angle watch xterm -title -icon -yscrollcommand -autoseparators 19 | -blockcursor -endline -inactiveselectbackground -insertunfocussed -maxundo -tabstyle -undo tabular wordprocessor 20 | -closeenough -confine -scrollregion -xscrollincrement -yscrollincrement -colormap -screen -use -after -before 21 | -expand -in -column -columnspan -row -rowspan -sticky -weight -slant -tag roman italic scrollbar eot . tk.destroy 22 | manager name parent toplevel height width ismapped pointerx pointery reqheight reqwidth rootx rooty 23 | screenheight screenwidth viewable] 24 | 25 | (declare url [string --> [list number]]) 26 | (declare require [string --> symbol]) 27 | (declare tcl->shen [--> unit]) 28 | (declare shen->tcl [string --> string]) 29 | (declare event-loop [--> A]) 30 | (declare types [symbol --> [list symbol]]) 31 | (declare my-pack [[list widget] --> [[options pack] --> [list widget]]]) 32 | (declare my-grid [[list [list widget]] --> [[options grid] --> [list [list widget]]]]) 33 | (declare unpack [[list widget] --> [list widget]]) 34 | (declare exit [--> symbol]) 35 | (declare widgetclass [symbol --> symbol]) 36 | (declare putw [A --> [[attribute A B] --> [B --> B]]]) 37 | (declare getw [A --> [[attribute A B] --> B]]) 38 | (declare my-image [symbol --> [string --> [[options image] --> image]]]) 39 | (declare my-font [symbol --> [[options font] --> font]]) 40 | (declare my-messagebox [[options messagebox] --> string]) 41 | (declare menu [symbol --> [number --> [window * [canvas * [list button]]]]]) 42 | (declare root [--> window]) 43 | (declare my-openfile [[options openfile] --> string]) 44 | (declare winfo [symbol --> [[attribute winfo A] --> A]]) 45 | (declare tk.destroy [symbol --> symbol]) 46 | (declare bindkey [widget --> [event --> [[lazy A] --> [lazy A]]]]) 47 | (declare wipe [canvas --> [symbol --> symbol]]) ) -------------------------------------------------------------------------------- /S39/Test Programs/classes-defaults.shen: -------------------------------------------------------------------------------- 1 | (datatype class 2 | 3 | Slots : [slot]; 4 | _______________________________________ 5 | (defclass Class Slots) : (class Class); 6 | 7 | Attribute : symbol; Type : symbol; 8 | =================================== 9 | (@p Attribute Type) : slot; 10 | 11 | Default : Type; Attribute : symbol; Type : symbol; 12 | ================================================== 13 | (@p Attribute Type Default) : slot;) 14 | 15 | (define defclass 16 | Class ClassDef -> (let Attributes (map fst ClassDef) 17 | Types (record-attribute-types Class ClassDef) 18 | Assoc (map assign-values ClassDef) 19 | NewClassDef [[class | Class] | Assoc] 20 | Store (put-prop Class classdef NewClassDef) 21 | RecordClass (axiom Class Class [class Class]) 22 | Class)) 23 | 24 | (define assign-values 25 | (@p Attribute _ Value) -> [Attribute | Value] 26 | (@p Attribute _) -> [Attribute | fail!]) 27 | 28 | (define axiom 29 | DataType X A -> (eval [datatype DataType 30 | ________ 31 | X : A;])) 32 | 33 | (define record-attribute-types 34 | _ [] -> [] 35 | Class [(@p Attribute Type _) | ClassDef] 36 | -> (let DataTypeName (concat Class Attribute) 37 | DataType (axiom DataTypeName Attribute [attribute Class Type]) 38 | (record-attribute-types Class ClassDef)) 39 | Class [(@p Attribute Type) | ClassDef] 40 | -> (let DataTypeName (concat Class Attribute) 41 | DataType (axiom DataTypeName Attribute [attribute Class Type]) 42 | (record-attribute-types Class ClassDef))) 43 | 44 | (declare make-instance [[class Class] --> [instance Class]]) 45 | 46 | (define make-instance 47 | Class -> (let ClassDef (get-prop Class classdef []) 48 | (if (empty? ClassDef) 49 | (error "class ~A does not exist~%" Class) 50 | ClassDef))) 51 | 52 | (declare get-value [[attribute Class A] --> [instance Class] --> A]) 53 | 54 | (define get-value 55 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 56 | (get-value-test LookUp))) 57 | 58 | (define get-value-test 59 | [ ] -> (error "no such attribute!~%") 60 | [_ | fail!] -> (error "no such value!~%") 61 | [_ | Value] -> Value) 62 | 63 | (declare has-value? [[attribute Class A] --> [instance Class] --> boolean]) 64 | 65 | (define has-value? 66 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 67 | (has-value-test LookUp))) 68 | 69 | (define has-value-test 70 | [ ] -> (error "no such attribute!~%") 71 | [_ | fail!] -> false 72 | _ -> true) 73 | 74 | (declare has-attribute? [symbol --> [instance Class] --> boolean]) 75 | 76 | (define has-attribute? 77 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 78 | (not (empty? LookUp)))) 79 | 80 | (declare change-value [[instance Class] --> [attribute Class A] --> A --> [instance Class]]) 81 | 82 | (define change-value 83 | _ class _ -> (error "cannot change the class of an instance!~%") 84 | [ ] _ _ -> (error "no such attribute!~%") 85 | [[Attribute | _] | Instance] Attribute Value 86 | -> [[Attribute | Value] | Instance] 87 | [Slot | Instance] Attribute Value 88 | -> [Slot | (change-value Instance Attribute Value)]) 89 | 90 | (declare instance-of [[instance Class] --> [class Class]]) 91 | 92 | (define instance-of 93 | [[class | Class] | _] -> Class 94 | _ -> (error "not a class instance!")) 95 | -------------------------------------------------------------------------------- /S39/Lib/Tk/Samples/calculator.shen: -------------------------------------------------------------------------------- 1 | (package calc (external calc) 2 | 3 | (define show 4 | {label --> string --> string} 5 | Display Text -> (let DisplayText (tk.getw Display -text) 6 | (cases (digit? Text) (tk.putw Display -text (cn DisplayText Text)) 7 | (= "(" Text) (tk.putw Display -text (cn DisplayText Text)) 8 | (= ")" Text) (tk.putw Display -text (cn DisplayText Text)) 9 | (= "." Text) (tk.putw Display -text (cn DisplayText Text)) 10 | (element? Text ["+" "-" "*" "/"]) (tk.putw Display -text (@s DisplayText " " Text " ")) 11 | (= Text "sqrt") (tk.putw Display -text (cn "sqrt " DisplayText)) 12 | (= Text "=") (evaluate-display Display DisplayText) 13 | (= Text "cancel") (tk.putw Display -text "")))) 14 | 15 | (defmacro infix 16 | [M Op N] -> [Op M N] where (element? Op [+ / - *])) 17 | 18 | (define calculator 19 | {--> symbol} 20 | -> (let F1Text (tk.putw .below.f1 -text "Calculator") 21 | F1Width (tk.putw .below.f1 -width 20) 22 | F1Command (tk.putw .below.f1 -command (freeze (call-calculator))) 23 | ok)) 24 | 25 | (define call-calculator 26 | {--> symbol} 27 | -> (let Window (tk.widget .calculator window -bg (ide.bg)) 28 | Frame (tk.widget .calculator.buttons frame) 29 | Display (tk.widget .calculator.display label -width 25 -text "") 30 | MakeButton (/. Button Text (tk.widget Button button 31 | -text Text 32 | -bg (ide.bg) 33 | -fg "white" 34 | -relief flat 35 | -width 5 36 | -command (freeze (show Display Text)))) 37 | B0 (MakeButton .calculator.buttons.b0 "0") 38 | B1 (MakeButton .calculator.buttons.b1 "1") 39 | B2 (MakeButton .calculator.buttons.b2 "2") 40 | B3 (MakeButton .calculator.buttons.b3 "3") 41 | B4 (MakeButton .calculator.buttons.b4 "4") 42 | B5 (MakeButton .calculator.buttons.b5 "5") 43 | B6 (MakeButton .calculator.buttons.b6 "6") 44 | B7 (MakeButton .calculator.buttons.b7 "7") 45 | B8 (MakeButton .calculator.buttons.b8 "8") 46 | B9 (MakeButton .calculator.buttons.b9 "9") 47 | BDot (MakeButton .calculator.buttons.bdot ".") 48 | B+ (MakeButton .calculator.buttons.+ "+") 49 | B- (MakeButton .calculator.buttons.- "-") 50 | B* (MakeButton .calculator.buttons.* "*") 51 | B/ (MakeButton .calculator.buttons./ "/") 52 | Sqrt (MakeButton .calculator.buttons.sqrt "sqrt") 53 | BC (MakeButton .calculator.buttons.cancel "cancel") 54 | BLParen (MakeButton .calculator.buttons.lparen "(") 55 | BRParen (MakeButton .calculator.buttons.rparen ")") 56 | B= (MakeButton .calculator.buttons.= "=") 57 | PackB (tk.grid [[B0 B1 B2 B3 B4] 58 | [B5 B6 B7 B8 B9] 59 | [B+ B- B* B/ BDot] 60 | [Sqrt BLParen BRParen BC B=]]) 61 | Pack (tk.pack [Display Frame] -side top -pady 10) 62 | ok)) ) -------------------------------------------------------------------------------- /S39/Lib/StLib/IO/files.shen: -------------------------------------------------------------------------------- 1 | (package file [append-files append-files-with-open-stream mapc 2 | copy-file file-size reopen errout copy-file-with-open-stream 3 | file-exists? newv ascii] 4 | 5 | (defmacro file-macro 6 | [errout X Default ErrFile] -> (let Err (newv) 7 | Open (newv) 8 | Record (newv) 9 | Close (newv) 10 | E (newv) 11 | [trap-error X [/. E [let Err [error-to-string E] 12 | Open [trap-error [reopen ErrFile] [/. E [open ErrFile out]]] 13 | Record [pr Err Open] 14 | Close [close Open] 15 | Default]]])) 16 | 17 | (define append-files 18 | {(list string) --> string --> string} 19 | Files File -> (let Stream (append-files-with-open-stream Files File) 20 | Close (close Stream) 21 | File)) 22 | 23 | (define append-files-with-open-stream 24 | {(list string) --> string --> (stream out)} 25 | Files File -> (error "cannot read and write to ~A at the same time~%" File) where (element? File Files) 26 | Files File -> (let OutStream (open File out) 27 | Write (mapc (/. F (read&write (open F in) OutStream)) Files) 28 | OutStream)) 29 | 30 | (define read&write 31 | {(stream in) --> (stream out) --> number} 32 | In Out -> (read&write-h (read-byte In) In Out)) 33 | 34 | (define read&write-h 35 | {number --> (stream in) --> (stream out) --> number} 36 | -1 In Out -> -1 37 | Byte In Out -> (read&write-h (read-byte In) In (do (write-byte Byte Out) Out))) 38 | 39 | (define reopen 40 | {string --> (stream out)} 41 | File -> (let ByteList (read-file-as-bytelist File) 42 | Open (open File out) 43 | Write (mapc (/. Byte (write-byte Byte Open)) ByteList) 44 | Open)) 45 | 46 | (define copy-file 47 | {string --> string --> string} 48 | InFile OutFile -> (append-files [InFile] OutFile)) 49 | 50 | (define copy-file-with-open-stream 51 | {string --> string --> (stream out)} 52 | InFile OutFile -> (append-files-with-open-stream [InFile] OutFile)) 53 | 54 | (define file-exists? 55 | {string --> boolean} 56 | File -> (trap-error (do (close (open File in)) true) (/. E false))) 57 | 58 | (define file-size 59 | {string --> number} 60 | File -> (let Stream (open File in) 61 | Size (file-size-loop Stream 0 (read-byte Stream)) 62 | Close (close Stream) 63 | Size)) 64 | 65 | (define file-size-loop 66 | {(stream in) --> number --> number --> number} 67 | _ Size -1 -> Size 68 | Stream Size _ -> (file-size-loop Stream (+ 1 Size) (read-byte Stream))) 69 | 70 | (define ascii 71 | {number --> number --> string --> string} 72 | Min Max File -> (let Bytes (read-file-as-bytelist File) 73 | (scan-bytes Min Max Bytes ""))) 74 | 75 | (define scan-bytes 76 | {number --> number --> (list number) --> string --> string} 77 | Min Max [] S -> S 78 | Min Max [N | Ns] S 79 | -> (scan-bytes Min Max Ns (cn S (n->string N))) 80 | where (and (>= N Min) (<= N Max)) 81 | Min Max [N | _] S -> (error "character has code ~A: parsed to here~%~%~A" N S)) ) 82 | 83 | -------------------------------------------------------------------------------- /S39/Lib/StLib/Encrypt/encrypt.shen: -------------------------------------------------------------------------------- 1 | (package encrypt [e-> <-e ignore populate created random mapc tokenise whitespace? url] 2 | 3 | (define load-and-decrypt-from-web 4 | URL TC? -> (shen.load-help TC? (read-and-decrypt-from-web URL))) 5 | 6 | (define read-and-decrypt-from-web 7 | URL -> (let Crypted (url URL) 8 | CryptedBytes (string->listnum Crypted) 9 | DecryptedBytes (map (fn decrypt-byte) CryptedBytes) 10 | Data (bytes->shen DecryptedBytes) 11 | Data)) 12 | 13 | (define decrypt-from-web-and-read-to-string 14 | URL -> (let Crypted (url URL) 15 | CryptedBytes (string->listnum Crypted) 16 | DecryptedBytes (map (fn decrypt-byte) CryptedBytes) 17 | Data (bytes->string DecryptedBytes) 18 | Data)) 19 | 20 | (define bytes->string 21 | [] -> "" 22 | [Byte | Bytes] -> (cn (n->string Byte) (bytes->string Bytes))) 23 | 24 | (define string->listnum 25 | S -> (map (/. X (hd (read-from-string X))) (tokenise (fn whitespace?) S))) 26 | 27 | (define decrypt-byte 28 | Byte -> (<-vector (value *decrypt*) Byte)) 29 | 30 | (define bytes->shen 31 | ByteList -> (let S-exprs (trap-error (compile (/. X (shen. X)) ByteList) 32 | (/. E (shen.print-residue (value shen.*residue*)))) 33 | Process (shen.process-sexprs S-exprs) 34 | Process)) 35 | 36 | (define e-> 37 | File -> (let Encrypt (map (fn encrypt-byte) (read-file-as-bytelist File)) 38 | (write-procedure File Encrypt encryption))) 39 | 40 | (define <-e 41 | File -> (let Decrypt (map (fn decrypt-byte) (read-file File)) 42 | (write-procedure File Decrypt decryption))) 43 | 44 | (define write-procedure 45 | File Encrypt/Decrypt Flag -> (let OutFile (cn File ".txt") 46 | Stream (open OutFile out) 47 | Write (if (= Flag encryption) 48 | (mapc (/. X (pr (cn (str X) " ") Stream)) Encrypt/Decrypt) 49 | (mapc (/. X (pr (n->string X) Stream)) Encrypt/Decrypt)) 50 | Close (close Stream) 51 | OutFile)) 52 | 53 | (define encrypt-byte 54 | Byte -> (let Bytes (<-vector (value *encrypt*) Byte) 55 | N (length Bytes) 56 | Random (random 1 N) 57 | Encrypt (nth Random Bytes) 58 | Encrypt)) 59 | 60 | (define key 61 | File -> (let Bytes (read-file-as-bytelist File) 62 | Encrypt (populate (/. E []) [256]) 63 | FillEncrypt (set *encrypt* (fill-encrypt-vector Bytes Encrypt 1)) 64 | Decrypt (vector (length Bytes)) 65 | FillDecrypt (set *decrypt* (fill-decrypt-vector Decrypt FillEncrypt 1)) 66 | created)) 67 | 68 | (define fill-encrypt-vector 69 | [] Encrypt _ -> Encrypt 70 | [Byte | Bytes] Encrypt N -> (fill-encrypt-vector Bytes 71 | (augment-vector Byte Encrypt N) 72 | (+ N 1))) 73 | 74 | (define augment-vector 75 | Byte Encrypt N -> (let Ns (<-vector Encrypt Byte) (vector-> Encrypt Byte [N | Ns]))) 76 | 77 | (define fill-decrypt-vector 78 | Decrypt <> _ -> Decrypt 79 | Decrypt (@v E Encrypt) N -> (fill-decrypt-vector (fill-decrypt-vector-h Decrypt E N) Encrypt (+ N 1))) 80 | 81 | (define fill-decrypt-vector-h 82 | Decrypt [] _ -> Decrypt 83 | Decrypt [Byte | Bytes] N -> (fill-decrypt-vector-h (Decrypt[Byte] := N) Bytes N)) 84 | 85 | (key "Encrypt/tbos.txt") 86 | 87 | ) -------------------------------------------------------------------------------- /S39/Test Programs/classes-inheritance.shen: -------------------------------------------------------------------------------- 1 | (declare defclass [symbol --> [list [class A]] --> [list [symbol * symbol]] --> symbol]) 2 | 3 | (datatype subtype 4 | 5 | (subtype B A); X : B; 6 | _____________________ 7 | X : A;) 8 | 9 | (define defclass 10 | Class SuperClasses ClassDef 11 | -> (let Attributes (map fst ClassDef) 12 | Inherited (put-prop Class attributes 13 | (append Attributes (collect-attributes SuperClasses))) 14 | Types (record-attribute-types Class ClassDef) 15 | Assoc (map (/. Attribute [Attribute | fail!]) Inherited) 16 | ClassDef [[class | Class] | Assoc] 17 | Store (put-prop Class classdef ClassDef) 18 | RecordClass (axiom Class Class [class Class]) 19 | SubTypes (record-subtypes Class SuperClasses) 20 | Class)) 21 | 22 | (define record-subtypes 23 | _ [] -> _ 24 | Class SuperClasses -> (eval [datatype (concat Class superclasses) 25 | | (record-subtypes-help Class SuperClasses)])) 26 | 27 | (define record-subtypes-help 28 | _ [] -> [] 29 | Class [SuperClass | SuperClasses] -> [_______________________ 30 | [subtype SuperClass Class]; | 31 | (record-subtypes-help Class SuperClasses)]) 32 | 33 | (define collect-attributes 34 | [] -> [] 35 | [SuperClass | SuperClasses] -> (append (get-prop SuperClass attributes []) 36 | (collect-attributes SuperClasses))) 37 | 38 | (define axiom 39 | DataType X A -> (eval [datatype DataType 40 | ________ 41 | X : A;])) 42 | 43 | (define record-attribute-types 44 | _ [] -> [] 45 | Class [(@p Attribute Type) | ClassDef] 46 | -> (let DataTypeName (concat Class Attribute) 47 | DataType (axiom DataTypeName Attribute [attribute Class Type]) 48 | (record-attribute-types Class ClassDef))) 49 | 50 | (declare make-instance [[class Class] --> [instance Class]]) 51 | 52 | (define make-instance 53 | Class -> (let ClassDef (get-prop Class classdef []) 54 | (if (empty? ClassDef) 55 | (error "class ~A does not exist~%" Class) 56 | ClassDef))) 57 | 58 | (declare get-value [[attribute Class A] --> [instance Class] --> A]) 59 | 60 | (define get-value 61 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 62 | (get-value-test LookUp))) 63 | 64 | (define get-value-test 65 | [ ] -> (error "no such attribute!~%") 66 | [_ | fail!] -> (error "no such value!~%") 67 | [_ | Value] -> Value) 68 | 69 | (declare has-value? [[attribute Class A] --> [instance Class] --> boolean]) 70 | 71 | (define has-value? 72 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 73 | (has-value-test LookUp))) 74 | 75 | (define has-value-test 76 | [ ] -> (error "no such attribute!~%") 77 | [_ | fail!] -> false 78 | _ -> true) 79 | 80 | (declare has-attribute? [symbol --> [instance Class] --> boolean]) 81 | 82 | (define has-attribute? 83 | Attribute Instance -> (let LookUp (assoc Attribute Instance) 84 | (not (empty? LookUp)))) 85 | 86 | (declare change-value [[instance Class] --> [attribute Class A] --> A --> [instance Class]]) 87 | 88 | (define change-value 89 | _ class _ -> (error "cannot change the class of an instance!~%") 90 | [ ] _ _ -> (error "no such attribute!~%") 91 | [[Attribute | _] | Instance] Attribute Value 92 | -> [[Attribute | Value] | Instance] 93 | [Slot | Instance] Attribute Value 94 | -> [Slot | (change-value Instance Attribute Value)]) 95 | 96 | (declare instance-of [[instance Class] --> [class Class]]) 97 | 98 | (define instance-of 99 | [[class | Class] | _] -> Class 100 | _ -> (error "not a class instance!")) 101 | -------------------------------------------------------------------------------- /kl/reader.go: -------------------------------------------------------------------------------- 1 | package kl 2 | 3 | import ( 4 | "bufio" 5 | "io" 6 | "strconv" 7 | "unicode" 8 | ) 9 | 10 | type SexpReader struct { 11 | reader *bufio.Reader 12 | buf []rune 13 | // 'extended' reader is used by cora, which handles reader macro ' and [, 14 | // and expect ; as comment 15 | extended bool 16 | } 17 | 18 | func NewSexpReader(r io.Reader, extended bool) *SexpReader { 19 | return &SexpReader{ 20 | reader: bufio.NewReader(r), 21 | extended: extended, 22 | } 23 | } 24 | 25 | func (r *SexpReader) Read() (Obj, error) { 26 | b, err := peekFirstRune(r.reader) 27 | if err != nil { 28 | return Nil, err 29 | } 30 | 31 | if r.extended { 32 | switch b { 33 | case rune(';'): 34 | b, _, err = r.reader.ReadRune() 35 | if err != nil { 36 | return Nil, err 37 | } 38 | for b != '\n' { 39 | b, _, err = r.reader.ReadRune() 40 | if err != nil { 41 | return Nil, err 42 | } 43 | } 44 | return r.Read() 45 | case rune('\''): 46 | return r.readQuoteMacro() 47 | case rune('['): 48 | return r.readListMacro() 49 | } 50 | } 51 | 52 | switch b { 53 | case rune('('): 54 | return r.readSexp() 55 | case rune('"'): 56 | return r.readString() 57 | } 58 | 59 | r.resetBuf() 60 | r.appendBuf(b) 61 | b, _, err = r.reader.ReadRune() 62 | for err == nil { 63 | if r.notSymbolChar(b) { 64 | r.reader.UnreadRune() 65 | break 66 | } 67 | r.appendBuf(b) 68 | b, _, err = r.reader.ReadRune() 69 | } 70 | 71 | return tokenToObj(string(r.buf)), err 72 | } 73 | 74 | func (r *SexpReader) readQuoteMacro() (Obj, error) { 75 | obj, err := r.Read() 76 | if err != nil { 77 | return obj, err 78 | } 79 | return cons(symQuote, cons(obj, Nil)), nil 80 | } 81 | 82 | func (r *SexpReader) readListMacro() (Obj, error) { 83 | hd := MakeSymbol("list") 84 | tmp := Nil 85 | b, err := peekFirstRune(r.reader) 86 | for err == nil && b != ']' { 87 | if b == '.' { 88 | hd = MakeSymbol("list-rest") 89 | } else { 90 | r.reader.UnreadRune() 91 | } 92 | var obj Obj 93 | obj, err = r.Read() 94 | if err == nil { 95 | tmp = cons(obj, tmp) 96 | b, err = peekFirstRune(r.reader) 97 | } 98 | } 99 | return cons(hd, reverse(tmp)), nil 100 | } 101 | 102 | func RconsForm(o Obj) Obj { 103 | return rconsForm(o) 104 | } 105 | 106 | func rconsForm(o Obj) Obj { 107 | if *o == scmHeadPair { 108 | return cons(MakeSymbol("cons"), 109 | cons(rconsForm(car(o)), 110 | cons(rconsForm(cdr(o)), Nil))) 111 | } 112 | return o 113 | } 114 | 115 | func (r *SexpReader) readString() (Obj, error) { 116 | r.resetBuf() 117 | b, _, err := r.reader.ReadRune() 118 | for err == nil && b != rune('"') { 119 | r.appendBuf(b) 120 | b, _, err = r.reader.ReadRune() 121 | } 122 | return MakeString(string(r.buf)), err 123 | } 124 | 125 | func (r *SexpReader) readSexp() (Obj, error) { 126 | ret := Nil 127 | b, err := peekFirstRune(r.reader) 128 | for err == nil && b != ')' { 129 | var obj Obj 130 | r.reader.UnreadRune() 131 | obj, err = r.Read() 132 | if err == nil { 133 | ret = cons(obj, ret) 134 | b, err = peekFirstRune(r.reader) 135 | } 136 | } 137 | return reverse(ret), err 138 | } 139 | 140 | func (r *SexpReader) resetBuf() { 141 | r.buf = r.buf[:0] 142 | } 143 | 144 | func (r *SexpReader) appendBuf(b rune) { 145 | r.buf = append(r.buf, b) 146 | } 147 | 148 | func peekFirstRune(r *bufio.Reader) (rune, error) { 149 | b, _, err := r.ReadRune() 150 | for err == nil && unicode.IsSpace(b) { 151 | b, _, err = r.ReadRune() 152 | } 153 | return b, err 154 | } 155 | 156 | func (r *SexpReader) notSymbolChar(c rune) bool { 157 | if unicode.IsSpace(c) { 158 | return true 159 | } 160 | switch c { 161 | case '(', '"', ')': 162 | return true 163 | case '[', ']': 164 | return r.extended 165 | } 166 | return false 167 | } 168 | 169 | func tokenToObj(str string) Obj { 170 | switch str { 171 | case "true": 172 | return True 173 | case "false": 174 | return False 175 | } 176 | if v, err := strconv.ParseFloat(str, 64); err == nil { 177 | return MakeNumber(v) 178 | } 179 | return MakeSymbol(str) 180 | } 181 | -------------------------------------------------------------------------------- /S39/Lib/Tk/test.shen: -------------------------------------------------------------------------------- 1 | (tc +) 2 | (tk.types +) 3 | (tk.widget .b button) 4 | (tk.pack [.b]) 5 | (tk.putw .b -text "Hello World") 6 | (tk.putw .b -command (freeze (pr "Hello World"))) 7 | (tk.tcl->shen) 8 | (tk.widget .b1 button 9 | -text "Drink Me" 10 | -fg "green" 11 | -bg "yellow" 12 | -command (freeze (pr "I'm shrinking!"))) 13 | 14 | (tk.widget .b2 button 15 | -text "Bang" 16 | -height 50 17 | -width 50 18 | -command (freeze (pr "bang!"))) 19 | 20 | (tk.pack [.b1 .b2]) 21 | (tk.tcl->shen) 22 | (tk.tcl->shen) 23 | (tk.unpack [.b1 .b2]) 24 | 25 | (define mycheckbutton 26 | {symbol --> button} 27 | Widget -> (let Button (tk.widget Widget button) 28 | Relief (tk.putw Button -relief sunken) 29 | BG (tk.putw Button -bg "white") 30 | Text (tk.putw Button -text " ") 31 | Command (tk.putw Button -command (freeze (toggle Button))) 32 | Button)) 33 | 34 | (define toggle 35 | {button --> string} 36 | Widget -> (if (= (tk.getw Widget -text) " ") 37 | (tk.putw Widget -text "X") 38 | (tk.putw Widget -text " "))) 39 | 40 | (mycheckbutton .b6) 41 | (tk.pack [.b6]) 42 | (tk.tcl->shen) 43 | 44 | (tk.widget .e entry) 45 | (tk.pack [.e]) 46 | (tk.getw .e -text) 47 | (tk.putw .e -text "David") 48 | (tk.unpack [.e]) 49 | 50 | (tk.widget .t text) 51 | (tk.pack [.t]) 52 | (tk.getw .t -text) 53 | (tk.putw .t -text "hello world") 54 | (tk.unpack [.t]) 55 | 56 | (tk.image shenlogo "C:/Users/shend/OneDrive/Desktop/Shen Website/logo3.gif") 57 | (tk.widget .l label -image shenlogo) 58 | (tk.pack [.l]) 59 | (tk.unpack [.l]) 60 | 61 | (tk.font mybigfont -family "Courier" -size 20) 62 | (tk.widget .l label -font mybigfont -text "Wow!") 63 | (tk.pack [.l]) 64 | 65 | (tk.messagebox -title "Overwrite?" 66 | -type yesnocancel 67 | -icon warning 68 | -message "Overwrite file?") 69 | 70 | (tk.messagebox -type ok 71 | -title "Query Result" 72 | -message "Found 1000 matches") 73 | 74 | (tk.menu .mymenu 4) 75 | 76 | (tk.putw .mymenu.b1 -text "Selection 1") 77 | (tk.putw .mymenu.b1 -command (freeze (pr "1"))) 78 | 79 | (tk.putw .mymenu.b2 -text "Selection 2") 80 | (tk.putw .mymenu.b2 -command (freeze (pr "2"))) 81 | 82 | (tk.putw .mymenu.b3 -text "Selection 3") 83 | (tk.putw .mymenu.b3 -command (freeze (pr "3"))) 84 | 85 | (tk.putw .mymenu.b4 -text "Selection 4") 86 | (tk.putw .mymenu.b4 -command (freeze (pr "4"))) 87 | 88 | (tk.widget .c canvas -height 200 -width 200) 89 | (tk.pack [.c]) 90 | (tk.draw .c line [0 0 100 100 150 105]) 91 | (tk.draw .c arc [10 20 50 50] -fill "maroon") 92 | 93 | (tk.widget .b1 button -text "1") 94 | (tk.widget .b2 button -text "2") 95 | (tk.widget .b3 button -text "3") 96 | (tk.widget .b4 button -text "4") 97 | (tk.grid [[.b1 .b2] [.b3 .b4]] -padx 10 -pady 10) 98 | 99 | (tk.widget .f1 frame -relief groove -borderwidth 10 -background "orange") 100 | 101 | (tk.widget .f1.b1 button -text "Inside frame f1") 102 | (tk.widget .f1.b2 button -text "Also inside frame f1") 103 | 104 | (tk.pack [.f1.b1 .f1.b2] -side left) 105 | (tk.pack [.f1]) 106 | 107 | (tk.widget .b1 button -text "Outside frame f1") 108 | (tk.widget .b2 button -text "Also outside frame f1") 109 | 110 | (tk.pack [.b1 .b2]) 111 | 112 | (time (tk.url "https://shenlanguage.org/")) 113 | (time (let ASCII (tk.url "https://shenlanguage.org/") 114 | Text (tk.url->text ASCII) 115 | Text)) 116 | (time (let ASCII (tk.url "https://en.wikipedia.org/wiki/Leeds") 117 | Text (tk.url->text ASCII) 118 | Sentences (tk.text->sentences Text 50) 119 | Sentences)) 120 | (time (tk.links (tk.url "https://shenlanguage.org/"))) 121 | 122 | (tk.widget .hello button -text "Hello World" -command (freeze (output "hello world~%"))) 123 | (tk.widget .abort button -text "Abort" -command (freeze (error "aborted"))) 124 | (tk.pack [.hello .abort]) 125 | (tk.event-loop) -------------------------------------------------------------------------------- /S39/Lib/StLib/Maths/rationals.shen: -------------------------------------------------------------------------------- 1 | (package rational (append [r-reduce r= r< r> r>= r<= r+ r- r* r/ r-expr +-inverse *-inverse 2 | r-expt r->n r->pair n->r maths.n->r r-approx maths.lcd-loop 3 | r-op1 r-op2] 4 | (external rational) 5 | (external maths)) 6 | 7 | (define r-op1 8 | {(number --> number) --> rational --> rational} 9 | F R -> (n->r (F (r->n R)))) 10 | 11 | (define r-op2 12 | {(number --> number --> number) --> rational --> rational --> rational} 13 | F R1 R2 -> (n->r (F (r->n R1) (r->n R2)))) 14 | 15 | (define r->n 16 | {rational --> number} 17 | R -> (/ (numerator R) (denominator R))) 18 | 19 | (define r->pair 20 | {rational --> (number * number)} 21 | R -> (@p (numerator R) (denominator R))) 22 | 23 | (define n->r 24 | {number --> rational} 25 | N -> (let Pair (maths.n->r N 1) 26 | (r# (fst Pair) (snd Pair)))) 27 | 28 | (define r-reduce 29 | {rational --> rational} 30 | R -> (r-reduce-help (numerator R) (denominator R))) 31 | 32 | (define r-reduce-help 33 | {number --> number --> rational} 34 | N D -> (let LCD (lcd N D) 35 | (if (= LCD 1) 36 | (r# N D) 37 | (r-reduce-help (/ N LCD) (/ D LCD))))) 38 | 39 | (define r= 40 | {rational --> rational --> boolean} 41 | R1 R2 -> (let A (numerator R1) 42 | B (denominator R1) 43 | C (numerator R2) 44 | D (denominator R2) 45 | (= (* A D) (* B C)))) 46 | 47 | (define r< 48 | {rational --> rational --> boolean} 49 | R1 R2 -> (let A (numerator R1) 50 | B (denominator R1) 51 | C (numerator R2) 52 | D (denominator R2) 53 | (< (* A D) (* B C)))) 54 | 55 | (define r> 56 | {rational --> rational --> boolean} 57 | R1 R2 -> (not (or (r= R1 R2) (r< R1 R2)))) 58 | 59 | (define r>= 60 | {rational --> rational --> boolean} 61 | R1 R2 -> (or (r= R1 R2) (r> R1 R2))) 62 | 63 | (define r<= 64 | {rational --> rational --> boolean} 65 | R1 R2 -> (or (r= R1 R2) (r< R1 R2))) 66 | 67 | (define r+ 68 | {rational --> rational --> rational} 69 | R1 R2 -> (let A (numerator R1) 70 | B (denominator R1) 71 | C (numerator R2) 72 | D (denominator R2) 73 | (r# (+ (* A D) (* B C)) (* B D)))) 74 | 75 | (define r- 76 | {rational --> rational --> rational} 77 | R1 R2 -> (let A (numerator R1) 78 | B (denominator R1) 79 | C (numerator R2) 80 | D (denominator R2) 81 | (r# (- (* A D) (* B C)) (* B D)))) 82 | 83 | (define r* 84 | {rational --> rational --> rational} 85 | R1 R2 -> (let A (numerator R1) 86 | B (denominator R1) 87 | C (numerator R2) 88 | D (denominator R2) 89 | (r# (* A C) (* B D)))) 90 | 91 | (define +-inverse 92 | {rational --> rational} 93 | R -> (let A (numerator R) 94 | B (denominator R) 95 | (r# (~ A) B))) 96 | 97 | (define *-inverse 98 | {rational --> rational} 99 | R -> (let A (numerator R) 100 | B (denominator R) 101 | (r# B A))) 102 | 103 | (define r/ 104 | {rational --> rational --> rational} 105 | R1 R2 -> (r* R1 (*-inverse R2))) 106 | 107 | (define r-expt 108 | {rational --> number --> rational} 109 | R N -> (let A (numerator R) 110 | B (denominator R) 111 | (r# (power A N) (power B N))) where (natural? N) 112 | R N -> (let A (numerator R) 113 | B (denominator R) 114 | (r# (power B (~ N)) (power A (~ N)))) where (and (integer? N) (negative? N)) 115 | _ N -> (error "cannot exponentiate a rational by a non-integer ~A~%" N)) 116 | 117 | (define r-approx 118 | {rational --> number --> rational} 119 | R D -> (approx-r-h (r->n R) D 0)) 120 | 121 | (define approx-r-h 122 | {number --> number --> number --> rational} 123 | Value D N -> (r# N D) where (> (/ N D) Value) 124 | Value D N -> (approx-r-h Value D (+ N 1))) 125 | 126 | ) -------------------------------------------------------------------------------- /S39/KLambda/load.kl: -------------------------------------------------------------------------------- 1 | (defun load (V874) (let W875 (value shen.*tc*) (let W876 (let W877 (get-time run) (let W878 (shen.load-help W875 (read-file V874)) (let W879 (get-time run) (let W880 (- W879 W877) (let W881 (pr (cn " 2 | run time: " (cn (str W880) " secs 3 | ")) (stoutput)) W878))))) (let W882 (if W875 (pr (cn " 4 | typechecked in " (shen.app (inferences) " inferences 5 | " shen.a)) (stoutput)) shen.skip) loaded)))) 6 | 7 | (defun shen.load-help (V885 V886) (cond ((= false V885) (shen.eval-and-print V886)) (true (shen.check-eval-and-print V886)))) 8 | 9 | (defun shen.eval-and-print (V887) (map (lambda Z888 (pr (shen.app (eval-kl (shen.shen->kl Z888)) " 10 | " shen.s) (stoutput))) V887)) 11 | 12 | (defun shen.check-eval-and-print (V889) (let W890 (mapcan (lambda Z891 (shen.typetable Z891)) V889) (let W892 (trap-error (shen.assumetypes W890) (lambda Z893 (shen.unwind-types Z893 W890))) (trap-error (shen.work-through V889) (lambda Z894 (shen.unwind-types Z894 W890)))))) 13 | 14 | (defun shen.typetable (V899) (cond ((and (cons? V899) (and (= define (hd V899)) (and (cons? (tl V899)) (and (cons? (tl (tl V899))) (= { (hd (tl (tl V899)))))))) (cons (hd (tl V899)) (cons (shen.rectify-type (shen.type-F (hd (tl V899)) (tl (tl (tl V899))))) ()))) ((and (cons? V899) (and (= define (hd V899)) (cons? (tl V899)))) (simple-error (cn "missing { in " (shen.app (hd (tl V899)) " 15 | " shen.a)))) (true ()))) 16 | 17 | (defun shen.type-F (V906 V907) (cond ((and (cons? V907) (= } (hd V907))) ()) ((cons? V907) (cons (hd V907) (shen.type-F V906 (tl V907)))) (true (simple-error (cn "missing } in " (shen.app V906 " 18 | " shen.a)))))) 19 | 20 | (defun shen.assumetypes (V910) (cond ((= () V910) ()) ((and (cons? V910) (cons? (tl V910))) (do (declare (hd V910) (hd (tl V910))) (shen.assumetypes (tl (tl V910))))) (true (simple-error "implementation error in shen.assumetype")))) 21 | 22 | (defun shen.unwind-types (V915 V916) (cond ((and (cons? V916) (cons? (tl V916))) (do (destroy (hd V916)) (shen.unwind-types V915 (tl (tl V916))))) (true (simple-error (error-to-string V915))))) 23 | 24 | (defun shen.work-through (V919) (cond ((= () V919) ()) ((and (cons? V919) (and (cons? (tl V919)) (and (cons? (tl (tl V919))) (= (hd (tl V919)) (intern ":"))))) (let W920 (shen.typecheck (hd V919) (hd (tl (tl V919)))) (if (= W920 false) (shen.type-error) (let W921 (eval-kl (shen.shen->kl (hd V919))) (let W922 (pr (shen.app W921 (cn " : " (shen.app (shen.pretty-type W920) " 25 | " shen.r)) shen.s) (stoutput)) (shen.work-through (tl (tl (tl V919))))))))) ((cons? V919) (shen.work-through (cons (hd V919) (cons (intern ":") (cons A (tl V919)))))) (true (simple-error "implementation error in shen.work-through")))) 26 | 27 | (defun shen.pretty-type (V924) (cond ((and (cons? V924) (and (cons? (hd V924)) (and (= list (hd (hd V924))) (and (cons? (tl (hd V924))) (and (= () (tl (tl (hd V924)))) (and (cons? (tl V924)) (and (= --> (hd (tl V924))) (and (cons? (tl (tl V924))) (and (cons? (hd (tl (tl V924)))) (and (= str (hd (hd (tl (tl V924))))) (and (cons? (tl (hd (tl (tl V924))))) (and (cons? (hd (tl (hd (tl (tl V924)))))) (and (= list (hd (hd (tl (hd (tl (tl V924))))))) (and (cons? (tl (hd (tl (hd (tl (tl V924))))))) (and (= () (tl (tl (hd (tl (hd (tl (tl V924)))))))) (and (cons? (tl (tl (hd (tl (tl V924)))))) (and (= () (tl (tl (tl (hd (tl (tl V924))))))) (and (= () (tl (tl (tl V924)))) (= (hd (tl (hd V924))) (hd (tl (hd (tl (hd (tl (tl V924)))))))))))))))))))))))))) (cons (hd (tl (hd (tl (tl V924))))) (cons ==> (tl (tl (hd (tl (tl V924)))))))) ((cons? V924) (map (lambda Z925 (shen.pretty-type Z925)) V924)) (true V924))) 28 | 29 | (defun shen.type-error () (simple-error "type error 30 | ")) 31 | 32 | (defun bootstrap (V926) (let W927 (shen.klfile V926) (let W928 (read-file V926) (let W929 (open W927 out) (let W930 (map (lambda Z931 (shen.partial (shen.shen->kl-h Z931))) W928) (let W932 (shen.write-kl W930 W929) W927)))))) 33 | 34 | (defun shen.partial (V933) (cond ((and (cons? V933) (and (= shen.f-error (hd V933)) (and (cons? (tl V933)) (= () (tl (tl V933)))))) (cons simple-error (cons (cn "partial function " (str (hd (tl V933)))) ()))) ((cons? V933) (map (lambda Z934 (shen.partial Z934)) V933)) (true V933))) 35 | 36 | (defun shen.write-kl (V937 V938) (cond ((= () V937) (close V938)) ((and (cons? V937) (cons? (hd V937))) (shen.write-kl (tl V937) (do (shen.write-kl-h (hd V937) V938) V938))) ((cons? V937) (shen.write-kl (tl V937) V938)) (true (simple-error "partial function shen.write-kl")))) 37 | 38 | (defun shen.write-kl-h (V941 V942) (cond ((and (cons? V941) (and (= defun (hd V941)) (and (cons? (tl V941)) (and (= fail (hd (tl V941))) (and (cons? (tl (tl V941))) (and (= () (hd (tl (tl V941)))) (and (cons? (tl (tl (tl V941)))) (= () (tl (tl (tl (tl V941)))))))))))) (pr "(defun fail () shen.fail!)" V942)) (true (pr (shen.app V941 " 39 | 40 | " shen.r) V942)))) 41 | 42 | (defun shen.klfile (V943) (cond ((= "" V943) ".kl") ((= ".shen" V943) ".kl") ((shen.+string? V943) (@s (hdstr V943) (shen.klfile (tlstr V943)))) (true (simple-error "partial function shen.klfile")))) 43 | 44 | -------------------------------------------------------------------------------- /kl/eval_test.go: -------------------------------------------------------------------------------- 1 | package kl 2 | 3 | import ( 4 | "fmt" 5 | "io" 6 | "strings" 7 | "testing" 8 | ) 9 | 10 | func TestBasic(t *testing.T) { 11 | type testCase struct { 12 | name string 13 | input string 14 | output string 15 | } 16 | cases := []testCase{ 17 | { 18 | name: "let-variable-shadow", 19 | input: `(do (defun f (a b) 20 | (let a 3 a)) (f 4 5))`, 21 | output: "3", 22 | }, 23 | 24 | { 25 | name: "let variable shadow", 26 | input: `(let Result 123 27 | (let Result 456 28 | (if (= Result 456) 29 | true 30 | Result)))`, 31 | output: "true", 32 | }, 33 | 34 | { 35 | name: "trap-let", 36 | input: "(trap-error (let X 666 42) (lambda E (cons --> (cons A ()))))", 37 | output: "42", 38 | }, 39 | 40 | { 41 | name: "curry-partial", 42 | input: `((lambda x (lambda y (lambda z (+ x z)))) 1 2 3)`, 43 | output: "4", 44 | }, 45 | 46 | { 47 | name: "curry", 48 | input: `(do (defun f (x y z) y) ((f 1 2) 3))`, 49 | output: "2", 50 | }, 51 | 52 | { 53 | name: "curry1", 54 | input: `(do (defun f (x) 55 | (do (defun ignore (z w) 56 | (lambda y 57 | z)) (ignore))) 58 | (((f 1) 2 3) 4))`, 59 | output: "2", 60 | }, 61 | 62 | { 63 | name: "fib10", 64 | input: `(do (defun fib (i) 65 | (if (= i 0) 66 | 1 67 | (if (= i 1) 68 | 1 69 | (+ (fib (- i 1)) (fib (- i 2)))))) 70 | (fib 10))`, 71 | output: "89", 72 | }, 73 | 74 | { 75 | name: "proper tail call", 76 | input: `(do (defun sum (r i) 77 | (if (= i 0) 78 | r 79 | (sum (+ r 1) (- i 1)))) 80 | (sum 0 5000000))`, 81 | output: "5000000", 82 | }, 83 | 84 | { 85 | name: "do in args", 86 | input: `(+ (do 1 (do 2 3)) 4)`, 87 | output: "7", 88 | }, 89 | 90 | // testCase{ 91 | // name: "partial primitive", 92 | // input: `(+ (+ (+ 1 2) 3) 4)`, 93 | // output: "10", 94 | // }, 95 | 96 | { 97 | name: "do in tail call", 98 | input: `(do (defun f (x y z) (do 1 (do 2 z))) (f 1 2 3))`, 99 | output: "3", 100 | }, 101 | 102 | { 103 | name: "basic func call", 104 | input: `(do (defun id (x) x) (id (do 1 (do 2 42))))`, 105 | output: "42", 106 | }, 107 | 108 | { 109 | name: "identify function", 110 | input: `(do (defun id (x) x) (id 42))`, 111 | output: "42", 112 | }, 113 | 114 | { 115 | name: "basic set", 116 | input: `(do (set x 42) (value x))`, 117 | output: "42", 118 | }, 119 | 120 | { 121 | name: "basic if", 122 | input: `(if true 1 2)`, 123 | output: "1", 124 | }, 125 | 126 | { 127 | name: "basic lambda", 128 | input: `((lambda x (lambda y (lambda z z))) 1 2 3)`, 129 | output: "3", 130 | }, 131 | 132 | { 133 | name: "basic do", 134 | input: `(do 1 2)`, 135 | output: "2", 136 | }, 137 | 138 | { 139 | name: "basic primitive", 140 | input: `(+ 3 7)`, 141 | output: "10", 142 | }, 143 | 144 | // testCase{ 145 | // name: "partial primitive1", 146 | // input: `((+ 1) 2)`, 147 | // output: "3", 148 | // }, 149 | 150 | // testCase{ 151 | // name: "partial primitive2", 152 | // input: `(((+) 1) 2)`, 153 | // output: "3", 154 | // }, 155 | } 156 | 157 | var ctx ControlFlow 158 | for _, c := range cases { 159 | t.Run(c.name, func(t *testing.T) { 160 | res := evalString(&ctx, c.input) 161 | if ObjString(res) != c.output { 162 | fmt.Println("input is:", c.input) 163 | fmt.Println("output is:", ObjString(res)) 164 | t.Fail() 165 | } 166 | if ctx.pos != 0 { 167 | fmt.Println("unexpected sp after evaluation:", ctx.pos) 168 | t.Fail() 169 | } 170 | if len(ctx.data) != 0 { 171 | fmt.Println("unexpected stack after evaluation:", len(ctx.data)) 172 | t.Fail() 173 | } 174 | }) 175 | } 176 | } 177 | 178 | // func TestYYY(t *testing.T) { 179 | // var ctx ControlFlow 180 | // evalString(&ctx, "(defun return (x) (lambda k (k x)))") 181 | // evalString(&ctx, "(defun add1 (n) (return (+ n 1)))") 182 | // res := evalString(&ctx, "(add1 4 (lambda x x))") 183 | // if res != MakeInteger(5) { 184 | // t.Fail() 185 | // } 186 | // } 187 | 188 | func evalString(ctx *ControlFlow, exp string) Obj { 189 | r := NewSexpReader(strings.NewReader(exp), true) 190 | sexp, err := r.Read() 191 | if err != nil && err != io.EOF { 192 | panic(err) 193 | } 194 | return Eval(ctx, sexp) 195 | } 196 | 197 | func TestTypeIsMacro(t *testing.T) { 198 | var ctx ControlFlow 199 | // type is implemented as a macro rather than a primitive. 200 | // This is because the second argument is not evaluated. 201 | // See also https://github.com/tiancaiamao/shen-go/pull/30 202 | // This shouldn't something like 203 | // "Panic: can't apply non function: undefined" 204 | res := evalString(&ctx, "(type (cons 1 ()) (undefined func))") 205 | if ObjString(res) != "(1)" { 206 | t.Fail() 207 | } 208 | } 209 | -------------------------------------------------------------------------------- /S39/Sources/writer.shen: -------------------------------------------------------------------------------- 1 | \\ Copyright (c) 2010-2019, Mark Tarver 2 | 3 | \\ All rights reserved. 4 | 5 | (package shen [] 6 | 7 | (define print 8 | X -> (let String (insert X "~S") 9 | Print (pr String (stoutput)) 10 | X)) 11 | 12 | (define pr 13 | String Stream -> (cases (value *hush*) String 14 | (char-stoutput? Stream) (write-string String Stream) 15 | true (write-chars String Stream (string->byte String 0) 1))) 16 | 17 | (define string->byte 18 | String N -> (trap-error (string->n (pos String N)) (/. E eos))) 19 | 20 | (define write-chars 21 | String Stream eos N -> String 22 | String Stream Byte N -> (write-chars String 23 | Stream 24 | (do (write-byte Byte Stream) (string->byte String N)) 25 | (+ N 1))) 26 | 27 | (define mkstr 28 | String Args -> (mkstr-l (proc-nl String) Args) where (string? String) 29 | String Args -> (mkstr-r [proc-nl String] Args)) 30 | 31 | (define mkstr-l 32 | String [] -> String 33 | String [Arg | Args] -> (mkstr-l (insert-l Arg String) Args) 34 | _ _ -> (simple-error "implementation error in shen.mkstr-l")) 35 | 36 | (define insert-l 37 | _ "" -> "" 38 | Arg (@s "~A" S) -> [app Arg S a] 39 | Arg (@s "~R" S) -> [app Arg S r] 40 | Arg (@s "~S" S) -> [app Arg S s] 41 | Arg (@s S Ss) -> (factor-cn [cn S (insert-l Arg Ss)]) 42 | Arg [cn S Ss] -> [cn S (insert-l Arg Ss)] 43 | Arg [app S Ss Mode] -> [app S (insert-l Arg Ss) Mode] 44 | _ _ -> (simple-error "implementation error in shen.insert-l")) 45 | 46 | (define factor-cn 47 | [cn S1 [cn S2 S3]] -> [cn (cn S1 S2) S3] where (and (string? S1) (string? S2)) 48 | Cn -> Cn) 49 | 50 | (define proc-nl 51 | "" -> "" 52 | (@s "~%" Ss) -> (cn (n->string 10) (proc-nl Ss)) 53 | (@s S Ss) -> (cn S (proc-nl Ss)) 54 | _ -> (simple-error "implementation error in shen.proc-nl")) 55 | 56 | (define mkstr-r 57 | String [] -> String 58 | String [Arg | Args] -> (mkstr-r [insert Arg String] Args) 59 | _ _ -> (simple-error "implementation error in shen.mkstr-r")) 60 | 61 | (define insert 62 | Arg String -> (insert-h Arg String "")) 63 | 64 | (define insert-h 65 | _ "" String -> String 66 | Arg (@s "~A" S) String -> (cn String (app Arg S a)) 67 | Arg (@s "~R" S) String -> (cn String (app Arg S r)) 68 | Arg (@s "~S" S) String -> (cn String (app Arg S s)) 69 | Arg (@s S Ss) String -> (insert-h Arg Ss (cn String S)) 70 | _ _ _ -> (simple-error "implementation error in shen.insert-h")) 71 | 72 | (define app 73 | Arg String Mode -> (cn (arg->str Arg Mode) String)) 74 | 75 | (define arg->str 76 | F _ -> "..." where (= F (fail)) 77 | L Mode -> (list->str L Mode) where (list? L) 78 | S Mode -> (str->str S Mode) where (string? S) 79 | V Mode -> (vector->str V Mode) where (absvector? V) 80 | At _ -> (atom->str At)) 81 | 82 | (define list->str 83 | L r -> (@s "(" (iter-list L r (maxseq)) ")") 84 | L Mode -> (@s "[" (iter-list L Mode (maxseq)) "]")) 85 | 86 | (define maxseq 87 | -> (value *maximum-print-sequence-size*)) 88 | 89 | (define iter-list 90 | [] _ _ -> "" 91 | _ _ 0 -> "... etc" 92 | [X] Mode _ -> (arg->str X Mode) 93 | [X | Y] Mode N -> (@s (arg->str X Mode) " " (iter-list Y Mode (- N 1))) 94 | X Mode N -> (@s "| " (arg->str X Mode))) 95 | 96 | (define str->str 97 | S a -> S 98 | S _ -> (@s (n->string 34) S (n->string 34))) 99 | 100 | (define vector->str 101 | V Mode -> (cases (print-vector? V) ((fn (<-address V 0)) V) 102 | (vector? V) (@s "<" (iter-vector V 1 Mode (maxseq)) ">") 103 | true (@s "<<" (iter-vector V 0 Mode (maxseq)) ">>"))) 104 | 105 | (define print-vector? 106 | P -> (let Zero (<-address P 0) 107 | (cases (= Zero tuple) true 108 | (= Zero pvar) true 109 | (not (number? Zero)) (fbound? Zero) 110 | true false))) 111 | 112 | (define fbound? 113 | F -> (not (= (arity F) -1))) 114 | 115 | (define tuple 116 | P -> (make-string "(@p ~S ~S)" (<-address P 1) (<-address P 2))) 117 | 118 | (define iter-vector 119 | _ _ _ 0 -> "... etc" 120 | V N Mode Max -> (let Item (trap-error (<-address V N) (/. E out-of-bounds)) 121 | Next (trap-error (<-address V (+ N 1)) (/. E out-of-bounds)) 122 | (cases (= Item out-of-bounds) "" 123 | (= Next out-of-bounds) (arg->str Item Mode) 124 | true (@s (arg->str Item Mode) 125 | " " 126 | (iter-vector V (+ N 1) Mode (- Max 1)))))) 127 | 128 | (define atom->str 129 | At -> (trap-error (str At) (/. E (funexstring)))) 130 | 131 | (define funexstring 132 | -> (@s "c#16;fune" (arg->str (gensym (intern "x")) a) "c#17;")) 133 | 134 | (define list? 135 | X -> (or (empty? X) (cons? X))) ) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Shen/Go, a Go port of the Shen language 2 | 3 | Shen is a portable functional programming language by [Mark Tarver](http://marktarver.com) that offers 4 | 5 | - pattern matching, 6 | - λ calculus consistency, 7 | - macros, 8 | - optional lazy evaluation, 9 | - static type checking, 10 | - an integrated fully functional Prolog, 11 | - and an inbuilt compiler-compiler. 12 | 13 | shen-go is a port of the Shen language that runs on top of Go implementations. 14 | 15 | ## Building 16 | 17 | Make sure you have [Go installed](https://golang.org/doc/install). 18 | 19 | ``` 20 | make shen 21 | ``` 22 | 23 | or for windows 24 | 25 | ``` 26 | make shen-exe 27 | ``` 28 | 29 | ## Running 30 | 31 | ``` 32 | ./shen 33 | ``` 34 | 35 | This binary has no dependency, you can move it to any where you want. 36 | 37 | ## Testing 38 | 39 | 1. Run unit test: 40 | 41 | ``` 42 | make test 43 | ``` 44 | 45 | 2. Test the `klambda` implementation: 46 | 47 | ``` 48 | make kl 49 | cd 'S39/Test Programs' 50 | kl 51 | (load-file "../../cmd/kl/runtests.kl") 52 | (load "runme.shen") 53 | ``` 54 | 55 | 3. Test the `shen` binary: 56 | 57 | 58 | ``` 59 | make shen 60 | cd 'S39/Test Programs' 61 | ../../shen 62 | (load "runme.shen") 63 | ``` 64 | 65 | ## How to bootstrap 66 | 67 | You can just do 68 | ``` 69 | cd compiled 70 | kl 71 | (load-file "script.kl") 72 | (load "compile-to-go.shen") 73 | (load "bctogo.shen") 74 | cd .. 75 | make shen 76 | ``` 77 | Explanation : 78 | 79 | `kl` implement a simple klambda interpreter in Go, which can be used to bootstrap `shen` 80 | 81 | ``` 82 | ;; mkdir -p compiled 83 | ;; cd compiled 84 | ;; kl 85 | (load-file "../S39/KLambda/toplevel.kl") 86 | (load-file "../S39/KLambda/core.kl") 87 | (load-file "../S39/KLambda/sys.kl") 88 | (load-file "../S39/KLambda/sequent.kl") 89 | (load-file "../S39/KLambda/yacc.kl") 90 | (load-file "../S39/KLambda/reader.kl") 91 | (load-file "../S39/KLambda/prolog.kl") 92 | (load-file "../S39/KLambda/track.kl") 93 | (load-file "../S39/KLambda/load.kl") 94 | (load-file "../S39/KLambda/writer.kl") 95 | (load-file "../S39/KLambda/macros.kl") 96 | (load-file "../S39/KLambda/declarations.kl") 97 | (load-file "../S39/KLambda/t-star.kl") 98 | (load-file "../S39/KLambda/types.kl") 99 | (shen.shen) 100 | ``` 101 | 102 | `shen` source files is generated from the `.kl` files. The full transformation path is Shen -> KL -> IR -> Go. 103 | 104 | The file `src/compiler.shen` is a transpiler from KL to an intermediate representation(IR), load it: 105 | 106 | ``` 107 | (load "../src/compiler.shen") 108 | ``` 109 | 110 | Compile the klambda to the intermediate representation: 111 | 112 | ``` 113 | (set *maximum-print-sequence-size* 100000) 114 | (compile-file "../S39/KLambda/sys.kl" "sys.tmp") 115 | (compile-file "../S39/KLambda/writer.kl" "writer.tmp") 116 | (compile-file "../S39/KLambda/core.kl" "core.tmp") 117 | (compile-file "../S39/KLambda/reader.kl" "reader.tmp") 118 | (compile-file "../S39/KLambda/declarations.kl" "declarations.tmp") 119 | (compile-file "../S39/KLambda/toplevel.kl" "toplevel.tmp") 120 | (compile-file "../S39/KLambda/macros.kl" "macros.tmp") 121 | (compile-file "../S39/KLambda/load.kl" "load.tmp") 122 | (compile-file "../S39/KLambda/prolog.kl" "prolog.tmp") 123 | (compile-file "../S39/KLambda/sequent.kl" "sequent.tmp") 124 | (compile-file "../S39/KLambda/track.kl" "track.tmp") 125 | (compile-file "../S39/KLambda/t-star.kl" "t-star.tmp") 126 | (compile-file "../S39/KLambda/yacc.kl" "yacc.tmp") 127 | (compile-file "../S39/KLambda/types.kl" "types.tmp") 128 | ``` 129 | 130 | And generate the Go files from the intermediate representation: 131 | 132 | ``` 133 | (put bc->go arity 5) 134 | (let Cg (make-code-generator) 135 | (do 136 | (bc->go Cg "SysMain" false "sys.tmp" "../cmd/shen/sys.go") 137 | (bc->go Cg "WriterMain" false "writer.tmp" "../cmd/shen/writer.go") 138 | (bc->go Cg "CoreMain" false "core.tmp" "../cmd/shen/core.go") 139 | (bc->go Cg "ReaderMain" false "reader.tmp" "../cmd/shen/reader.go") 140 | (bc->go Cg "DeclarationsMain" false "declarations.tmp" "../cmd/shen/declarations.go") 141 | (bc->go Cg "TopLevelMain" false "toplevel.tmp" "../cmd/shen/toplevel.go") 142 | (bc->go Cg "MacrosMain" false "macros.tmp" "../cmd/shen/macros.go") 143 | (bc->go Cg "LoadMain" false "load.tmp" "../cmd/shen/load.go") 144 | (bc->go Cg "PrologMain" false "prolog.tmp" "../cmd/shen/prolog.go") 145 | (bc->go Cg "SequentMain" false "sequent.tmp" "../cmd/shen/sequent.go") 146 | (bc->go Cg "TrackMain" false "track.tmp" "../cmd/shen/track.go") 147 | (bc->go Cg "TStarMain" false "t-star.tmp" "../cmd/shen/t-star.go") 148 | (bc->go Cg "YaccMain" false "yacc.tmp" "../cmd/shen/yacc.go") 149 | (bc->go Cg "TypesMain" true "types.tmp" "../cmd/shen/types.go"))) 150 | ``` 151 | 152 | Now the shen source files are available, built it: 153 | 154 | ``` 155 | make shen 156 | ``` 157 | 158 | 159 | ## Learn Shen 160 | * [Official website of Shen](http://shenlanguage.org/) 161 | * [Shen Community Wiki](https://github.com/Shen-Language/wiki/wiki) 162 | 163 | ## License 164 | 165 | - Shen, Copyright © 2010-2015 Mark Tarver - [License](http://www.shenlanguage.org/license.pdf). 166 | - shen-go, Copyright © 2017-2022 Arthur Mao under [BSD 3-Clause License](http://opensource.org/licenses/BSD-3-Clause). 167 | --------------------------------------------------------------------------------