├── .gitignore ├── shen.ms ├── shen-lib.ms ├── CHANGELOG.md ├── Makefile ├── declarations.ms ├── overwrites-internal.ms ├── kl ├── declarations.kl ├── extension-features.kl ├── dict.kl ├── load.kl ├── extension-programmable-pattern-matching.kl ├── extension-launcher.kl ├── track.kl ├── extension-expand-dynamic.kl ├── writer.kl ├── toplevel.kl ├── yacc.kl ├── extension-factorise-defun.kl └── macros.kl ├── compiled ├── extension-features.kl.ms ├── declarations.kl.ms ├── load.kl.ms ├── dict.kl.ms ├── extension-programmable-pattern-matching.kl.ms ├── extension-launcher.kl.ms ├── track.kl.ms ├── writer.kl.ms ├── toplevel.kl.ms └── yacc.kl.ms ├── primitives.ms ├── driver.ms ├── compiler.ms └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | shen 2 | *.mo 3 | -------------------------------------------------------------------------------- /shen.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | 4 | (import "shen-lib") 5 | 6 | (define (main . args) 7 | (kl:shen.initialise) 8 | (kl:shen.x.launcher.main (cons "shen" args))) 9 | -------------------------------------------------------------------------------- /shen-lib.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | (module "shen-lib") 4 | (import "driver") 5 | (import "compiled/toplevel.kl") 6 | (import "compiled/core.kl") 7 | (import "compiled/sys.kl") 8 | (import "compiled/dict.kl") 9 | (import "compiled/sequent.kl") 10 | (import "compiled/yacc.kl") 11 | (import "compiled/reader.kl") 12 | (import "compiled/prolog.kl") 13 | (import "compiled/track.kl") 14 | (import "compiled/load.kl") 15 | (import "compiled/writer.kl") 16 | (import "compiled/macros.kl") 17 | (import "compiled/declarations.kl") 18 | (import "overwrites-internal") 19 | (import "compiled/types.kl") 20 | (import "compiled/t-star.kl") 21 | (import "compiled/init.kl") 22 | (import "compiled/extension-features.kl") 23 | (import "compiled/extension-launcher.kl") 24 | (import "compiled/extension-factorise-defun.kl") 25 | (import "compiled/extension-programmable-pattern-matching.kl") 26 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | # Change Log 2 | 3 | ## 0.12 - 2022-04-29 4 | 5 | - Update to Shen OS Kernel 22.4 6 | 7 | ## 0.11 - 2019-09-28 8 | 9 | - Add module declarations to Wasp Lisp files and a `shen-libs.ms` that 10 | can be imported to load all the compiled Shen code from Lisp. 11 | - Update to Shen OS Kernel 22.0. 12 | - Requires a new version of Wasp Lisp, that can handle larger package sizes. 13 | Tested with commit 95cbb26 of the Wasp VM from https://github.com/doublec/shen-wasp/ 14 | in the `shen` branch. 15 | - Changes command line argument handling to the OS Kernel 22.0 launcher extension. 16 | 17 | ## 0.10 - 2018-10-07 18 | 19 | - Update to Shen OS Kernel 21.1. 20 | 21 | ## 0.9 - 2018-10-06 22 | 23 | - Add `shen-wasp.*argv*` variable to get list of command line arguments. 24 | - Fix 'cd' function so current directory changing works with 'load'. 25 | - Add command line arguments to load scripts, evaluate expressions and show usage. 26 | 27 | ## 0.8 - 2018-07-04 28 | 29 | - Update to Shen OS Kernel 21.0. 30 | 31 | ## 0.7 - 2017-05-23 32 | 33 | - update to Shen OS Kernel 20.1. 34 | - Improve startup time. 35 | 36 | ## 0.6 - 2017-05-02 37 | 38 | - Includes KLambda code generated from Shen source with commit `b6bb8333` included to fix `*sterror*` issue. 39 | - Includes KLambda code generated from shen source with commit `c5810337` included to fix `dict-fold` issue. 40 | - Added Change Log. 41 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: shen 2 | 3 | MO = \ 4 | compiled/core.kl.mo \ 5 | compiled/macros.kl.mo \ 6 | compiled/sequent.kl.mo \ 7 | compiled/track.kl.mo \ 8 | compiled/writer.kl.mo \ 9 | compiled/declarations.kl.mo \ 10 | compiled/prolog.kl.mo \ 11 | compiled/sys.kl.mo \ 12 | compiled/t-star.kl.mo \ 13 | compiled/yacc.kl.mo \ 14 | compiled/load.kl.mo \ 15 | compiled/reader.kl.mo \ 16 | compiled/toplevel.kl.mo \ 17 | compiled/types.kl.mo 18 | 19 | KL = \ 20 | kl/core.kl \ 21 | kl/macros.kl \ 22 | kl/sequent.kl \ 23 | kl/track.kl \ 24 | kl/writer.kl \ 25 | kl/declarations.kl \ 26 | kl/prolog.kl \ 27 | kl/sys.kl \ 28 | kl/t-star.kl \ 29 | kl/yacc.kl \ 30 | kl/load.kl \ 31 | kl/reader.kl \ 32 | kl/toplevel.kl \ 33 | kl/types.kl 34 | 35 | compiled/core.kl.mo: compiled/core.kl.ms 36 | waspc compiled/core.kl.ms 37 | 38 | compiled/macros.kl.mo: compiled/macros.kl.ms 39 | waspc compiled/macros.kl.ms 40 | 41 | compiled/sequent.kl.mo: compiled/sequent.kl.ms 42 | waspc compiled/sequent.kl.ms 43 | 44 | compiled/track.kl.mo: compiled/track.kl.ms 45 | waspc compiled/track.kl.ms 46 | 47 | compiled/writer.kl.mo: compiled/writer.kl.ms 48 | waspc compiled/writer.kl.ms 49 | 50 | compiled/declarations.kl.mo: compiled/declarations.kl.ms 51 | waspc compiled/declarations.kl.ms 52 | 53 | compiled/prolog.kl.mo: compiled/prolog.kl.ms 54 | waspc compiled/prolog.kl.ms 55 | 56 | compiled/sys.kl.mo: compiled/sys.kl.ms 57 | waspc compiled/sys.kl.ms 58 | 59 | compiled/t-star.kl.mo: compiled/t-star.kl.ms 60 | waspc compiled/t-star.kl.ms 61 | 62 | compiled/yacc.kl.mo: compiled/yacc.kl.ms 63 | waspc compiled/yacc.kl.ms 64 | 65 | compiled/load.kl.mo: compiled/load.kl.ms 66 | waspc compiled/load.kl.ms 67 | 68 | compiled/reader.kl.mo: compiled/reader.kl.ms 69 | waspc compiled/reader.kl.ms 70 | 71 | compiled/toplevel.kl.mo: compiled/toplevel.kl.ms 72 | waspc compiled/toplevel.kl.ms 73 | 74 | compiled/types.kl.mo: compiled/types.kl.ms 75 | waspc compiled/types.kl.ms 76 | 77 | compiler.mo: compiler.ms 78 | waspc declarations.ms 79 | 80 | driver.mo: driver.ms primitives.ms declarations.ms compiler.ms 81 | waspc driver.ms 82 | 83 | overwrites-internal.mo: overwrites-internal.ms 84 | waspc overwrites-internal.ms 85 | 86 | primitives.mo: primitives.ms 87 | waspc primitives.ms 88 | 89 | shen.mo: shen.ms $(MO) 90 | waspc shen.ms 91 | 92 | shen: compiler.mo driver.mo overwrites-internal.mo primitives.mo shen.mo $(MO) $(KL) 93 | waspc -exe shen shen.ms 94 | -------------------------------------------------------------------------------- /declarations.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | ; 4 | ; Shen Scheme derived soure code is: 5 | ; Copyright (c) 2012-2015 Bruno Deferrari. All rights reserved. 6 | 7 | (define *shen-function-arities* (make-dict)) 8 | 9 | (define (register-function-arity name arity) 10 | (dict-set! *shen-function-arities* name arity)) 11 | 12 | (define (function-arity name) 13 | (if (symbol? name) 14 | (dict-ref *shen-function-arities* name -1) 15 | -1)) 16 | 17 | (define (initialize-arity-table entries) 18 | (if (null? entries) 19 | 'done 20 | (let ((name (car entries)) 21 | (arity (cadr entries))) 22 | (register-function-arity name arity) 23 | (initialize-arity-table (cdr (cdr entries)))))) 24 | 25 | (initialize-arity-table 26 | '(abort 0 absvector? 1 absvector 1 adjoin 2 and 2 append 2 arity 1 assoc 2 boolean? 1 cd 1 compile 3 concat 2 cons 2 cons? 1 27 | cn 2 declare 2 destroy 1 difference 2 do 2 element? 2 empty? 1 enable-type-theory 1 interror 2 eval 1 28 | eval-kl 1 explode 1 external 1 fail-if 2 fail 0 fix 2 findall 5 freeze 1 fst 1 gensym 1 get 3 29 | get-time 1 address-> 3 <-address 2 <-vector 2 > 2 >= 2 = 2 hd 1 hdv 1 hdstr 1 head 1 if 3 integer? 1 30 | intern 1 identical 4 inferences 0 input 1 input+ 2 implementation 0 intersection 2 it 0 kill 0 language 0 31 | length 1 lineread 1 load 1 < 2 <= 2 vector 1 macroexpand 1 map 2 mapcan 2 maxinferences 1 not 1 nth 2 32 | n->string 1 number? 1 occurs-check 1 occurrences 2 occurs-check 1 optimise 1 or 2 os 0 package 3 package? 1 33 | port 0 porters 0 pos 2 print 1 profile 1 profile-results 1 pr 2 ps 1 preclude 1 preclude-all-but 1 protect 1 34 | address-> 3 put 4 reassemble 2 read-file-as-string 1 read-file 1 read 1 read-byte 1 read-from-string 1 35 | receive 1 release 0 remove 2 require 3 reverse 1 set 2 simple-error 1 snd 1 specialise 1 spy 1 step 1 stinput 0 stoutput 0 36 | string->n 1 string->symbol 1 string? 1 subst 3 sum 1 symbol? 1 tail 1 tl 1 tc 1 tc? 0 37 | thaw 1 tlstr 1 track 1 trap-error 2 tuple? 1 type 2 return 3 undefmacro 1 unput 3 unprofile 1 unify 4 unify! 4 38 | union 2 untrack 1 unspecialise 1 undefmacro 1 vector 1 vector-> 3 value 1 variable? 1 version 0 39 | write-byte 2 write-to-file 2 y-or-n? 1 + 2 * 2 / 2 - 2 == 2 1 @p 2 @v 2 @s 2 preclude 1 include 1 40 | preclude-all-but 1 include-all-but 1 where 2)) 41 | -------------------------------------------------------------------------------- /overwrites-internal.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | ; 4 | ; Shen Scheme derived soure code is: 5 | ; Copyright (c) 2012-2015 Bruno Deferrari. All rights reserved. 6 | 7 | (define kl:shen.old-sysfunc? kl:shen.sysfunc?) 8 | (define (kl:shen.sysfunc? x) (or (null? x) (kl:shen.old-sysfunc? x))) 9 | 10 | (define (kl:element? V2813 V2814) 11 | (and (member V2813 V2814) #t)) 12 | 13 | (define (kl:shen.alpha? V2704) 14 | (kl:element? V2704 '("A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M" "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z" "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m" "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z" "=" "*" "/" "+" "-" "_" "?" "$" "!" "@" "~" ">" "<" "&" "%" "{" "}" ":" ";" "`" "#" "." "'"))) 15 | 16 | (define (kl:shen.alphanums? V2706) 17 | (define buf (make-string 1 65)) 18 | (define len (string-length V2706)) 19 | 20 | (define i 0) 21 | (while (< i len) 22 | (string-set! buf 0 (string-ref V2706 i)) 23 | (if (not (kl:shen.alphanum? buf)) 24 | (return #f)) 25 | (set! i (+ 1 i))) 26 | #t) 27 | 28 | (define (kl:integer? x) 29 | (or (integer? x) (and (real? x) (= 0.0 (- (real->integer x) x))))) 30 | (define (kl:map V2961 V2962) (map V2961 V2962)) 31 | (define (kl:append V2735 V2736) (append V2735 V2736)) 32 | (define (kl:sum V2899) (apply + V2899)) 33 | (define (kl:reverse V2925) (reverse V2925)) 34 | 35 | (define (kl:shen.pvar? x) 36 | (and (vector? x) (eq? (vector-ref x 0) 'shen.pvar))) 37 | 38 | (define (kl:variable? V2712) 39 | (cond ((or (kl:boolean? V2712) (or (number? V2712) (string? V2712))) #f) 40 | (#t (kl:shen.analyse-variable? (kl:str V2712))))) 41 | 42 | (define (kl:symbol? V2700) 43 | (cond ((or (kl:boolean? V2700) (or (number? V2700) (string? V2700))) #f) 44 | (#t (kl:shen.analyse-symbol? (kl:str V2700))))) 45 | 46 | (define (kl:<-address/or V2855 V2856 V2857) 47 | (if (>= V2856 (vector-length V2855)) 48 | (kl:thaw V2857) 49 | (vector-ref V2855 V2856))) 50 | 51 | (define (kl:shen.compose V1709 V1710) 52 | (define r V1710) 53 | (define m V1709) 54 | (while (pair? m) 55 | (set! r ((car m) r)) 56 | (set! m (cdr m))) 57 | (if (null? m) 58 | r 59 | (kl:shen.f_error (quote shen.compose)))) 60 | 61 | (define (kl:shen.safe-multiply a b) 62 | (define m (* a b)) 63 | (if (and (not (= a 0)) (not (= (/ m a) b))) 64 | (error "Integer overflow in safe-*") 65 | m)) 66 | 67 | (define (kl:cd path) 68 | (if (string=? path "") 69 | (let ((path (kl:value (quote shen.*initial-home-directory*)))) 70 | (chdir path) 71 | (kl:set (quote *home-directory*) path)) 72 | (begin 73 | (chdir path) 74 | (kl:set (quote *home-directory*) path)))) 75 | 76 | -------------------------------------------------------------------------------- /kl/declarations.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun shen.initialise_arity_table (V393) (cond ((= () V393) ()) ((and (cons? V393) (cons? (tl V393))) (let DecArity (put (hd V393) arity (hd (tl V393)) (value *property-vector*)) (shen.initialise_arity_table (tl (tl V393))))) (true (shen.f_error shen.initialise_arity_table)))) 32 | 33 | (defun arity (V395) (trap-error (get V395 arity (value *property-vector*)) (lambda E -1))) 34 | 35 | (defun systemf (V397) (let Shen (intern "shen") (let External (get Shen shen.external-symbols (value *property-vector*)) (let Place (put Shen shen.external-symbols (adjoin V397 External) (value *property-vector*)) V397)))) 36 | 37 | (defun adjoin (V400 V401) (if (element? V400 V401) V401 (cons V400 V401))) 38 | 39 | (defun shen.lambda-form-entry (V403) (cond ((= package V403) ()) ((= receive V403) ()) (true (let ArityF (arity V403) (if (= ArityF -1) () (if (= ArityF 0) () (cons (cons V403 (eval-kl (shen.lambda-form V403 ArityF))) ()))))))) 40 | 41 | (defun shen.lambda-form (V406 V407) (cond ((= 0 V407) V406) (true (let X (gensym V) (cons lambda (cons X (cons (shen.lambda-form (shen.add-end V406 X) (- V407 1)) ()))))))) 42 | 43 | (defun shen.add-end (V410 V411) (cond ((cons? V410) (append V410 (cons V411 ()))) (true (cons V410 (cons V411 ()))))) 44 | 45 | (defun shen.set-lambda-form-entry (V413) (cond ((cons? V413) (put (hd V413) shen.lambda-form (tl V413) (value *property-vector*))) (true (shen.f_error shen.set-lambda-form-entry)))) 46 | 47 | (defun specialise (V415) (do (set shen.*special* (cons V415 (value shen.*special*))) V415)) 48 | 49 | (defun unspecialise (V417) (do (set shen.*special* (remove V417 (value shen.*special*))) V417)) 50 | 51 | 52 | 53 | -------------------------------------------------------------------------------- /kl/extension-features.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2019 Bruno Deferrari. 2 | BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | 4 | (defun shen.x.features.cond-expand-macro (V4827) (cond ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (= () (tl V4827)))) (simple-error "Unfulfilled shen.x.features.cond-expand clause.")) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (= true (hd (tl V4827))) (and (cons? (tl (tl V4827))) (= () (tl (tl (tl V4827))))))))) (hd (tl (tl V4827)))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (cons? (hd (tl V4827))) (and (= and (hd (hd (tl V4827)))) (and (= () (tl (hd (tl V4827)))) (cons? (tl (tl V4827))))))))) (hd (tl (tl V4827)))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (cons? (hd (tl V4827))) (and (= and (hd (hd (tl V4827)))) (and (cons? (tl (hd (tl V4827)))) (cons? (tl (tl V4827))))))))) (cons shen.x.features.cond-expand (cons (hd (tl (hd (tl V4827)))) (cons (cons shen.x.features.cond-expand (cons (cons and (tl (tl (hd (tl V4827))))) (tl (tl V4827)))) (tl (tl (tl V4827))))))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (cons? (hd (tl V4827))) (and (= or (hd (hd (tl V4827)))) (and (= () (tl (hd (tl V4827)))) (cons? (tl (tl V4827))))))))) (cons shen.x.features.cond-expand (tl (tl (tl V4827))))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (cons? (hd (tl V4827))) (and (= or (hd (hd (tl V4827)))) (and (cons? (tl (hd (tl V4827)))) (cons? (tl (tl V4827))))))))) (cons shen.x.features.cond-expand (cons (hd (tl (hd (tl V4827)))) (cons (hd (tl (tl V4827))) (cons true (cons (cons shen.x.features.cond-expand (cons (cons or (tl (tl (hd (tl V4827))))) (tl (tl V4827)))) ())))))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (cons? (hd (tl V4827))) (and (= not (hd (hd (tl V4827)))) (and (cons? (tl (hd (tl V4827)))) (and (= () (tl (tl (hd (tl V4827))))) (cons? (tl (tl V4827)))))))))) (cons shen.x.features.cond-expand (cons (hd (tl (hd (tl V4827)))) (cons (cons shen.x.features.cond-expand (tl (tl (tl V4827)))) (cons true (cons (hd (tl (tl V4827))) ())))))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (and (cons? (tl (tl V4827))) (element? (hd (tl V4827)) (value shen.x.features.*features*)))))) (hd (tl (tl V4827)))) ((and (cons? V4827) (and (= shen.x.features.cond-expand (hd V4827)) (and (cons? (tl V4827)) (cons? (tl (tl V4827)))))) (cons shen.x.features.cond-expand (tl (tl (tl V4827))))) (true V4827))) 5 | 6 | (defun shen.x.features.current () (value shen.x.features.*features*)) 7 | 8 | (defun shen.x.features.initialise (V4829) (let _ (trap-error (value shen.x.features.*features*) (lambda E (do (set shen.x.features.*features* ()) (do (shen.set-lambda-form-entry (cons shen.x.features.cond-expand-macro (lambda X (shen.x.features.cond-expand-macro X)))) (shen.add-macro shen.x.features.cond-expand-macro))))) (let Old (shen.x.features.current) (let _ (set shen.x.features.*features* V4829) Old)))) 9 | 10 | (defun shen.x.features.add (V4831) (let Old (shen.x.features.current) (let _ (set shen.x.features.*features* (adjoin V4831 Old)) Old))) 11 | 12 | 13 | 14 | -------------------------------------------------------------------------------- /kl/dict.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun shen.dict (V2284) (cond ((< V2284 1) (simple-error (cn "invalid initial dict size: " (shen.app V2284 "" shen.s)))) (true (let D (absvector (+ 3 V2284)) (let Tag (address-> D 0 shen.dictionary) (let Capacity (address-> D 1 V2284) (let Count (address-> D 2 0) (let Fill (shen.fillvector D 3 (+ 2 V2284) ()) D)))))))) 32 | 33 | (defun shen.dict? (V2286) (and (absvector? V2286) (= (trap-error (<-address V2286 0) (lambda E shen.not-dictionary)) shen.dictionary))) 34 | 35 | (defun shen.dict-capacity (V2288) (<-address V2288 1)) 36 | 37 | (defun shen.dict-count (V2290) (<-address V2290 2)) 38 | 39 | (defun shen.dict-count-> (V2293 V2294) (address-> V2293 2 V2294)) 40 | 41 | (defun shen.<-dict-bucket (V2297 V2298) (<-address V2297 (+ 3 V2298))) 42 | 43 | (defun shen.dict-bucket-> (V2302 V2303 V2304) (address-> V2302 (+ 3 V2303) V2304)) 44 | 45 | (defun shen.dict-update-count (V2308 V2309 V2310) (let Diff (- (length V2310) (length V2309)) (shen.dict-count-> V2308 (+ Diff (shen.dict-count V2308))))) 46 | 47 | (defun shen.dict-> (V2314 V2315 V2316) (let N (hash V2315 (shen.dict-capacity V2314)) (let Bucket (shen.<-dict-bucket V2314 N) (let NewBucket (shen.assoc-set V2315 V2316 Bucket) (let Change (shen.dict-bucket-> V2314 N NewBucket) (let Count (shen.dict-update-count V2314 Bucket NewBucket) V2316)))))) 48 | 49 | (defun shen.<-dict (V2319 V2320) (let N (hash V2320 (shen.dict-capacity V2319)) (let Bucket (shen.<-dict-bucket V2319 N) (let Result (assoc V2320 Bucket) (if (empty? Result) (simple-error (cn "value " (shen.app V2320 " not found in dict 50 | " shen.a))) (tl Result)))))) 51 | 52 | (defun shen.dict-rm (V2323 V2324) (let N (hash V2324 (shen.dict-capacity V2323)) (let Bucket (shen.<-dict-bucket V2323 N) (let NewBucket (shen.assoc-rm V2324 Bucket) (let Change (shen.dict-bucket-> V2323 N NewBucket) (let Count (shen.dict-update-count V2323 Bucket NewBucket) V2324)))))) 53 | 54 | (defun shen.dict-fold (V2328 V2329 V2330) (let Limit (shen.dict-capacity V2329) (shen.dict-fold-h V2328 V2329 V2330 0 Limit))) 55 | 56 | (defun shen.dict-fold-h (V2337 V2338 V2339 V2340 V2341) (cond ((= V2341 V2340) V2339) (true (let B (shen.<-dict-bucket V2338 V2340) (let Acc (shen.bucket-fold V2337 B V2339) (shen.dict-fold-h V2337 V2338 Acc (+ 1 V2340) V2341)))))) 57 | 58 | (defun shen.bucket-fold (V2345 V2346 V2347) (cond ((= () V2346) V2347) ((and (cons? V2346) (cons? (hd V2346))) (V2345 (hd (hd V2346)) (tl (hd V2346)) (shen.bucket-fold V2345 (tl V2346) V2347))) (true (shen.f_error shen.bucket-fold)))) 59 | 60 | (defun shen.dict-keys (V2349) (shen.dict-fold (lambda K (lambda _ (lambda Acc (cons K Acc)))) V2349 ())) 61 | 62 | (defun shen.dict-values (V2351) (shen.dict-fold (lambda _ (lambda V (lambda Acc (cons V Acc)))) V2351 ())) 63 | 64 | 65 | 66 | -------------------------------------------------------------------------------- /compiled/extension-features.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/extension-features.kl") 2 | "Copyright (c) 2019 Bruno Deferrari.\nBSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | (begin (register-function-arity (quote shen.x.features.cond-expand-macro) 1) (define (kl:shen.x.features.cond-expand-macro V4827) (cond ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (null? (cdr V4827)))) (simple-error "Unfulfilled shen.x.features.cond-expand clause.")) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (kl:= #t (car (cdr V4827))) (and (pair? (cdr (cdr V4827))) (null? (cdr (cdr (cdr V4827))))))))) (car (cdr (cdr V4827)))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (pair? (car (cdr V4827))) (and (eq? (quote and) (car (car (cdr V4827)))) (and (null? (cdr (car (cdr V4827)))) (pair? (cdr (cdr V4827))))))))) (car (cdr (cdr V4827)))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (pair? (car (cdr V4827))) (and (eq? (quote and) (car (car (cdr V4827)))) (and (pair? (cdr (car (cdr V4827)))) (pair? (cdr (cdr V4827))))))))) (cons (quote shen.x.features.cond-expand) (cons (car (cdr (car (cdr V4827)))) (cons (cons (quote shen.x.features.cond-expand) (cons (cons (quote and) (cdr (cdr (car (cdr V4827))))) (cdr (cdr V4827)))) (cdr (cdr (cdr V4827))))))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (pair? (car (cdr V4827))) (and (eq? (quote or) (car (car (cdr V4827)))) (and (null? (cdr (car (cdr V4827)))) (pair? (cdr (cdr V4827))))))))) (cons (quote shen.x.features.cond-expand) (cdr (cdr (cdr V4827))))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (pair? (car (cdr V4827))) (and (eq? (quote or) (car (car (cdr V4827)))) (and (pair? (cdr (car (cdr V4827)))) (pair? (cdr (cdr V4827))))))))) (cons (quote shen.x.features.cond-expand) (cons (car (cdr (car (cdr V4827)))) (cons (car (cdr (cdr V4827))) (cons #t (cons (cons (quote shen.x.features.cond-expand) (cons (cons (quote or) (cdr (cdr (car (cdr V4827))))) (cdr (cdr V4827)))) (quote ()))))))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (pair? (car (cdr V4827))) (and (eq? (quote not) (car (car (cdr V4827)))) (and (pair? (cdr (car (cdr V4827)))) (and (null? (cdr (cdr (car (cdr V4827))))) (pair? (cdr (cdr V4827)))))))))) (cons (quote shen.x.features.cond-expand) (cons (car (cdr (car (cdr V4827)))) (cons (cons (quote shen.x.features.cond-expand) (cdr (cdr (cdr V4827)))) (cons #t (cons (car (cdr (cdr V4827))) (quote ()))))))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (and (pair? (cdr (cdr V4827))) (kl:element? (car (cdr V4827)) (kl:value (quote shen.x.features.*features*))))))) (car (cdr (cdr V4827)))) ((and (pair? V4827) (and (eq? (quote shen.x.features.cond-expand) (car V4827)) (and (pair? (cdr V4827)) (pair? (cdr (cdr V4827)))))) (cons (quote shen.x.features.cond-expand) (cdr (cdr (cdr V4827))))) (#t V4827))) (export shen.x.features.cond-expand-macro) (quote shen.x.features.cond-expand-macro)) 4 | (begin (register-function-arity (quote shen.x.features.current) 0) (define (kl:shen.x.features.current) (kl:value (quote shen.x.features.*features*))) (export shen.x.features.current) (quote shen.x.features.current)) 5 | (begin (register-function-arity (quote shen.x.features.initialise) 1) (define (kl:shen.x.features.initialise V4829) (let ((_ (guard (lambda (E) (begin (kl:set (quote shen.x.features.*features*) (quote ())) (begin (kl:shen.set-lambda-form-entry (cons (quote shen.x.features.cond-expand-macro) (lambda (X) (kl:shen.x.features.cond-expand-macro X)))) (kl:shen.add-macro (quote shen.x.features.cond-expand-macro))))) (kl:value (quote shen.x.features.*features*))))) (let ((Old (kl:shen.x.features.current))) (let ((_ (kl:set (quote shen.x.features.*features*) V4829))) Old)))) (export shen.x.features.initialise) (quote shen.x.features.initialise)) 6 | (begin (register-function-arity (quote shen.x.features.add) 1) (define (kl:shen.x.features.add V4831) (let ((Old (kl:shen.x.features.current))) (let ((_ (kl:set (quote shen.x.features.*features*) (kl:adjoin V4831 Old)))) Old))) (export shen.x.features.add) (quote shen.x.features.add)) 7 | -------------------------------------------------------------------------------- /kl/load.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun load (V643) (let Load (let Start (get-time run) (let Result (shen.load-help (value shen.*tc*) (read-file V643)) (let Finish (get-time run) (let Time (- Finish Start) (let Message (shen.prhush (cn " 32 | run time: " (cn (str Time) " secs 33 | ")) (stoutput)) Result))))) (let Infs (if (value shen.*tc*) (shen.prhush (cn " 34 | typechecked in " (shen.app (inferences) " inferences 35 | " shen.a)) (stoutput)) shen.skip) loaded))) 36 | 37 | (defun shen.load-help (V650 V651) (cond ((= false V650) (shen.for-each (lambda X (shen.prhush (shen.app (shen.eval-without-macros X) " 38 | " shen.s) (stoutput))) V651)) (true (let RemoveSynonyms (mapcan (lambda X (shen.remove-synonyms X)) V651) (let Table (mapcan (lambda X (shen.typetable X)) RemoveSynonyms) (let Assume (shen.for-each (lambda X (shen.assumetype X)) Table) (trap-error (shen.for-each (lambda X (shen.typecheck-and-load X)) RemoveSynonyms) (lambda E (shen.unwind-types E Table))))))))) 39 | 40 | (defun shen.remove-synonyms (V653) (cond ((and (cons? V653) (= shen.synonyms-help (hd V653))) (do (eval V653) ())) (true (cons V653 ())))) 41 | 42 | (defun shen.typecheck-and-load (V655) (do (nl 1) (shen.typecheck-and-evaluate V655 (gensym A)))) 43 | 44 | (defun shen.typetable (V661) (cond ((and (cons? V661) (and (= define (hd V661)) (cons? (tl V661)))) (let Sig (compile (lambda Y (shen. Y)) (tl (tl V661)) (lambda E (simple-error (shen.app (hd (tl V661)) " lacks a proper signature. 45 | " shen.a)))) (cons (cons (hd (tl V661)) Sig) ()))) (true ()))) 46 | 47 | (defun shen.assumetype (V663) (cond ((cons? V663) (declare (hd V663) (tl V663))) (true (shen.f_error shen.assumetype)))) 48 | 49 | (defun shen.unwind-types (V670 V671) (cond ((= () V671) (simple-error (error-to-string V670))) ((and (cons? V671) (cons? (hd V671))) (do (shen.remtype (hd (hd V671))) (shen.unwind-types V670 (tl V671)))) (true (shen.f_error shen.unwind-types)))) 50 | 51 | (defun shen.remtype (V673) (set shen.*signedfuncs* (shen.removetype V673 (value shen.*signedfuncs*)))) 52 | 53 | (defun shen.removetype (V681 V682) (cond ((= () V682) ()) ((and (cons? V682) (and (cons? (hd V682)) (= (hd (hd V682)) V681))) (shen.removetype (hd (hd V682)) (tl V682))) ((cons? V682) (cons (hd V682) (shen.removetype V681 (tl V682)))) (true (shen.f_error shen.removetype)))) 54 | 55 | (defun shen. (V684) (let Parse_shen. (shen. V684) (if (not (= (fail) Parse_shen.)) (let Parse_ ( Parse_shen.) (if (not (= (fail) Parse_)) (shen.pair (hd Parse_) (shen.hdtl Parse_shen.)) (fail))) (fail)))) 56 | 57 | (defun write-to-file (V687 V688) (let Stream (open V687 out) (let String (if (string? V688) (shen.app V688 " 58 | 59 | " shen.a) (shen.app V688 " 60 | 61 | " shen.s)) (let Write (pr String Stream) (let Close (close Stream) V688))))) 62 | 63 | 64 | 65 | -------------------------------------------------------------------------------- /compiled/declarations.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/declarations.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote shen.initialise_arity_table) 1) (define (kl:shen.initialise_arity_table V393) (cond ((null? V393) (quote ())) ((and (pair? V393) (pair? (cdr V393))) (let ((DecArity (kl:put (car V393) (quote arity) (car (cdr V393)) (kl:value (quote *property-vector*))))) (kl:shen.initialise_arity_table (cdr (cdr V393))))) (#t (kl:shen.f_error (quote shen.initialise_arity_table))))) (export shen.initialise_arity_table) (quote shen.initialise_arity_table)) 4 | (begin (register-function-arity (quote arity) 1) (define (kl:arity V395) (guard (lambda (E) -1) (kl:get V395 (quote arity) (kl:value (quote *property-vector*))))) (export arity) (quote arity)) 5 | (begin (register-function-arity (quote systemf) 1) (define (kl:systemf V397) (let ((Shen (kl:intern "shen"))) (let ((External (kl:get Shen (quote shen.external-symbols) (kl:value (quote *property-vector*))))) (let ((Place (kl:put Shen (quote shen.external-symbols) (kl:adjoin V397 External) (kl:value (quote *property-vector*))))) V397)))) (export systemf) (quote systemf)) 6 | (begin (register-function-arity (quote adjoin) 2) (define (kl:adjoin V400 V401) (if (kl:element? V400 V401) V401 (cons V400 V401))) (export adjoin) (quote adjoin)) 7 | (begin (register-function-arity (quote shen.lambda-form-entry) 1) (define (kl:shen.lambda-form-entry V403) (cond ((eq? (quote package) V403) (quote ())) ((eq? (quote receive) V403) (quote ())) (#t (let ((ArityF (kl:arity V403))) (if (kl:= ArityF -1) (quote ()) (if (kl:= ArityF 0) (quote ()) (cons (cons V403 (kl:eval-kl (kl:shen.lambda-form V403 ArityF))) (quote ())))))))) (export shen.lambda-form-entry) (quote shen.lambda-form-entry)) 8 | (begin (register-function-arity (quote shen.lambda-form) 2) (define (kl:shen.lambda-form V406 V407) (cond ((kl:= 0 V407) V406) (#t (let ((X (kl:gensym (quote V)))) (cons (quote lambda) (cons X (cons (kl:shen.lambda-form (kl:shen.add-end V406 X) (- V407 1)) (quote ())))))))) (export shen.lambda-form) (quote shen.lambda-form)) 9 | (begin (register-function-arity (quote shen.add-end) 2) (define (kl:shen.add-end V410 V411) (cond ((pair? V410) (kl:append V410 (cons V411 (quote ())))) (#t (cons V410 (cons V411 (quote ())))))) (export shen.add-end) (quote shen.add-end)) 10 | (begin (register-function-arity (quote shen.set-lambda-form-entry) 1) (define (kl:shen.set-lambda-form-entry V413) (cond ((pair? V413) (kl:put (car V413) (quote shen.lambda-form) (cdr V413) (kl:value (quote *property-vector*)))) (#t (kl:shen.f_error (quote shen.set-lambda-form-entry))))) (export shen.set-lambda-form-entry) (quote shen.set-lambda-form-entry)) 11 | (begin (register-function-arity (quote specialise) 1) (define (kl:specialise V415) (begin (kl:set (quote shen.*special*) (cons V415 (kl:value (quote shen.*special*)))) V415)) (export specialise) (quote specialise)) 12 | (begin (register-function-arity (quote unspecialise) 1) (define (kl:unspecialise V417) (begin (kl:set (quote shen.*special*) (kl:remove V417 (kl:value (quote shen.*special*)))) V417)) (export unspecialise) (quote unspecialise)) 13 | -------------------------------------------------------------------------------- /kl/extension-programmable-pattern-matching.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2019 Bruno Deferrari. All rights reserved. 2 | BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | 4 | (defun shen.x.programmable-pattern-matching.apply-pattern-handlers (V5042 V5043 V5044 V5045 V5046) (cond ((= () V5042) (fail)) (true (let Freeze (freeze (cond ((cons? V5042) (shen.x.programmable-pattern-matching.apply-pattern-handlers (tl V5042) V5043 V5044 V5045 V5046)) (true (shen.f_error shen.x.programmable-pattern-matching.apply-pattern-handlers)))) (if (cons? V5042) (let Result ((hd V5042) V5043 V5044 V5045 V5046) (if (= Result (fail)) (thaw Freeze) Result)) (thaw Freeze)))))) 5 | 6 | (defun shen.x.programmable-pattern-matching.make-stack () (address-> (absvector 1) 0 ())) 7 | 8 | (defun shen.x.programmable-pattern-matching.push (V5049 V5050) (address-> V5049 0 (cons V5050 (<-address V5049 0)))) 9 | 10 | (defun shen.x.programmable-pattern-matching.pop-all (V5052) (let Res (<-address V5052 0) (let _ (address-> V5052 0 ()) Res))) 11 | 12 | (defun shen.x.programmable-pattern-matching.compile-pattern (V5056 V5057 V5058) (let VarsStack (shen.x.programmable-pattern-matching.make-stack) (let Self Self$$7907$$ (let AddTest (lambda _ shen.x.programmable-pattern-matching.ignored) (let Bind (lambda Var (lambda _ (shen.x.programmable-pattern-matching.push VarsStack Var))) (let Result (shen.x.programmable-pattern-matching.apply-pattern-handlers V5057 Self AddTest Bind V5056) (if (= Result (fail)) (thaw V5058) (shen.x.programmable-pattern-matching.compile-pattern-h V5056 (reverse (shen.x.programmable-pattern-matching.pop-all VarsStack)))))))))) 13 | 14 | (defun shen.x.programmable-pattern-matching.compile-pattern-h (V5061 V5062) (cond ((cons? V5061) (let Compile (lambda X (shen. X)) (let Handler (lambda E (simple-error (cn "failed to compile " (shen.app E "" shen.a)))) (let NewArgs (map (lambda Arg (if (element? Arg V5062) (compile Compile (cons Arg ()) Handler) Arg)) (tl V5061)) (cons (hd V5061) NewArgs))))) (true (shen.f_error shen.x.programmable-pattern-matching.compile-pattern-h)))) 15 | 16 | (defun shen.x.programmable-pattern-matching.reduce (V5065 V5066) (cond ((and (cons? V5065) (and (cons? (hd V5065)) (and (= /. (hd (hd V5065))) (and (cons? (tl (hd V5065))) (and (cons? (hd (tl (hd V5065)))) (and (cons? (tl (tl (hd V5065)))) (and (= () (tl (tl (tl (hd V5065))))) (and (cons? (tl V5065)) (= () (tl (tl V5065))))))))))) (let SelectorStack (shen.x.programmable-pattern-matching.make-stack) (let AddTest (lambda Expr (shen.add_test Expr)) (let Bind (lambda Var (lambda Expr (shen.x.programmable-pattern-matching.push SelectorStack (@p Var Expr)))) (let Result (shen.x.programmable-pattern-matching.apply-pattern-handlers V5066 (hd (tl V5065)) AddTest Bind (hd (tl (hd V5065)))) (let Vars+Sels (reverse (shen.x.programmable-pattern-matching.pop-all SelectorStack)) (let Vars (map (lambda V5019 (fst V5019)) Vars+Sels) (let Selectors (map (lambda V5020 (snd V5020)) Vars+Sels) (let Abstraction (shen.abstraction_build Vars (shen.ebr (hd (tl V5065)) (hd (tl (hd V5065))) (hd (tl (tl (hd V5065)))))) (let Application (shen.application_build Selectors Abstraction) (shen.reduce_help Application))))))))))) (true (shen.f_error shen.x.programmable-pattern-matching.reduce)))) 17 | 18 | (defun shen.x.programmable-pattern-matching.initialise () (do (set shen.*custom-pattern-compiler* (lambda Arg (lambda OnFail (shen.x.programmable-pattern-matching.compile-pattern Arg (value shen.x.programmable-pattern-matching.*pattern-handlers*) OnFail)))) (do (set shen.*custom-pattern-reducer* (lambda Arg (shen.x.programmable-pattern-matching.reduce Arg (value shen.x.programmable-pattern-matching.*pattern-handlers*)))) (do (set shen.x.programmable-pattern-matching.*pattern-handlers* ()) (do (set shen.x.programmable-pattern-matching.*pattern-handlers-reg* ()) shen.x.programmable-pattern-matching.done))))) 19 | 20 | (defun shen.x.programmable-pattern-matching.register-handler (V5068) (cond ((element? V5068 (value shen.x.programmable-pattern-matching.*pattern-handlers-reg*)) V5068) (true (do (set shen.x.programmable-pattern-matching.*pattern-handlers-reg* (cons V5068 (value shen.x.programmable-pattern-matching.*pattern-handlers-reg*))) (do (set shen.x.programmable-pattern-matching.*pattern-handlers* (cons (function V5068) (value shen.x.programmable-pattern-matching.*pattern-handlers*))) V5068))))) 21 | 22 | (defun shen.x.programmable-pattern-matching.findpos (V5071 V5072) (trap-error (shen.findpos V5071 V5072) (lambda _ (simple-error (shen.app V5071 " is not a pattern handler 23 | " shen.a))))) 24 | 25 | (defun shen.x.programmable-pattern-matching.unregister-handler (V5074) (let Reg (value shen.x.programmable-pattern-matching.*pattern-handlers-reg*) (let Pos (shen.x.programmable-pattern-matching.findpos V5074 Reg) (let RemoveReg (set shen.x.programmable-pattern-matching.*pattern-handlers-reg* (remove V5074 Reg)) (let RemoveFun (set shen.x.programmable-pattern-matching.*pattern-handlers* (shen.remove-nth Pos (value shen.x.programmable-pattern-matching.*pattern-handlers*))) V5074))))) 26 | 27 | 28 | 29 | -------------------------------------------------------------------------------- /kl/extension-launcher.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2019 Bruno Deferrari. 2 | BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | 4 | (defun shen.x.launcher.quiet-load (V4833) (let Contents (read-file V4833) (map (lambda X (shen.eval-without-macros X)) Contents))) 5 | 6 | (defun shen.x.launcher.version-string () (shen.app (version) (cn " " (shen.app (cons port (cons (cons (language) (cons (port) ())) (cons implementation (cons (cons (implementation) (cons (release) ())) ())))) " 7 | " shen.r)) shen.a)) 8 | 9 | (defun shen.x.launcher.help-text (V4835) (cn "Usage: " (shen.app V4835 " [--version] [--help] [] 10 | 11 | commands: 12 | repl 13 | Launches the interactive REPL. 14 | Default action if no command is supplied. 15 | 16 | script [] 17 | Runs the script in FILE. *argv* is set to [FILE | ARGS]. 18 | 19 | eval 20 | Evaluates expressions and files. ARGS are evaluated from 21 | left to right and can be a combination of: 22 | -e, --eval 23 | Evaluates EXPR and prints result. 24 | -l, --load 25 | Reads and evaluates FILE. 26 | -q, --quiet 27 | Silences interactive output. 28 | -s, --set 29 | Evaluates KEY, VALUE and sets as global. 30 | -r, --repl 31 | Launches the interactive REPL after evaluating 32 | all the previous expresions." shen.a))) 33 | 34 | (defun shen.x.launcher.execute-all (V4837) (cond ((= () V4837) (cons success ())) ((cons? V4837) (do (thaw (hd V4837)) (shen.x.launcher.execute-all (tl V4837)))) (true (shen.f_error shen.x.launcher.execute-all)))) 35 | 36 | (defun shen.x.launcher.eval-string (V4839) (eval (head (read-from-string V4839)))) 37 | 38 | (defun shen.x.launcher.eval-flag-map (V4845) (cond ((= "-e" V4845) "--eval") ((= "-l" V4845) "--load") ((= "-q" V4845) "--quiet") ((= "-s" V4845) "--set") ((= "-r" V4845) "--repl") (true false))) 39 | 40 | (defun shen.x.launcher.eval-command-h (V4856 V4857) (cond ((= () V4856) (shen.x.launcher.execute-all (reverse V4857))) ((and (cons? V4856) (and (= "--eval" (hd V4856)) (cons? (tl V4856)))) (shen.x.launcher.eval-command-h (tl (tl V4856)) (cons (freeze (shen.prhush (shen.app (shen.x.launcher.eval-string (hd (tl V4856))) " 41 | " shen.a) (stoutput))) V4857))) ((and (cons? V4856) (and (= "--load" (hd V4856)) (cons? (tl V4856)))) (shen.x.launcher.eval-command-h (tl (tl V4856)) (cons (freeze (load (hd (tl V4856)))) V4857))) ((and (cons? V4856) (= "--quiet" (hd V4856))) (shen.x.launcher.eval-command-h (tl V4856) (cons (freeze (set *hush* true)) V4857))) ((and (cons? V4856) (and (= "--set" (hd V4856)) (and (cons? (tl V4856)) (cons? (tl (tl V4856)))))) (shen.x.launcher.eval-command-h (tl (tl (tl V4856))) (cons (freeze (set (shen.x.launcher.eval-string (hd (tl V4856))) (shen.x.launcher.eval-string (hd (tl (tl V4856)))))) V4857))) ((and (cons? V4856) (= "--repl" (hd V4856))) (do (shen.x.launcher.eval-command-h () V4857) (cons launch-repl (tl V4856)))) (true (let Freeze (freeze (cond ((cons? V4856) (cons error (cons (cn "Invalid eval argument: " (shen.app (hd V4856) "" shen.a)) ()))) (true (shen.f_error shen.x.launcher.eval-command-h)))) (if (cons? V4856) (let Result (let Long (shen.x.launcher.eval-flag-map (hd V4856)) (if (= false Long) (fail) (shen.x.launcher.eval-command-h (cons Long (tl V4856)) V4857))) (if (= Result (fail)) (thaw Freeze) Result)) (thaw Freeze)))))) 42 | 43 | (defun shen.x.launcher.eval-command (V4859) (shen.x.launcher.eval-command-h V4859 ())) 44 | 45 | (defun shen.x.launcher.script-command (V4862 V4863) (do (set *argv* (cons V4862 V4863)) (do (shen.x.launcher.quiet-load V4862) (cons success ())))) 46 | 47 | (defun shen.x.launcher.launch-shen (V4865) (cond ((and (cons? V4865) (= () (tl V4865))) (cons launch-repl ())) ((and (cons? V4865) (and (cons? (tl V4865)) (= "--help" (hd (tl V4865))))) (cons show-help (cons (shen.x.launcher.help-text (hd V4865)) ()))) ((and (cons? V4865) (and (cons? (tl V4865)) (= "--version" (hd (tl V4865))))) (cons success (cons (shen.x.launcher.version-string) ()))) ((and (cons? V4865) (and (cons? (tl V4865)) (= "repl" (hd (tl V4865))))) (cons launch-repl (tl (tl V4865)))) ((and (cons? V4865) (and (cons? (tl V4865)) (and (= "script" (hd (tl V4865))) (cons? (tl (tl V4865)))))) (shen.x.launcher.script-command (hd (tl (tl V4865))) (tl (tl (tl V4865))))) ((and (cons? V4865) (and (cons? (tl V4865)) (= "eval" (hd (tl V4865))))) (shen.x.launcher.eval-command (tl (tl V4865)))) ((and (cons? V4865) (cons? (tl V4865))) (cons unknown-arguments V4865)) (true (shen.f_error shen.x.launcher.launch-shen)))) 48 | 49 | (defun shen.x.launcher.default-handle-result (V4869) (cond ((and (cons? V4869) (and (= success (hd V4869)) (= () (tl V4869)))) shen.x.launcher.done) ((and (cons? V4869) (and (= success (hd V4869)) (and (cons? (tl V4869)) (= () (tl (tl V4869)))))) (shen.prhush (shen.app (hd (tl V4869)) " 50 | " shen.a) (stoutput))) ((and (cons? V4869) (and (= error (hd V4869)) (and (cons? (tl V4869)) (= () (tl (tl V4869)))))) (shen.prhush (cn "ERROR: " (shen.app (hd (tl V4869)) " 51 | " shen.a)) (stoutput))) ((and (cons? V4869) (= launch-repl (hd V4869))) (shen.repl)) ((and (cons? V4869) (and (= show-help (hd V4869)) (and (cons? (tl V4869)) (= () (tl (tl V4869)))))) (shen.prhush (shen.app (hd (tl V4869)) " 52 | " shen.a) (stoutput))) ((and (cons? V4869) (and (= unknown-arguments (hd V4869)) (and (cons? (tl V4869)) (cons? (tl (tl V4869)))))) (shen.prhush (cn "ERROR: Invalid argument: " (shen.app (hd (tl (tl V4869))) (cn " 53 | Try `" (shen.app (hd (tl V4869)) " --help' for more information. 54 | " shen.a)) shen.a)) (stoutput))) (true (shen.f_error shen.x.launcher.default-handle-result)))) 55 | 56 | (defun shen.x.launcher.main (V4871) (shen.x.launcher.default-handle-result (shen.x.launcher.launch-shen V4871))) 57 | 58 | 59 | 60 | -------------------------------------------------------------------------------- /primitives.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | ; 4 | ; Shen Scheme derived soure code is: 5 | ; Copyright (c) 2012-2015 Bruno Deferrari. All rights reserved. 6 | 7 | (module "primitives") 8 | (import "lib/with-io") 9 | (import "lib/eval") 10 | 11 | (define (call-with-output-string proc) 12 | (define q (make-queue)) 13 | (proc q) 14 | (send 'quit q) 15 | (define msg (wait q)) 16 | (define output (make-string)) 17 | (while (not (eq? msg 'quit)) 18 | (string-append! output msg) 19 | (set! msg (wait q))) 20 | output) 21 | 22 | (export call-with-output-string) 23 | 24 | (define (write-u8 byte out) 25 | (define out (car out)) 26 | (cond 27 | ((file? out) (write-file out (make-string 1 byte))) 28 | (else 29 | (send (make-string 1 byte) out) 30 | (if (or (= byte 13) (= byte 10)) 31 | (pause)))) 32 | out) 33 | 34 | (export write-u8) 35 | 36 | (define (read-u8 in) 37 | (define input-buffer (cdr in)) 38 | (define my-in (car in)) 39 | (if (file? my-in) (return (read-file-u8 my-in input-buffer))) 40 | (if (> (string-length input-buffer) 0) 41 | (string-read-byte! input-buffer) 42 | (begin 43 | (define msg (wait my-in)) 44 | (cond 45 | ((and (string? msg) (> (string-length msg) 0)) 46 | (string-append! input-buffer msg) 47 | (read-u8 in)) 48 | ((string? msg) -1) 49 | (else (error 'read-u8 "Non-string on input stream")))))) 50 | 51 | (export read-u8) 52 | 53 | (define (read-file-u8 in input-buffer) 54 | (if (> (string-length input-buffer) 0) 55 | (string-read-byte! input-buffer) 56 | (begin 57 | (define msg (read-file in 1024)) 58 | (cond 59 | ((and (string? msg) (> (string-length msg) 0)) 60 | (string-append! input-buffer msg) 61 | (read-file-u8 in input-buffer)) 62 | ((string? msg) -1) 63 | (else (error 'read-file-u8 "Non-string on file stream")))))) 64 | 65 | (export read-file-u8) 66 | 67 | ;; Boolean Operators 68 | ;; 69 | 70 | (define (assert-boolean value) 71 | (if (boolean? value) 72 | value 73 | (error 'assert-boolean "expected a boolean, got" value))) 74 | 75 | (export assert-boolean) 76 | 77 | ;; Symbols 78 | ;; 79 | 80 | (define (kl:intern name) 81 | (cond ((equal? name "true") #t) 82 | ((equal? name "false") #f) 83 | ((string-find name "@") (string->symbol (string-replace name "@" "_waspvm_at_"))) 84 | ((string-find name ";") (string->symbol (string-replace name ";" "_waspvm_sc_"))) 85 | ((string-find name "$") (string->symbol (string-replace name "$" "_waspvm_dl_"))) 86 | (else (string->symbol name)))) 87 | 88 | ;; Strings 89 | ;; 90 | 91 | (define (kl:str value) 92 | (cond ((eq? value #t) "true") 93 | ((eq? value #f) "false") 94 | ((symbol? value) 95 | (define s (symbol->string value)) 96 | (cond 97 | ((string-find s "_waspvm_at_") 98 | (string-replace s "_waspvm_at_" "@")) 99 | ((string-find s "_waspvm_sc_") 100 | (string-replace s "_waspvm_sc_" ";")) 101 | ((string-find s "_waspvm_dl_") 102 | (string-replace s "_waspvm_dl_" "$")) 103 | (else s))) 104 | ((function? value) ;; Required for kl:symbol to return false for functions 105 | (string-append "#" (format (type value)) " " (format value))) 106 | (else 107 | (format value)))) 108 | 109 | ;; Assignments 110 | ;; 111 | 112 | (define *shen-globals* (make-dict)) 113 | 114 | (define (kl:set key val) 115 | (dict-set! *shen-globals* key val) 116 | val) 117 | 118 | (define (kl:value key) 119 | (if (not (dict-set? *shen-globals* key)) 120 | (error 'kl:set "variable has no value: " key)) 121 | (dict-ref *shen-globals* key)) 122 | 123 | (define (kl:error-to-string e) 124 | (format e)) 125 | 126 | (define (vector=? a b) 127 | (define len (vector-length a)) 128 | (if (not (= len (vector-length b))) 129 | (return #f)) 130 | 131 | (define i 0) 132 | (while (< i len) 133 | (if (not (kl:= (vector-ref a i) (vector-ref b i))) 134 | (return #f)) 135 | (set! i (+ 1 i))) 136 | #t) 137 | 138 | (define (kl:= a b) 139 | (cond ((eq? a b) #t) ;; fast path 140 | ((number? a) (and (number? b) (= a b))) 141 | ((pair? a) 142 | (and (pair? b) 143 | (kl:= (car a) (car b)) 144 | (kl:= (cdr a) (cdr b)))) 145 | ((string? a) (and (string? b) (string=? a b))) 146 | ((vector? a) (and (vector? b) (vector=? a b))) 147 | ;; the first eq? test already covers for null and symbols 148 | (else #f))) 149 | 150 | (define (kl:eval-kl expr) 151 | (eval (kl->wasp expr))) 152 | 153 | (define (full-path-for-file filename) 154 | (path-join (kl:value (quote *home-directory*)) filename)) 155 | 156 | (define (kl:open filename direction) 157 | (let ((full-path (full-path-for-file filename))) 158 | (case direction 159 | ((in) (if (path-exists? full-path) 160 | (cons (open-file full-path "r") (make-string)) 161 | (error 'kl:open "File does not exist" full-path))) 162 | ((out) (cons (open-file full-path "wct") #f)) 163 | (else (error 'kl:open "Invalid direction" direction))))) 164 | 165 | (define (kl:close stream) 166 | (if (file? (car stream)) 167 | (close-file (car stream)) 168 | (send 'close (car stream)))) 169 | 170 | (define (kl:get-time sym) 171 | (case sym 172 | ((real) (now)) 173 | ((run) (now)) 174 | (else (error kl:get-time "get-time does not understand the parameter" sym)))) 175 | 176 | (export kl:get-time kl:close kl:open kl:eval-kl kl:= kl:error-to-string kl:value kl:set kl:str kl:intern) 177 | -------------------------------------------------------------------------------- /compiled/load.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/load.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote load) 1) (define (kl:load V643) (let ((Load (let ((Start (kl:get-time (quote run)))) (let ((Result (kl:shen.load-help (kl:value (quote shen.*tc*)) (kl:read-file V643)))) (let ((Finish (kl:get-time (quote run)))) (let ((Time (- Finish Start))) (let ((Message (kl:shen.prhush (string-append "\nrun time: " (string-append (kl:str Time) " secs\n")) (kl:stoutput)))) Result))))))) (let ((Infs (if (assert-boolean (kl:value (quote shen.*tc*))) (kl:shen.prhush (string-append "\ntypechecked in " (kl:shen.app (kl:inferences) " inferences\n" (quote shen.a))) (kl:stoutput)) (quote shen.skip)))) (quote loaded)))) (export load) (quote load)) 4 | (begin (register-function-arity (quote shen.load-help) 2) (define (kl:shen.load-help V650 V651) (cond ((kl:= #f V650) (kl:shen.for-each (lambda (X) (kl:shen.prhush (kl:shen.app (kl:shen.eval-without-macros X) "\n" (quote shen.s)) (kl:stoutput))) V651)) (#t (let ((RemoveSynonyms (kl:mapcan (lambda (X) (kl:shen.remove-synonyms X)) V651))) (let ((Table (kl:mapcan (lambda (X) (kl:shen.typetable X)) RemoveSynonyms))) (let ((Assume (kl:shen.for-each (lambda (X) (kl:shen.assumetype X)) Table))) (guard (lambda (E) (kl:shen.unwind-types E Table)) (kl:shen.for-each (lambda (X) (kl:shen.typecheck-and-load X)) RemoveSynonyms)))))))) (export shen.load-help) (quote shen.load-help)) 5 | (begin (register-function-arity (quote shen.remove-synonyms) 1) (define (kl:shen.remove-synonyms V653) (cond ((and (pair? V653) (eq? (quote shen.synonyms-help) (car V653))) (begin (kl:eval V653) (quote ()))) (#t (cons V653 (quote ()))))) (export shen.remove-synonyms) (quote shen.remove-synonyms)) 6 | (begin (register-function-arity (quote shen.typecheck-and-load) 1) (define (kl:shen.typecheck-and-load V655) (begin (kl:nl 1) (kl:shen.typecheck-and-evaluate V655 (kl:gensym (quote A))))) (export shen.typecheck-and-load) (quote shen.typecheck-and-load)) 7 | (begin (register-function-arity (quote shen.typetable) 1) (define (kl:shen.typetable V661) (cond ((and (pair? V661) (and (eq? (quote define) (car V661)) (pair? (cdr V661)))) (let ((Sig (kl:compile (lambda (Y) (kl:shen. Y)) (cdr (cdr V661)) (lambda (E) (simple-error (kl:shen.app (car (cdr V661)) " lacks a proper signature.\n" (quote shen.a))))))) (cons (cons (car (cdr V661)) Sig) (quote ())))) (#t (quote ())))) (export shen.typetable) (quote shen.typetable)) 8 | (begin (register-function-arity (quote shen.assumetype) 1) (define (kl:shen.assumetype V663) (cond ((pair? V663) (kl:declare (car V663) (cdr V663))) (#t (kl:shen.f_error (quote shen.assumetype))))) (export shen.assumetype) (quote shen.assumetype)) 9 | (begin (register-function-arity (quote shen.unwind-types) 2) (define (kl:shen.unwind-types V670 V671) (cond ((null? V671) (simple-error (kl:error-to-string V670))) ((and (pair? V671) (pair? (car V671))) (begin (kl:shen.remtype (car (car V671))) (kl:shen.unwind-types V670 (cdr V671)))) (#t (kl:shen.f_error (quote shen.unwind-types))))) (export shen.unwind-types) (quote shen.unwind-types)) 10 | (begin (register-function-arity (quote shen.remtype) 1) (define (kl:shen.remtype V673) (kl:set (quote shen.*signedfuncs*) (kl:shen.removetype V673 (kl:value (quote shen.*signedfuncs*))))) (export shen.remtype) (quote shen.remtype)) 11 | (begin (register-function-arity (quote shen.removetype) 2) (define (kl:shen.removetype V681 V682) (cond ((null? V682) (quote ())) ((and (pair? V682) (and (pair? (car V682)) (kl:= (car (car V682)) V681))) (kl:shen.removetype (car (car V682)) (cdr V682))) ((pair? V682) (cons (car V682) (kl:shen.removetype V681 (cdr V682)))) (#t (kl:shen.f_error (quote shen.removetype))))) (export shen.removetype) (quote shen.removetype)) 12 | (begin (register-function-arity (quote shen.) 1) (define (kl:shen. V684) (let ((Parse_shen. (kl:shen. V684))) (if (kl:not (kl:= (kl:fail) Parse_shen.)) (let ((Parse_ (kl: Parse_shen.))) (if (kl:not (kl:= (kl:fail) Parse_)) (kl:shen.pair (car Parse_) (kl:shen.hdtl Parse_shen.)) (kl:fail))) (kl:fail)))) (export shen.) (quote shen.)) 13 | (begin (register-function-arity (quote write-to-file) 2) (define (kl:write-to-file V687 V688) (let ((Stream (kl:open V687 (quote out)))) (let ((String (if (string? V688) (kl:shen.app V688 "\n\n" (quote shen.a)) (kl:shen.app V688 "\n\n" (quote shen.s))))) (let ((Write (kl:pr String Stream))) (let ((Close (kl:close Stream))) V688))))) (export write-to-file) (quote write-to-file)) 14 | -------------------------------------------------------------------------------- /compiled/dict.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/dict.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote shen.dict) 1) (define (kl:shen.dict V2284) (cond ((< V2284 1) (simple-error (string-append "invalid initial dict size: " (kl:shen.app V2284 "" (quote shen.s))))) (#t (let ((D (make-vector (+ 3 V2284) (quote (quote shen.fail!))))) (let ((Tag (let ((_tmp D)) (vector-set! _tmp 0 (quote shen.dictionary)) _tmp))) (let ((Capacity (let ((_tmp D)) (vector-set! _tmp 1 V2284) _tmp))) (let ((Count (let ((_tmp D)) (vector-set! _tmp 2 0) _tmp))) (let ((Fill (kl:shen.fillvector D 3 (+ 2 V2284) (quote ())))) D)))))))) (export shen.dict) (quote shen.dict)) 4 | (begin (register-function-arity (quote shen.dict?) 1) (define (kl:shen.dict? V2286) (and (vector? V2286) (eq? (guard (lambda (E) (quote shen.not-dictionary)) (vector-ref V2286 0)) (quote shen.dictionary)))) (export shen.dict?) (quote shen.dict?)) 5 | (begin (register-function-arity (quote shen.dict-capacity) 1) (define (kl:shen.dict-capacity V2288) (vector-ref V2288 1)) (export shen.dict-capacity) (quote shen.dict-capacity)) 6 | (begin (register-function-arity (quote shen.dict-count) 1) (define (kl:shen.dict-count V2290) (vector-ref V2290 2)) (export shen.dict-count) (quote shen.dict-count)) 7 | (begin (register-function-arity (quote shen.dict-count->) 2) (define (kl:shen.dict-count-> V2293 V2294) (let ((_tmp V2293)) (vector-set! _tmp 2 V2294) _tmp)) (export shen.dict-count->) (quote shen.dict-count->)) 8 | (begin (register-function-arity (quote shen.<-dict-bucket) 2) (define (kl:shen.<-dict-bucket V2297 V2298) (vector-ref V2297 (+ 3 V2298))) (export shen.<-dict-bucket) (quote shen.<-dict-bucket)) 9 | (begin (register-function-arity (quote shen.dict-bucket->) 3) (define (kl:shen.dict-bucket-> V2302 V2303 V2304) (let ((_tmp V2302)) (vector-set! _tmp (+ 3 V2303) V2304) _tmp)) (export shen.dict-bucket->) (quote shen.dict-bucket->)) 10 | (begin (register-function-arity (quote shen.dict-update-count) 3) (define (kl:shen.dict-update-count V2308 V2309 V2310) (let ((Diff (- (kl:length V2310) (kl:length V2309)))) (kl:shen.dict-count-> V2308 (+ Diff (kl:shen.dict-count V2308))))) (export shen.dict-update-count) (quote shen.dict-update-count)) 11 | (begin (register-function-arity (quote shen.dict->) 3) (define (kl:shen.dict-> V2314 V2315 V2316) (let ((N (kl:hash V2315 (kl:shen.dict-capacity V2314)))) (let ((Bucket (kl:shen.<-dict-bucket V2314 N))) (let ((NewBucket (kl:shen.assoc-set V2315 V2316 Bucket))) (let ((Change (kl:shen.dict-bucket-> V2314 N NewBucket))) (let ((Count (kl:shen.dict-update-count V2314 Bucket NewBucket))) V2316)))))) (export shen.dict->) (quote shen.dict->)) 12 | (begin (register-function-arity (quote shen.<-dict) 2) (define (kl:shen.<-dict V2319 V2320) (let ((N (kl:hash V2320 (kl:shen.dict-capacity V2319)))) (let ((Bucket (kl:shen.<-dict-bucket V2319 N))) (let ((Result (kl:assoc V2320 Bucket))) (if (kl:empty? Result) (simple-error (string-append "value " (kl:shen.app V2320 " not found in dict\n" (quote shen.a)))) (cdr Result)))))) (export shen.<-dict) (quote shen.<-dict)) 13 | (begin (register-function-arity (quote shen.dict-rm) 2) (define (kl:shen.dict-rm V2323 V2324) (let ((N (kl:hash V2324 (kl:shen.dict-capacity V2323)))) (let ((Bucket (kl:shen.<-dict-bucket V2323 N))) (let ((NewBucket (kl:shen.assoc-rm V2324 Bucket))) (let ((Change (kl:shen.dict-bucket-> V2323 N NewBucket))) (let ((Count (kl:shen.dict-update-count V2323 Bucket NewBucket))) V2324)))))) (export shen.dict-rm) (quote shen.dict-rm)) 14 | (begin (register-function-arity (quote shen.dict-fold) 3) (define (kl:shen.dict-fold V2328 V2329 V2330) (let ((Limit (kl:shen.dict-capacity V2329))) (kl:shen.dict-fold-h V2328 V2329 V2330 0 Limit))) (export shen.dict-fold) (quote shen.dict-fold)) 15 | (begin (register-function-arity (quote shen.dict-fold-h) 5) (define (kl:shen.dict-fold-h V2337 V2338 V2339 V2340 V2341) (cond ((kl:= V2341 V2340) V2339) (#t (let ((B (kl:shen.<-dict-bucket V2338 V2340))) (let ((Acc (kl:shen.bucket-fold V2337 B V2339))) (kl:shen.dict-fold-h V2337 V2338 Acc (+ 1 V2340) V2341)))))) (export shen.dict-fold-h) (quote shen.dict-fold-h)) 16 | (begin (register-function-arity (quote shen.bucket-fold) 3) (define (kl:shen.bucket-fold V2345 V2346 V2347) (cond ((null? V2346) V2347) ((and (pair? V2346) (pair? (car V2346))) (((V2345 (car (car V2346))) (cdr (car V2346))) (kl:shen.bucket-fold V2345 (cdr V2346) V2347))) (#t (kl:shen.f_error (quote shen.bucket-fold))))) (export shen.bucket-fold) (quote shen.bucket-fold)) 17 | (begin (register-function-arity (quote shen.dict-keys) 1) (define (kl:shen.dict-keys V2349) (kl:shen.dict-fold (lambda (K) (lambda (_) (lambda (Acc) (cons K Acc)))) V2349 (quote ()))) (export shen.dict-keys) (quote shen.dict-keys)) 18 | (begin (register-function-arity (quote shen.dict-values) 1) (define (kl:shen.dict-values V2351) (kl:shen.dict-fold (lambda (_) (lambda (V) (lambda (Acc) (cons V Acc)))) V2351 (quote ()))) (export shen.dict-values) (quote shen.dict-values)) 19 | -------------------------------------------------------------------------------- /kl/track.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun shen.f_error (V3077) (do (shen.prhush (cn "partial function " (shen.app V3077 "; 32 | " shen.a)) (stoutput)) (do (if (and (not (shen.tracked? V3077)) (y-or-n? (cn "track " (shen.app V3077 "? " shen.a)))) (shen.track-function (ps V3077)) shen.ok) (simple-error "aborted")))) 33 | 34 | (defun shen.tracked? (V3079) (element? V3079 (value shen.*tracking*))) 35 | 36 | (defun track (V3081) (let Source (ps V3081) (shen.track-function Source))) 37 | 38 | (defun shen.track-function (V3083) (cond ((and (cons? V3083) (and (= defun (hd V3083)) (and (cons? (tl V3083)) (and (cons? (tl (tl V3083))) (and (cons? (tl (tl (tl V3083)))) (= () (tl (tl (tl (tl V3083)))))))))) (let KL (cons defun (cons (hd (tl V3083)) (cons (hd (tl (tl V3083))) (cons (shen.insert-tracking-code (hd (tl V3083)) (hd (tl (tl V3083))) (hd (tl (tl (tl V3083))))) ())))) (let Ob (eval-kl KL) (let Tr (set shen.*tracking* (cons Ob (value shen.*tracking*))) Ob)))) (true (shen.f_error shen.track-function)))) 39 | 40 | (defun shen.insert-tracking-code (V3087 V3088 V3089) (cons do (cons (cons set (cons shen.*call* (cons (cons + (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.input-track (cons (cons value (cons shen.*call* ())) (cons V3087 (cons (shen.cons_form V3088) ())))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons (cons let (cons Result (cons V3089 (cons (cons do (cons (cons shen.output-track (cons (cons value (cons shen.*call* ())) (cons V3087 (cons Result ())))) (cons (cons do (cons (cons set (cons shen.*call* (cons (cons - (cons (cons value (cons shen.*call* ())) (cons 1 ()))) ()))) (cons (cons do (cons (cons shen.terpri-or-read-char ()) (cons Result ()))) ()))) ()))) ())))) ()))) ()))) ())))) 41 | 42 | (defun step (V3095) (cond ((= + V3095) (set shen.*step* true)) ((= - V3095) (set shen.*step* false)) (true (simple-error "step expects a + or a -. 43 | ")))) 44 | 45 | (defun spy (V3101) (cond ((= + V3101) (set shen.*spy* true)) ((= - V3101) (set shen.*spy* false)) (true (simple-error "spy expects a + or a -. 46 | ")))) 47 | 48 | (defun shen.terpri-or-read-char () (if (value shen.*step*) (shen.check-byte (read-byte (value *stinput*))) (nl 1))) 49 | 50 | (defun shen.check-byte (V3107) (cond ((= V3107 (shen.hat)) (simple-error "aborted")) (true true))) 51 | 52 | (defun shen.input-track (V3111 V3112 V3113) (do (shen.prhush (cn " 53 | " (shen.app (shen.spaces V3111) (cn "<" (shen.app V3111 (cn "> Inputs to " (shen.app V3112 (cn " 54 | " (shen.app (shen.spaces V3111) "" shen.a)) shen.a)) shen.a)) shen.a)) (stoutput)) (shen.recursively-print V3113))) 55 | 56 | (defun shen.recursively-print (V3115) (cond ((= () V3115) (shen.prhush " ==>" (stoutput))) ((cons? V3115) (do (print (hd V3115)) (do (shen.prhush ", " (stoutput)) (shen.recursively-print (tl V3115))))) (true (shen.f_error shen.recursively-print)))) 57 | 58 | (defun shen.spaces (V3117) (cond ((= 0 V3117) "") (true (cn " " (shen.spaces (- V3117 1)))))) 59 | 60 | (defun shen.output-track (V3121 V3122 V3123) (shen.prhush (cn " 61 | " (shen.app (shen.spaces V3121) (cn "<" (shen.app V3121 (cn "> Output from " (shen.app V3122 (cn " 62 | " (shen.app (shen.spaces V3121) (cn "==> " (shen.app V3123 "" shen.s)) shen.a)) shen.a)) shen.a)) shen.a)) (stoutput))) 63 | 64 | (defun untrack (V3125) (let Tracking (value shen.*tracking*) (let Tracking (set shen.*tracking* (remove V3125 Tracking)) (eval (ps V3125))))) 65 | 66 | (defun profile (V3127) (shen.profile-help (ps V3127))) 67 | 68 | (defun shen.profile-help (V3133) (cond ((and (cons? V3133) (and (= defun (hd V3133)) (and (cons? (tl V3133)) (and (cons? (tl (tl V3133))) (and (cons? (tl (tl (tl V3133)))) (= () (tl (tl (tl (tl V3133)))))))))) (let G (gensym shen.f) (let Profile (cons defun (cons (hd (tl V3133)) (cons (hd (tl (tl V3133))) (cons (shen.profile-func (hd (tl V3133)) (hd (tl (tl V3133))) (cons G (hd (tl (tl V3133))))) ())))) (let Def (cons defun (cons G (cons (hd (tl (tl V3133))) (cons (subst G (hd (tl V3133)) (hd (tl (tl (tl V3133))))) ())))) (let CompileProfile (shen.eval-without-macros Profile) (let CompileG (shen.eval-without-macros Def) (hd (tl V3133)))))))) (true (simple-error "Cannot profile. 69 | ")))) 70 | 71 | (defun unprofile (V3135) (untrack V3135)) 72 | 73 | (defun shen.profile-func (V3139 V3140 V3141) (cons let (cons Start (cons (cons get-time (cons run ())) (cons (cons let (cons Result (cons V3141 (cons (cons let (cons Finish (cons (cons - (cons (cons get-time (cons run ())) (cons Start ()))) (cons (cons let (cons Record (cons (cons shen.put-profile (cons V3139 (cons (cons + (cons (cons shen.get-profile (cons V3139 ())) (cons Finish ()))) ()))) (cons Result ())))) ())))) ())))) ()))))) 74 | 75 | (defun profile-results (V3143) (let Results (shen.get-profile V3143) (let Initialise (shen.put-profile V3143 0) (@p V3143 Results)))) 76 | 77 | (defun shen.get-profile (V3145) (trap-error (get V3145 profile (value *property-vector*)) (lambda E 0))) 78 | 79 | (defun shen.put-profile (V3148 V3149) (put V3148 profile V3149 (value *property-vector*))) 80 | 81 | 82 | 83 | -------------------------------------------------------------------------------- /kl/extension-expand-dynamic.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2019 Bruno Deferrari. 2 | BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | 4 | (defun shen.x.expand-dynamic.initialise () (do (set shen.x.expand-dynamic.*external-symbols* ()) (set shen.x.expand-dynamic.*arities* ()))) 5 | 6 | (defun shen.x.expand-dynamic.expand-dynamic (V5077) (cond ((= () V5077) ()) ((and (cons? V5077) (and (cons? (hd V5077)) (and (= declare (hd (hd V5077))) (and (cons? (tl (hd V5077))) (and (cons? (tl (tl (hd V5077)))) (= () (tl (tl (tl (hd V5077)))))))))) (append (shen.x.expand-dynamic.expand-declare (hd V5077)) (shen.x.expand-dynamic.expand-dynamic (tl V5077)))) ((and (cons? V5077) (and (cons? (hd V5077)) (and (= put (hd (hd V5077))) (and (cons? (tl (hd V5077))) (and (cons? (hd (tl (hd V5077)))) (and (= intern (hd (hd (tl (hd V5077))))) (and (cons? (tl (hd (tl (hd V5077))))) (and (= "shen" (hd (tl (hd (tl (hd V5077)))))) (and (= () (tl (tl (hd (tl (hd V5077)))))) (and (cons? (tl (tl (hd V5077)))) (and (= shen.external-symbols (hd (tl (tl (hd V5077))))) (and (cons? (tl (tl (tl (hd V5077))))) (and (cons? (tl (tl (tl (tl (hd V5077)))))) (= () (tl (tl (tl (tl (tl (hd V5077)))))))))))))))))))) (do (set shen.x.expand-dynamic.*external-symbols* (eval-kl (hd (tl (tl (tl (hd V5077))))))) (cons (hd V5077) (shen.x.expand-dynamic.expand-dynamic (tl V5077))))) ((and (cons? V5077) (and (cons? (hd V5077)) (and (= shen.initialise_arity_table (hd (hd V5077))) (and (cons? (tl (hd V5077))) (= () (tl (tl (hd V5077)))))))) (do (set shen.x.expand-dynamic.*arities* (eval-kl (hd (tl (hd V5077))))) (cons (hd V5077) (shen.x.expand-dynamic.expand-dynamic (tl V5077))))) ((and (cons? V5077) (and (cons? (hd V5077)) (and (= shen.for-each (hd (hd V5077))) (and (cons? (tl (hd V5077))) (and (cons? (hd (tl (hd V5077)))) (and (= lambda (hd (hd (tl (hd V5077))))) (and (cons? (tl (hd (tl (hd V5077))))) (and (cons? (tl (tl (hd (tl (hd V5077)))))) (and (cons? (hd (tl (tl (hd (tl (hd V5077))))))) (and (= shen.set-lambda-form-entry (hd (hd (tl (tl (hd (tl (hd V5077)))))))) (and (cons? (tl (hd (tl (tl (hd (tl (hd V5077)))))))) (and (= () (tl (tl (hd (tl (tl (hd (tl (hd V5077))))))))) (and (= () (tl (tl (tl (hd (tl (hd V5077))))))) (and (cons? (tl (tl (hd V5077)))) (and (= () (tl (tl (tl (hd V5077))))) (= (hd (tl (hd (tl (tl (hd (tl (hd V5077)))))))) (hd (tl (hd (tl (hd V5077))))))))))))))))))))) (append (shen.x.expand-dynamic.expand-lambda-entries (hd (tl (tl (hd V5077))))) (shen.x.expand-dynamic.expand-dynamic (tl V5077)))) ((cons? V5077) (cons (hd V5077) (shen.x.expand-dynamic.expand-dynamic (tl V5077)))) (true (shen.f_error shen.x.expand-dynamic.expand-dynamic)))) 7 | 8 | (defun shen.x.expand-dynamic.expand-declare (V5079) (cond ((and (cons? V5079) (and (= declare (hd V5079)) (and (cons? (tl V5079)) (and (cons? (tl (tl V5079))) (= () (tl (tl (tl V5079)))))))) (let Eval (eval-kl V5079) (let F* (concat shen.type-signature-of- (hd (tl V5079))) (let KlDef (ps F*) (let RecordSig (cons set (cons shen.*signedfuncs* (cons (cons cons (cons (cons cons (tl V5079)) (cons (cons value (cons shen.*signedfuncs* ())) ()))) ()))) (let RecordLambda (cons shen.set-lambda-form-entry (cons (cons cons (cons F* (cons (shen.lambda-form F* 3) ()))) ())) (cons KlDef (cons RecordSig (cons RecordLambda ()))))))))) (true (shen.f_error shen.x.expand-dynamic.expand-declare)))) 9 | 10 | (defun shen.x.expand-dynamic.expand-lambda-entries (V5082) (cond ((= () V5082) ()) ((and (cons? V5082) (and (= mapcan (hd V5082)) (and (cons? (tl V5082)) (and (cons? (hd (tl V5082))) (and (= lambda (hd (hd (tl V5082)))) (and (cons? (tl (hd (tl V5082)))) (and (cons? (tl (tl (hd (tl V5082))))) (and (cons? (hd (tl (tl (hd (tl V5082)))))) (and (= shen.lambda-form-entry (hd (hd (tl (tl (hd (tl V5082))))))) (and (cons? (tl (hd (tl (tl (hd (tl V5082))))))) (and (= () (tl (tl (hd (tl (tl (hd (tl V5082)))))))) (and (= () (tl (tl (tl (hd (tl V5082)))))) (and (cons? (tl (tl V5082))) (and (cons? (hd (tl (tl V5082)))) (and (= external (hd (hd (tl (tl V5082))))) (and (cons? (tl (hd (tl (tl V5082))))) (and (cons? (hd (tl (hd (tl (tl V5082)))))) (and (= intern (hd (hd (tl (hd (tl (tl V5082))))))) (and (cons? (tl (hd (tl (hd (tl (tl V5082))))))) (and (= "shen" (hd (tl (hd (tl (hd (tl (tl V5082)))))))) (and (= () (tl (tl (hd (tl (hd (tl (tl V5082)))))))) (and (= () (tl (tl (hd (tl (tl V5082)))))) (and (= () (tl (tl (tl V5082)))) (= (hd (tl (hd (tl (tl (hd (tl V5082))))))) (hd (tl (hd (tl V5082)))))))))))))))))))))))))))) (mapcan (lambda F (shen.x.expand-dynamic.expand-lambda-form-entry F)) (value shen.x.expand-dynamic.*external-symbols*))) ((and (cons? V5082) (and (= cons (hd V5082)) (and (cons? (tl V5082)) (and (cons? (hd (tl V5082))) (and (= cons (hd (hd (tl V5082)))) (and (cons? (tl (hd (tl V5082)))) (and (cons? (tl (tl (hd (tl V5082))))) (and (= () (tl (tl (tl (hd (tl V5082)))))) (and (cons? (tl (tl V5082))) (= () (tl (tl (tl V5082))))))))))))) (cons (cons shen.set-lambda-form-entry (cons (hd (tl V5082)) ())) (shen.x.expand-dynamic.expand-lambda-entries (hd (tl (tl V5082)))))) (true (shen.f_error shen.x.expand-dynamic.expand-lambda-entries)))) 11 | 12 | (defun shen.x.expand-dynamic.get-arity (V5094 V5095) (cond ((= () V5095) -1) ((and (cons? V5095) (and (cons? (tl V5095)) (= (hd V5095) V5094))) (hd (tl V5095))) ((and (cons? V5095) (cons? (tl V5095))) (shen.x.expand-dynamic.get-arity V5094 (tl (tl V5095)))) (true (shen.f_error shen.x.expand-dynamic.get-arity)))) 13 | 14 | (defun shen.x.expand-dynamic.expand-lambda-form-entry (V5097) (cond ((= package V5097) ()) ((= receive V5097) ()) (true (let ArityF (shen.x.expand-dynamic.get-arity V5097 (value shen.x.expand-dynamic.*arities*)) (if (= ArityF -1) () (if (= ArityF 0) () (cons (cons shen.set-lambda-form-entry (cons (cons cons (cons V5097 (cons (shen.lambda-form V5097 ArityF) ()))) ())) ()))))))) 15 | 16 | (defun shen.x.expand-dynamic.split-defuns-h (V5100 V5101) (cond ((and (cons? V5100) (and (cons? (hd V5100)) (and (= defun (hd (hd V5100))) (tuple? V5101)))) (shen.x.expand-dynamic.split-defuns-h (tl V5100) (@p (cons (hd V5100) (fst V5101)) (snd V5101)))) ((and (cons? V5100) (tuple? V5101)) (shen.x.expand-dynamic.split-defuns-h (tl V5100) (@p (fst V5101) (cons (hd V5100) (snd V5101))))) ((and (= () V5100) (tuple? V5101)) (@p (reverse (fst V5101)) (reverse (snd V5101)))) (true (shen.f_error shen.x.expand-dynamic.split-defuns-h)))) 17 | 18 | (defun shen.x.expand-dynamic.split-defuns (V5103) (shen.x.expand-dynamic.split-defuns-h V5103 (@p () ()))) 19 | 20 | (defun shen.x.expand-dynamic.wrap-in-defun (V5107 V5108 V5109) (cons defun (cons V5107 (cons V5108 (cons (shen.x.expand-dynamic.to-single-expression V5109) ()))))) 21 | 22 | (defun shen.x.expand-dynamic.to-single-expression (V5111) (cond ((and (cons? V5111) (= () (tl V5111))) (hd V5111)) ((cons? V5111) (cons do (cons (hd V5111) (cons (shen.x.expand-dynamic.to-single-expression (tl V5111)) ())))) (true (shen.f_error shen.x.expand-dynamic.to-single-expression)))) 23 | 24 | 25 | 26 | -------------------------------------------------------------------------------- /driver.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | ; 4 | ; Shen Scheme derived soure code is: 5 | ; Copyright (c) 2012-2015 Bruno Deferrari. All rights reserved. 6 | 7 | (import "primitives") 8 | (import "declarations") 9 | (import "compiler") 10 | ;(load "primitives.ms") 11 | ;(load "declarations.ms") 12 | ;(load "overwrites-internal.ms") 13 | ;(load "compiler.ms") 14 | 15 | (define (pretty x) (if (list? x) (begin (print "(") (for-each (lambda (y) (if (list? y) (pretty y) (begin (print (format y)) (print " ")))) x) (print ") ")) (begin (print (format x)) (print " ")))) 16 | 17 | (define (char-whitespace? char) 18 | (or 19 | (= char (string-ref " " 0)) 20 | (= char (string-ref "\t" 0)) 21 | (= char (string-ref "\n" 0)) 22 | (= char (string-ref "\r" 0)))) 23 | 24 | (define (digit? char) 25 | (and (>= char 48) (<= char 57))) 26 | 27 | ;; From https://rosettacode.org/wiki/S-Expressions#Scheme 28 | (define (sexpr-read str) 29 | (define (help str) 30 | (let ((char (string-read-byte! str))) 31 | (cond 32 | ((or (not char) (eq? char (string-ref "\)" 0))) '()) 33 | ((= char (string-ref "(" 0)) 34 | (define lhs (help str)) 35 | (define rhs (help str)) 36 | (cons lhs rhs)) 37 | ((char-whitespace? char) (help str)) 38 | ((eq? char (string-ref "\"" 0)) (cons (quote-read str) (help str))) 39 | ((and (= char (string-ref "-" 0)) (> (string-length str) 1) (digit? (string-ref str 0))) (cons (* -1 (number-read str)) (help str))) 40 | ((digit? char) (string-prepend! str (make-string 1 char)) (cons (number-read str) (help str))) 41 | (else (string-prepend! str (make-string 1 char)) (cons (string-read str) (help str)))))) 42 | ; This is needed because the function conses all parsed sexprs onto something, 43 | ; so the top expression is one level too deep. 44 | (define result (help str)) 45 | (if (null? result ) result (car result))) 46 | 47 | (define (list->string lst str) 48 | (cond 49 | ((null? lst) str) 50 | (else 51 | (string-append-byte! str (car lst)) 52 | (list->string (cdr lst) str)))) 53 | 54 | 55 | (define (quote-read str) 56 | (define (help str) 57 | (let ((char (string-read-byte! str))) 58 | (if 59 | (or (not char) (eq? char (string-ref "\"" 0))) 60 | '() 61 | (cons char (help str))))) 62 | (list->string (help str) (make-string))) 63 | 64 | (define (string-read str) 65 | (define (help str) 66 | (let ((char (string-read-byte! str))) 67 | (cond 68 | ((or (not char) (char-whitespace? char)) '()) 69 | ((eq? char (string-ref ")" 0)) (string-prepend! str (make-string 1 char)) '()) 70 | (else (cons char (help str)))))) 71 | (kl:intern (list->string (help str) (make-string)))) 72 | 73 | (define (number-read str) 74 | (define real #f) 75 | (define (help str) 76 | (let ((char (string-read-byte! str))) 77 | (cond 78 | ((or (not char) (char-whitespace? char)) '()) 79 | ((eq? char (string-ref ")" 0)) (string-prepend! str (make-string 1 char)) '()) 80 | ((eq? char (string-ref "." 0)) (set! real #t) (cons char (help str))) 81 | ((or (< char 48) (> char 57)) (string-prepend! str (make-string 1 char)) '()) 82 | (else (cons char (help str)))))) 83 | (define str (list->string (help str) (make-string))) 84 | ((if real string->real string->integer) str)) 85 | 86 | (define (read-kl-file path) 87 | (sexpr-read (string-append "(" (read-data-file path) ")"))) 88 | 89 | (import "lib/waspc") 90 | 91 | (define (compile-all) 92 | (define files '("toplevel.kl" 93 | "core.kl" 94 | "sys.kl" 95 | "dict.kl" 96 | "sequent.kl" 97 | "yacc.kl" 98 | "reader.kl" 99 | "prolog.kl" 100 | "track.kl" 101 | "load.kl" 102 | "writer.kl" 103 | "macros.kl" 104 | "declarations.kl" 105 | "types.kl" 106 | "t-star.kl" 107 | "init.kl" 108 | "extension-features.kl" 109 | "extension-launcher.kl" 110 | "extension-factorise-defun.kl" 111 | "extension-programmable-pattern-matching.kl" 112 | )) 113 | (for-each 114 | (lambda (file) 115 | (print "Compiling ") (print file) (print "\n") 116 | (define compiled-name (string-append "compiled/" file)) 117 | (write-lisp-file (string-append compiled-name ".ms") (cons `(module ,compiled-name) (map kl->wasp (read-kl-file (string-append "kl/" file))))) 118 | (waspc (string-append "compiled/" file ".ms"))) 119 | files) 120 | (waspc "overwrites-internal.ms")) 121 | 122 | (define (eval-all) 123 | (define files '("toplevel.kl" 124 | "core.kl" 125 | "sys.kl" 126 | "dict.kl" 127 | "sequent.kl" 128 | "yacc.kl" 129 | "reader.kl" 130 | "prolog.kl" 131 | "track.kl" 132 | "load.kl" 133 | "writer.kl" 134 | "macros.kl" 135 | "declarations.kl" 136 | "types.kl" 137 | "t-star.kl" 138 | "init.kl" 139 | "extension-features.kl" 140 | "extension-launcher.kl" 141 | "extension-factorise-defun.kl" 142 | "extension-programmable-pattern-matching.kl" 143 | )) 144 | (for-each 145 | (lambda (file) 146 | (print "Compiling ") (print file) (print "\n") 147 | (map (lambda (x) (eval (kl->wasp x))) (read-kl-file (string-append "kl/" file)))) 148 | files) 149 | (load "overwrites-internal.ms")) 150 | 151 | 152 | (define (load-all) 153 | (define files '("toplevel.kl" 154 | "core.kl" 155 | "sys.kl" 156 | "dict.kl" 157 | "sequent.kl" 158 | "yacc.kl" 159 | "reader.kl" 160 | "prolog.kl" 161 | "track.kl" 162 | "load.kl" 163 | "writer.kl" 164 | "macros.kl" 165 | "declarations.kl" 166 | "types.kl" 167 | "t-star.kl" 168 | "init.kl" 169 | "extension-features.kl" 170 | "extension-launcher.kl" 171 | "extension-factorise-defun.kl" 172 | "extension-programmable-pattern-matching.kl" 173 | )) 174 | (for-each 175 | (lambda (file) 176 | (print "Loading ") (print file) (print "\n") 177 | (load (string-append "compiled/" file ".mo"))) 178 | files) 179 | (load "overwrites-internal.ms")) 180 | 181 | (kl:set (quote *language*) "Wasp Lisp") 182 | (kl:set (quote *implementation*) "WaspVM") 183 | (kl:set (quote *port*) "0.12") 184 | (kl:set (quote *release*) "0.12") 185 | (kl:set (quote *porters*) "Chris Double") 186 | (kl:set (quote *sterror*) (cons (current-output) #f)) 187 | (kl:set (quote *stinput*) (cons (current-input) (make-string))) 188 | (kl:set (quote *stoutput*) (cons (current-output) #f)) 189 | (kl:set (quote *home-directory*) (getcwd)) 190 | (kl:set (quote shen.*initial-home-directory*) (getcwd)) 191 | 192 | 193 | 194 | 195 | 196 | 197 | 198 | -------------------------------------------------------------------------------- /compiled/extension-programmable-pattern-matching.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/extension-programmable-pattern-matching.kl") 2 | "Copyright (c) 2019 Bruno Deferrari. All rights reserved.\nBSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.apply-pattern-handlers) 5) (define (kl:shen.x.programmable-pattern-matching.apply-pattern-handlers V5042 V5043 V5044 V5045 V5046) (cond ((null? V5042) (kl:fail)) (#t (let ((Freeze (lambda () (cond ((pair? V5042) (kl:shen.x.programmable-pattern-matching.apply-pattern-handlers (cdr V5042) V5043 V5044 V5045 V5046)) (#t (kl:shen.f_error (quote shen.x.programmable-pattern-matching.apply-pattern-handlers))))))) (if (pair? V5042) (let ((Result (((((car V5042) V5043) V5044) V5045) V5046))) (if (kl:= Result (kl:fail)) (kl:thaw Freeze) Result)) (kl:thaw Freeze)))))) (export shen.x.programmable-pattern-matching.apply-pattern-handlers) (quote shen.x.programmable-pattern-matching.apply-pattern-handlers)) 4 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.make-stack) 0) (define (kl:shen.x.programmable-pattern-matching.make-stack) (let ((_tmp (make-vector 1 (quote (quote shen.fail!))))) (vector-set! _tmp 0 (quote ())) _tmp)) (export shen.x.programmable-pattern-matching.make-stack) (quote shen.x.programmable-pattern-matching.make-stack)) 5 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.push) 2) (define (kl:shen.x.programmable-pattern-matching.push V5049 V5050) (let ((_tmp V5049)) (vector-set! _tmp 0 (cons V5050 (vector-ref V5049 0))) _tmp)) (export shen.x.programmable-pattern-matching.push) (quote shen.x.programmable-pattern-matching.push)) 6 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.pop-all) 1) (define (kl:shen.x.programmable-pattern-matching.pop-all V5052) (let ((Res (vector-ref V5052 0))) (let ((_ (let ((_tmp V5052)) (vector-set! _tmp 0 (quote ())) _tmp))) Res))) (export shen.x.programmable-pattern-matching.pop-all) (quote shen.x.programmable-pattern-matching.pop-all)) 7 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.compile-pattern) 3) (define (kl:shen.x.programmable-pattern-matching.compile-pattern V5056 V5057 V5058) (let ((VarsStack (kl:shen.x.programmable-pattern-matching.make-stack))) (let ((Self (quote Self_waspvm_dl__waspvm_dl_7907_waspvm_dl__waspvm_dl_))) (let ((AddTest (lambda (_) (quote shen.x.programmable-pattern-matching.ignored)))) (let ((Bind (lambda (Var) (lambda (_) (kl:shen.x.programmable-pattern-matching.push VarsStack Var))))) (let ((Result (kl:shen.x.programmable-pattern-matching.apply-pattern-handlers V5057 Self AddTest Bind V5056))) (if (kl:= Result (kl:fail)) (kl:thaw V5058) (kl:shen.x.programmable-pattern-matching.compile-pattern-h V5056 (kl:reverse (kl:shen.x.programmable-pattern-matching.pop-all VarsStack)))))))))) (export shen.x.programmable-pattern-matching.compile-pattern) (quote shen.x.programmable-pattern-matching.compile-pattern)) 8 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.compile-pattern-h) 2) (define (kl:shen.x.programmable-pattern-matching.compile-pattern-h V5061 V5062) (cond ((pair? V5061) (let ((Compile (lambda (X) (kl:shen. X)))) (let ((Handler (lambda (E) (simple-error (string-append "failed to compile " (kl:shen.app E "" (quote shen.a))))))) (let ((NewArgs (kl:map (lambda (Arg) (if (kl:element? Arg V5062) (kl:compile Compile (cons Arg (quote ())) Handler) Arg)) (cdr V5061)))) (cons (car V5061) NewArgs))))) (#t (kl:shen.f_error (quote shen.x.programmable-pattern-matching.compile-pattern-h))))) (export shen.x.programmable-pattern-matching.compile-pattern-h) (quote shen.x.programmable-pattern-matching.compile-pattern-h)) 9 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.reduce) 2) (define (kl:shen.x.programmable-pattern-matching.reduce V5065 V5066) (cond ((and (pair? V5065) (and (pair? (car V5065)) (and (eq? (quote /.) (car (car V5065))) (and (pair? (cdr (car V5065))) (and (pair? (car (cdr (car V5065)))) (and (pair? (cdr (cdr (car V5065)))) (and (null? (cdr (cdr (cdr (car V5065))))) (and (pair? (cdr V5065)) (null? (cdr (cdr V5065))))))))))) (let ((SelectorStack (kl:shen.x.programmable-pattern-matching.make-stack))) (let ((AddTest (lambda (Expr) (kl:shen.add_test Expr)))) (let ((Bind (lambda (Var) (lambda (Expr) (kl:shen.x.programmable-pattern-matching.push SelectorStack (kl:_waspvm_at_p Var Expr)))))) (let ((Result (kl:shen.x.programmable-pattern-matching.apply-pattern-handlers V5066 (car (cdr V5065)) AddTest Bind (car (cdr (car V5065)))))) (let ((Vars+Sels (kl:reverse (kl:shen.x.programmable-pattern-matching.pop-all SelectorStack)))) (let ((Vars (kl:map (lambda (V5019) (kl:fst V5019)) Vars+Sels))) (let ((Selectors (kl:map (lambda (V5020) (kl:snd V5020)) Vars+Sels))) (let ((Abstraction (kl:shen.abstraction_build Vars (kl:shen.ebr (car (cdr V5065)) (car (cdr (car V5065))) (car (cdr (cdr (car V5065)))))))) (let ((Application (kl:shen.application_build Selectors Abstraction))) (kl:shen.reduce_help Application))))))))))) (#t (kl:shen.f_error (quote shen.x.programmable-pattern-matching.reduce))))) (export shen.x.programmable-pattern-matching.reduce) (quote shen.x.programmable-pattern-matching.reduce)) 10 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.initialise) 0) (define (kl:shen.x.programmable-pattern-matching.initialise) (begin (kl:set (quote shen.*custom-pattern-compiler*) (lambda (Arg) (lambda (OnFail) (kl:shen.x.programmable-pattern-matching.compile-pattern Arg (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers*)) OnFail)))) (begin (kl:set (quote shen.*custom-pattern-reducer*) (lambda (Arg) (kl:shen.x.programmable-pattern-matching.reduce Arg (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers*))))) (begin (kl:set (quote shen.x.programmable-pattern-matching.*pattern-handlers*) (quote ())) (begin (kl:set (quote shen.x.programmable-pattern-matching.*pattern-handlers-reg*) (quote ())) (quote shen.x.programmable-pattern-matching.done)))))) (export shen.x.programmable-pattern-matching.initialise) (quote shen.x.programmable-pattern-matching.initialise)) 11 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.register-handler) 1) (define (kl:shen.x.programmable-pattern-matching.register-handler V5068) (cond ((kl:element? V5068 (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers-reg*))) V5068) (#t (begin (kl:set (quote shen.x.programmable-pattern-matching.*pattern-handlers-reg*) (cons V5068 (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers-reg*)))) (begin (kl:set (quote shen.x.programmable-pattern-matching.*pattern-handlers*) (cons (kl:function V5068) (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers*)))) V5068))))) (export shen.x.programmable-pattern-matching.register-handler) (quote shen.x.programmable-pattern-matching.register-handler)) 12 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.findpos) 2) (define (kl:shen.x.programmable-pattern-matching.findpos V5071 V5072) (guard (lambda (_) (simple-error (kl:shen.app V5071 " is not a pattern handler\n" (quote shen.a)))) (kl:shen.findpos V5071 V5072))) (export shen.x.programmable-pattern-matching.findpos) (quote shen.x.programmable-pattern-matching.findpos)) 13 | (begin (register-function-arity (quote shen.x.programmable-pattern-matching.unregister-handler) 1) (define (kl:shen.x.programmable-pattern-matching.unregister-handler V5074) (let ((Reg (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers-reg*)))) (let ((Pos (kl:shen.x.programmable-pattern-matching.findpos V5074 Reg))) (let ((RemoveReg (kl:set (quote shen.x.programmable-pattern-matching.*pattern-handlers-reg*) (kl:remove V5074 Reg)))) (let ((RemoveFun (kl:set (quote shen.x.programmable-pattern-matching.*pattern-handlers*) (kl:shen.remove-nth Pos (kl:value (quote shen.x.programmable-pattern-matching.*pattern-handlers*)))))) V5074))))) (export shen.x.programmable-pattern-matching.unregister-handler) (quote shen.x.programmable-pattern-matching.unregister-handler)) 14 | -------------------------------------------------------------------------------- /compiled/extension-launcher.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/extension-launcher.kl") 2 | "Copyright (c) 2019 Bruno Deferrari.\nBSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | (begin (register-function-arity (quote shen.x.launcher.quiet-load) 1) (define (kl:shen.x.launcher.quiet-load V4833) (let ((Contents (kl:read-file V4833))) (kl:map (lambda (X) (kl:shen.eval-without-macros X)) Contents))) (export shen.x.launcher.quiet-load) (quote shen.x.launcher.quiet-load)) 4 | (begin (register-function-arity (quote shen.x.launcher.version-string) 0) (define (kl:shen.x.launcher.version-string) (kl:shen.app (kl:version) (string-append " " (kl:shen.app (cons (quote port) (cons (cons (kl:language) (cons (kl:port) (quote ()))) (cons (quote implementation) (cons (cons (kl:implementation) (cons (kl:release) (quote ()))) (quote ()))))) "\n" (quote shen.r))) (quote shen.a))) (export shen.x.launcher.version-string) (quote shen.x.launcher.version-string)) 5 | (begin (register-function-arity (quote shen.x.launcher.help-text) 1) (define (kl:shen.x.launcher.help-text V4835) (string-append "Usage: " (kl:shen.app V4835 " [--version] [--help] []\n\ncommands:\n repl\n Launches the interactive REPL.\n Default action if no command is supplied.\n\n script []\n Runs the script in FILE. *argv* is set to [FILE | ARGS].\n\n eval \n Evaluates expressions and files. ARGS are evaluated from\n left to right and can be a combination of:\n -e, --eval \n Evaluates EXPR and prints result.\n -l, --load \n Reads and evaluates FILE.\n -q, --quiet\n Silences interactive output.\n -s, --set \n Evaluates KEY, VALUE and sets as global.\n -r, --repl\n Launches the interactive REPL after evaluating\n all the previous expresions." (quote shen.a)))) (export shen.x.launcher.help-text) (quote shen.x.launcher.help-text)) 6 | (begin (register-function-arity (quote shen.x.launcher.execute-all) 1) (define (kl:shen.x.launcher.execute-all V4837) (cond ((null? V4837) (cons (quote success) (quote ()))) ((pair? V4837) (begin (kl:thaw (car V4837)) (kl:shen.x.launcher.execute-all (cdr V4837)))) (#t (kl:shen.f_error (quote shen.x.launcher.execute-all))))) (export shen.x.launcher.execute-all) (quote shen.x.launcher.execute-all)) 7 | (begin (register-function-arity (quote shen.x.launcher.eval-string) 1) (define (kl:shen.x.launcher.eval-string V4839) (kl:eval (kl:head (kl:read-from-string V4839)))) (export shen.x.launcher.eval-string) (quote shen.x.launcher.eval-string)) 8 | (begin (register-function-arity (quote shen.x.launcher.eval-flag-map) 1) (define (kl:shen.x.launcher.eval-flag-map V4845) (cond ((equal? "-e" V4845) "--eval") ((equal? "-l" V4845) "--load") ((equal? "-q" V4845) "--quiet") ((equal? "-s" V4845) "--set") ((equal? "-r" V4845) "--repl") (#t #f))) (export shen.x.launcher.eval-flag-map) (quote shen.x.launcher.eval-flag-map)) 9 | (begin (register-function-arity (quote shen.x.launcher.eval-command-h) 2) (define (kl:shen.x.launcher.eval-command-h V4856 V4857) (cond ((null? V4856) (kl:shen.x.launcher.execute-all (kl:reverse V4857))) ((and (pair? V4856) (and (equal? "--eval" (car V4856)) (pair? (cdr V4856)))) (kl:shen.x.launcher.eval-command-h (cdr (cdr V4856)) (cons (lambda () (kl:shen.prhush (kl:shen.app (kl:shen.x.launcher.eval-string (car (cdr V4856))) "\n" (quote shen.a)) (kl:stoutput))) V4857))) ((and (pair? V4856) (and (equal? "--load" (car V4856)) (pair? (cdr V4856)))) (kl:shen.x.launcher.eval-command-h (cdr (cdr V4856)) (cons (lambda () (kl:load (car (cdr V4856)))) V4857))) ((and (pair? V4856) (equal? "--quiet" (car V4856))) (kl:shen.x.launcher.eval-command-h (cdr V4856) (cons (lambda () (kl:set (quote *hush*) #t)) V4857))) ((and (pair? V4856) (and (equal? "--set" (car V4856)) (and (pair? (cdr V4856)) (pair? (cdr (cdr V4856)))))) (kl:shen.x.launcher.eval-command-h (cdr (cdr (cdr V4856))) (cons (lambda () (kl:set (kl:shen.x.launcher.eval-string (car (cdr V4856))) (kl:shen.x.launcher.eval-string (car (cdr (cdr V4856)))))) V4857))) ((and (pair? V4856) (equal? "--repl" (car V4856))) (begin (kl:shen.x.launcher.eval-command-h (quote ()) V4857) (cons (quote launch-repl) (cdr V4856)))) (#t (let ((Freeze (lambda () (cond ((pair? V4856) (cons (quote error) (cons (string-append "Invalid eval argument: " (kl:shen.app (car V4856) "" (quote shen.a))) (quote ())))) (#t (kl:shen.f_error (quote shen.x.launcher.eval-command-h))))))) (if (pair? V4856) (let ((Result (let ((Long (kl:shen.x.launcher.eval-flag-map (car V4856)))) (if (kl:= #f Long) (kl:fail) (kl:shen.x.launcher.eval-command-h (cons Long (cdr V4856)) V4857))))) (if (kl:= Result (kl:fail)) (kl:thaw Freeze) Result)) (kl:thaw Freeze)))))) (export shen.x.launcher.eval-command-h) (quote shen.x.launcher.eval-command-h)) 10 | (begin (register-function-arity (quote shen.x.launcher.eval-command) 1) (define (kl:shen.x.launcher.eval-command V4859) (kl:shen.x.launcher.eval-command-h V4859 (quote ()))) (export shen.x.launcher.eval-command) (quote shen.x.launcher.eval-command)) 11 | (begin (register-function-arity (quote shen.x.launcher.script-command) 2) (define (kl:shen.x.launcher.script-command V4862 V4863) (begin (kl:set (quote *argv*) (cons V4862 V4863)) (begin (kl:shen.x.launcher.quiet-load V4862) (cons (quote success) (quote ()))))) (export shen.x.launcher.script-command) (quote shen.x.launcher.script-command)) 12 | (begin (register-function-arity (quote shen.x.launcher.launch-shen) 1) (define (kl:shen.x.launcher.launch-shen V4865) (cond ((and (pair? V4865) (null? (cdr V4865))) (cons (quote launch-repl) (quote ()))) ((and (pair? V4865) (and (pair? (cdr V4865)) (equal? "--help" (car (cdr V4865))))) (cons (quote show-help) (cons (kl:shen.x.launcher.help-text (car V4865)) (quote ())))) ((and (pair? V4865) (and (pair? (cdr V4865)) (equal? "--version" (car (cdr V4865))))) (cons (quote success) (cons (kl:shen.x.launcher.version-string) (quote ())))) ((and (pair? V4865) (and (pair? (cdr V4865)) (equal? "repl" (car (cdr V4865))))) (cons (quote launch-repl) (cdr (cdr V4865)))) ((and (pair? V4865) (and (pair? (cdr V4865)) (and (equal? "script" (car (cdr V4865))) (pair? (cdr (cdr V4865)))))) (kl:shen.x.launcher.script-command (car (cdr (cdr V4865))) (cdr (cdr (cdr V4865))))) ((and (pair? V4865) (and (pair? (cdr V4865)) (equal? "eval" (car (cdr V4865))))) (kl:shen.x.launcher.eval-command (cdr (cdr V4865)))) ((and (pair? V4865) (pair? (cdr V4865))) (cons (quote unknown-arguments) V4865)) (#t (kl:shen.f_error (quote shen.x.launcher.launch-shen))))) (export shen.x.launcher.launch-shen) (quote shen.x.launcher.launch-shen)) 13 | (begin (register-function-arity (quote shen.x.launcher.default-handle-result) 1) (define (kl:shen.x.launcher.default-handle-result V4869) (cond ((and (pair? V4869) (and (eq? (quote success) (car V4869)) (null? (cdr V4869)))) (quote shen.x.launcher.done)) ((and (pair? V4869) (and (eq? (quote success) (car V4869)) (and (pair? (cdr V4869)) (null? (cdr (cdr V4869)))))) (kl:shen.prhush (kl:shen.app (car (cdr V4869)) "\n" (quote shen.a)) (kl:stoutput))) ((and (pair? V4869) (and (eq? (quote error) (car V4869)) (and (pair? (cdr V4869)) (null? (cdr (cdr V4869)))))) (kl:shen.prhush (string-append "ERROR: " (kl:shen.app (car (cdr V4869)) "\n" (quote shen.a))) (kl:stoutput))) ((and (pair? V4869) (eq? (quote launch-repl) (car V4869))) (kl:shen.repl)) ((and (pair? V4869) (and (eq? (quote show-help) (car V4869)) (and (pair? (cdr V4869)) (null? (cdr (cdr V4869)))))) (kl:shen.prhush (kl:shen.app (car (cdr V4869)) "\n" (quote shen.a)) (kl:stoutput))) ((and (pair? V4869) (and (eq? (quote unknown-arguments) (car V4869)) (and (pair? (cdr V4869)) (pair? (cdr (cdr V4869)))))) (kl:shen.prhush (string-append "ERROR: Invalid argument: " (kl:shen.app (car (cdr (cdr V4869))) (string-append "\nTry `" (kl:shen.app (car (cdr V4869)) " --help' for more information.\n" (quote shen.a))) (quote shen.a))) (kl:stoutput))) (#t (kl:shen.f_error (quote shen.x.launcher.default-handle-result))))) (export shen.x.launcher.default-handle-result) (quote shen.x.launcher.default-handle-result)) 14 | (begin (register-function-arity (quote shen.x.launcher.main) 1) (define (kl:shen.x.launcher.main V4871) (kl:shen.x.launcher.default-handle-result (kl:shen.x.launcher.launch-shen V4871))) (export shen.x.launcher.main) (quote shen.x.launcher.main)) 15 | -------------------------------------------------------------------------------- /kl/writer.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun pr (V4536 V4537) (trap-error (shen.prh V4536 V4537 0) (lambda E V4536))) 32 | 33 | (defun shen.prh (V4541 V4542 V4543) (shen.prh V4541 V4542 (shen.write-char-and-inc V4541 V4542 V4543))) 34 | 35 | (defun shen.write-char-and-inc (V4547 V4548 V4549) (do (write-byte (string->n (pos V4547 V4549)) V4548) (+ V4549 1))) 36 | 37 | (defun print (V4551) (let String (shen.insert V4551 "~S") (let Print (shen.prhush String (stoutput)) V4551))) 38 | 39 | (defun shen.prhush (V4554 V4555) (if (value *hush*) V4554 (pr V4554 V4555))) 40 | 41 | (defun shen.mkstr (V4558 V4559) (cond ((string? V4558) (shen.mkstr-l (shen.proc-nl V4558) V4559)) (true (shen.mkstr-r (cons shen.proc-nl (cons V4558 ())) V4559)))) 42 | 43 | (defun shen.mkstr-l (V4562 V4563) (cond ((= () V4563) V4562) ((cons? V4563) (shen.mkstr-l (shen.insert-l (hd V4563) V4562) (tl V4563))) (true (shen.f_error shen.mkstr-l)))) 44 | 45 | (defun shen.insert-l (V4568 V4569) (cond ((= "" V4569) "") ((and (shen.+string? V4569) (and (= "~" (pos V4569 0)) (and (shen.+string? (tlstr V4569)) (= "A" (pos (tlstr V4569) 0))))) (cons shen.app (cons V4568 (cons (tlstr (tlstr V4569)) (cons shen.a ()))))) ((and (shen.+string? V4569) (and (= "~" (pos V4569 0)) (and (shen.+string? (tlstr V4569)) (= "R" (pos (tlstr V4569) 0))))) (cons shen.app (cons V4568 (cons (tlstr (tlstr V4569)) (cons shen.r ()))))) ((and (shen.+string? V4569) (and (= "~" (pos V4569 0)) (and (shen.+string? (tlstr V4569)) (= "S" (pos (tlstr V4569) 0))))) (cons shen.app (cons V4568 (cons (tlstr (tlstr V4569)) (cons shen.s ()))))) ((shen.+string? V4569) (shen.factor-cn (cons cn (cons (pos V4569 0) (cons (shen.insert-l V4568 (tlstr V4569)) ()))))) ((and (cons? V4569) (and (= cn (hd V4569)) (and (cons? (tl V4569)) (and (cons? (tl (tl V4569))) (= () (tl (tl (tl V4569)))))))) (cons cn (cons (hd (tl V4569)) (cons (shen.insert-l V4568 (hd (tl (tl V4569)))) ())))) ((and (cons? V4569) (and (= shen.app (hd V4569)) (and (cons? (tl V4569)) (and (cons? (tl (tl V4569))) (and (cons? (tl (tl (tl V4569)))) (= () (tl (tl (tl (tl V4569)))))))))) (cons shen.app (cons (hd (tl V4569)) (cons (shen.insert-l V4568 (hd (tl (tl V4569)))) (tl (tl (tl V4569))))))) (true (shen.f_error shen.insert-l)))) 46 | 47 | (defun shen.factor-cn (V4571) (cond ((and (cons? V4571) (and (= cn (hd V4571)) (and (cons? (tl V4571)) (and (cons? (tl (tl V4571))) (and (cons? (hd (tl (tl V4571)))) (and (= cn (hd (hd (tl (tl V4571))))) (and (cons? (tl (hd (tl (tl V4571))))) (and (cons? (tl (tl (hd (tl (tl V4571)))))) (and (= () (tl (tl (tl (hd (tl (tl V4571))))))) (and (= () (tl (tl (tl V4571)))) (and (string? (hd (tl V4571))) (string? (hd (tl (hd (tl (tl V4571))))))))))))))))) (cons cn (cons (cn (hd (tl V4571)) (hd (tl (hd (tl (tl V4571)))))) (tl (tl (hd (tl (tl V4571)))))))) (true V4571))) 48 | 49 | (defun shen.proc-nl (V4573) (cond ((= "" V4573) "") ((and (shen.+string? V4573) (and (= "~" (pos V4573 0)) (and (shen.+string? (tlstr V4573)) (= "%" (pos (tlstr V4573) 0))))) (cn (n->string 10) (shen.proc-nl (tlstr (tlstr V4573))))) ((shen.+string? V4573) (cn (pos V4573 0) (shen.proc-nl (tlstr V4573)))) (true (shen.f_error shen.proc-nl)))) 50 | 51 | (defun shen.mkstr-r (V4576 V4577) (cond ((= () V4577) V4576) ((cons? V4577) (shen.mkstr-r (cons shen.insert (cons (hd V4577) (cons V4576 ()))) (tl V4577))) (true (shen.f_error shen.mkstr-r)))) 52 | 53 | (defun shen.insert (V4580 V4581) (shen.insert-h V4580 V4581 "")) 54 | 55 | (defun shen.insert-h (V4587 V4588 V4589) (cond ((= "" V4588) V4589) ((and (shen.+string? V4588) (and (= "~" (pos V4588 0)) (and (shen.+string? (tlstr V4588)) (= "A" (pos (tlstr V4588) 0))))) (cn V4589 (shen.app V4587 (tlstr (tlstr V4588)) shen.a))) ((and (shen.+string? V4588) (and (= "~" (pos V4588 0)) (and (shen.+string? (tlstr V4588)) (= "R" (pos (tlstr V4588) 0))))) (cn V4589 (shen.app V4587 (tlstr (tlstr V4588)) shen.r))) ((and (shen.+string? V4588) (and (= "~" (pos V4588 0)) (and (shen.+string? (tlstr V4588)) (= "S" (pos (tlstr V4588) 0))))) (cn V4589 (shen.app V4587 (tlstr (tlstr V4588)) shen.s))) ((shen.+string? V4588) (shen.insert-h V4587 (tlstr V4588) (cn V4589 (pos V4588 0)))) (true (shen.f_error shen.insert-h)))) 56 | 57 | (defun shen.app (V4593 V4594 V4595) (cn (shen.arg->str V4593 V4595) V4594)) 58 | 59 | (defun shen.arg->str (V4603 V4604) (cond ((= V4603 (fail)) "...") ((shen.list? V4603) (shen.list->str V4603 V4604)) ((string? V4603) (shen.str->str V4603 V4604)) ((absvector? V4603) (shen.vector->str V4603 V4604)) (true (shen.atom->str V4603)))) 60 | 61 | (defun shen.list->str (V4607 V4608) (cond ((= shen.r V4608) (@s "(" (@s (shen.iter-list V4607 shen.r (shen.maxseq)) ")"))) (true (@s "[" (@s (shen.iter-list V4607 V4608 (shen.maxseq)) "]"))))) 62 | 63 | (defun shen.maxseq () (value *maximum-print-sequence-size*)) 64 | 65 | (defun shen.iter-list (V4622 V4623 V4624) (cond ((= () V4622) "") ((= 0 V4624) "... etc") ((and (cons? V4622) (= () (tl V4622))) (shen.arg->str (hd V4622) V4623)) ((cons? V4622) (@s (shen.arg->str (hd V4622) V4623) (@s " " (shen.iter-list (tl V4622) V4623 (- V4624 1))))) (true (@s "|" (@s " " (shen.arg->str V4622 V4623)))))) 66 | 67 | (defun shen.str->str (V4631 V4632) (cond ((= shen.a V4632) V4631) (true (@s (n->string 34) (@s V4631 (n->string 34)))))) 68 | 69 | (defun shen.vector->str (V4635 V4636) (if (shen.print-vector? V4635) ((function (<-address V4635 0)) V4635) (if (vector? V4635) (@s "<" (@s (shen.iter-vector V4635 1 V4636 (shen.maxseq)) ">")) (@s "<" (@s "<" (@s (shen.iter-vector V4635 0 V4636 (shen.maxseq)) ">>")))))) 70 | 71 | (defun shen.empty-absvector? (V4638) (= V4638 (value shen.*empty-absvector*))) 72 | 73 | (defun shen.print-vector? (V4640) (and (not (shen.empty-absvector? V4640)) (let First (<-address V4640 0) (or (= First shen.tuple) (or (= First shen.pvar) (or (= First shen.dictionary) (and (not (number? First)) (shen.fbound? First)))))))) 74 | 75 | (defun shen.fbound? (V4642) (trap-error (do (shen.lookup-func V4642) true) (lambda E false))) 76 | 77 | (defun shen.tuple (V4644) (cn "(@p " (shen.app (<-address V4644 1) (cn " " (shen.app (<-address V4644 2) ")" shen.s)) shen.s))) 78 | 79 | (defun shen.dictionary (V4646) "(dict ...)") 80 | 81 | (defun shen.iter-vector (V4657 V4658 V4659 V4660) (cond ((= 0 V4660) "... etc") (true (let Item (trap-error (<-address V4657 V4658) (lambda E shen.out-of-bounds)) (let Next (trap-error (<-address V4657 (+ V4658 1)) (lambda E shen.out-of-bounds)) (if (= Item shen.out-of-bounds) "" (if (= Next shen.out-of-bounds) (shen.arg->str Item V4659) (@s (shen.arg->str Item V4659) (@s " " (shen.iter-vector V4657 (+ V4658 1) V4659 (- V4660 1))))))))))) 82 | 83 | (defun shen.atom->str (V4662) (trap-error (str V4662) (lambda E (shen.funexstring)))) 84 | 85 | (defun shen.funexstring () (@s "" (@s "f" (@s "u" (@s "n" (@s "e" (@s (shen.arg->str (gensym (intern "x")) shen.a) ""))))))) 86 | 87 | (defun shen.list? (V4664) (or (empty? V4664) (cons? V4664))) 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /kl/toplevel.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun shen.repl () (do (shen.credits) (shen.loop))) 32 | 33 | (defun shen.loop () (do (shen.initialise_environment) (do (shen.prompt) (do (trap-error (shen.read-evaluate-print) (lambda E (shen.toplevel-display-exception E))) (shen.loop))))) 34 | 35 | (defun shen.toplevel-display-exception (V2964) (pr (error-to-string V2964) (stoutput))) 36 | 37 | (defun shen.credits () (do (shen.prhush " 38 | Shen, copyright (C) 2010-2015 Mark Tarver 39 | " (stoutput)) (do (shen.prhush (cn "www.shenlanguage.org, " (shen.app (value *version*) " 40 | " shen.a)) (stoutput)) (do (shen.prhush (cn "running under " (shen.app (value *language*) (cn ", implementation: " (shen.app (value *implementation*) "" shen.a)) shen.a)) (stoutput)) (shen.prhush (cn " 41 | port " (shen.app (value *port*) (cn " ported by " (shen.app (value *porters*) " 42 | " shen.a)) shen.a)) (stoutput)))))) 43 | 44 | (defun shen.initialise_environment () (shen.multiple-set (cons shen.*call* (cons 0 (cons shen.*infs* (cons 0 (cons shen.*process-counter* (cons 0 (cons shen.*catch* (cons 0 ())))))))))) 45 | 46 | (defun shen.multiple-set (V2966) (cond ((= () V2966) ()) ((and (cons? V2966) (cons? (tl V2966))) (do (set (hd V2966) (hd (tl V2966))) (shen.multiple-set (tl (tl V2966))))) (true (shen.f_error shen.multiple-set)))) 47 | 48 | (defun destroy (V2968) (declare V2968 symbol)) 49 | 50 | (defun shen.read-evaluate-print () (let Lineread (shen.toplineread) (let History (value shen.*history*) (let NewLineread (shen.retrieve-from-history-if-needed Lineread History) (let NewHistory (shen.update_history NewLineread History) (let Parsed (fst NewLineread) (shen.toplevel Parsed))))))) 51 | 52 | (defun shen.retrieve-from-history-if-needed (V2980 V2981) (cond ((and (tuple? V2980) (and (cons? (snd V2980)) (element? (hd (snd V2980)) (cons (shen.space) (cons (shen.newline) ()))))) (shen.retrieve-from-history-if-needed (@p (fst V2980) (tl (snd V2980))) V2981)) ((and (tuple? V2980) (and (cons? (snd V2980)) (and (cons? (tl (snd V2980))) (and (= () (tl (tl (snd V2980)))) (and (cons? V2981) (and (= (hd (snd V2980)) (shen.exclamation)) (= (hd (tl (snd V2980))) (shen.exclamation)))))))) (let PastPrint (shen.prbytes (snd (hd V2981))) (hd V2981))) ((and (tuple? V2980) (and (cons? (snd V2980)) (= (hd (snd V2980)) (shen.exclamation)))) (let Key? (shen.make-key (tl (snd V2980)) V2981) (let Find (head (shen.find-past-inputs Key? V2981)) (let PastPrint (shen.prbytes (snd Find)) Find)))) ((and (tuple? V2980) (and (cons? (snd V2980)) (and (= () (tl (snd V2980))) (= (hd (snd V2980)) (shen.percent))))) (do (shen.print-past-inputs (lambda X true) (reverse V2981) 0) (abort))) ((and (tuple? V2980) (and (cons? (snd V2980)) (= (hd (snd V2980)) (shen.percent)))) (let Key? (shen.make-key (tl (snd V2980)) V2981) (let Pastprint (shen.print-past-inputs Key? (reverse V2981) 0) (abort)))) (true V2980))) 53 | 54 | (defun shen.percent () 37) 55 | 56 | (defun shen.exclamation () 33) 57 | 58 | (defun shen.prbytes (V2983) (do (shen.for-each (lambda Byte (pr (n->string Byte) (stoutput))) V2983) (nl 1))) 59 | 60 | (defun shen.update_history (V2986 V2987) (set shen.*history* (cons V2986 V2987))) 61 | 62 | (defun shen.toplineread () (shen.toplineread_loop (shen.read-char-code (stinput)) ())) 63 | 64 | (defun shen.toplineread_loop (V2991 V2992) (cond ((= V2991 (shen.hat)) (simple-error "line read aborted")) ((element? V2991 (cons (shen.newline) (cons (shen.carriage-return) ()))) (let Line (compile (lambda X (shen. X)) V2992 (lambda E shen.nextline)) (let It (shen.record-it V2992) (if (or (= Line shen.nextline) (empty? Line)) (shen.toplineread_loop (shen.read-char-code (stinput)) (append V2992 (cons V2991 ()))) (@p Line V2992))))) (true (shen.toplineread_loop (shen.read-char-code (stinput)) (if (= V2991 -1) V2992 (append V2992 (cons V2991 ()))))))) 65 | 66 | (defun shen.hat () 94) 67 | 68 | (defun shen.newline () 10) 69 | 70 | (defun shen.carriage-return () 13) 71 | 72 | (defun tc (V2998) (cond ((= + V2998) (set shen.*tc* true)) ((= - V2998) (set shen.*tc* false)) (true (simple-error "tc expects a + or -")))) 73 | 74 | (defun shen.prompt () (if (value shen.*tc*) (shen.prhush (cn " 75 | 76 | (" (shen.app (length (value shen.*history*)) "+) " shen.a)) (stoutput)) (shen.prhush (cn " 77 | 78 | (" (shen.app (length (value shen.*history*)) "-) " shen.a)) (stoutput)))) 79 | 80 | (defun shen.toplevel (V3000) (shen.toplevel_evaluate V3000 (value shen.*tc*))) 81 | 82 | (defun shen.find-past-inputs (V3003 V3004) (let F (shen.find V3003 V3004) (if (empty? F) (simple-error "input not found 83 | ") F))) 84 | 85 | (defun shen.make-key (V3007 V3008) (let Atom (hd (compile (lambda X (shen. X)) V3007 (lambda E (if (cons? E) (simple-error (cn "parse error here: " (shen.app E " 86 | " shen.s))) (simple-error "parse error 87 | "))))) (if (integer? Atom) (lambda X (= X (nth (+ Atom 1) (reverse V3008)))) (lambda X (shen.prefix? V3007 (shen.trim-gubbins (snd X))))))) 88 | 89 | (defun shen.trim-gubbins (V3010) (cond ((and (cons? V3010) (= (hd V3010) (shen.space))) (shen.trim-gubbins (tl V3010))) ((and (cons? V3010) (= (hd V3010) (shen.newline))) (shen.trim-gubbins (tl V3010))) ((and (cons? V3010) (= (hd V3010) (shen.carriage-return))) (shen.trim-gubbins (tl V3010))) ((and (cons? V3010) (= (hd V3010) (shen.tab))) (shen.trim-gubbins (tl V3010))) ((and (cons? V3010) (= (hd V3010) (shen.left-round))) (shen.trim-gubbins (tl V3010))) (true V3010))) 90 | 91 | (defun shen.space () 32) 92 | 93 | (defun shen.tab () 9) 94 | 95 | (defun shen.left-round () 40) 96 | 97 | (defun shen.find (V3019 V3020) (cond ((= () V3020) ()) ((and (cons? V3020) (V3019 (hd V3020))) (cons (hd V3020) (shen.find V3019 (tl V3020)))) ((cons? V3020) (shen.find V3019 (tl V3020))) (true (shen.f_error shen.find)))) 98 | 99 | (defun shen.prefix? (V3034 V3035) (cond ((= () V3034) true) ((and (cons? V3034) (and (cons? V3035) (= (hd V3035) (hd V3034)))) (shen.prefix? (tl V3034) (tl V3035))) (true false))) 100 | 101 | (defun shen.print-past-inputs (V3047 V3048 V3049) (cond ((= () V3048) _) ((and (cons? V3048) (not (V3047 (hd V3048)))) (shen.print-past-inputs V3047 (tl V3048) (+ V3049 1))) ((and (cons? V3048) (tuple? (hd V3048))) (do (shen.prhush (shen.app V3049 ". " shen.a) (stoutput)) (do (shen.prbytes (snd (hd V3048))) (shen.print-past-inputs V3047 (tl V3048) (+ V3049 1))))) (true (shen.f_error shen.print-past-inputs)))) 102 | 103 | (defun shen.toplevel_evaluate (V3052 V3053) (cond ((and (cons? V3052) (and (cons? (tl V3052)) (and (= : (hd (tl V3052))) (and (cons? (tl (tl V3052))) (and (= () (tl (tl (tl V3052)))) (= true V3053)))))) (shen.typecheck-and-evaluate (hd V3052) (hd (tl (tl V3052))))) ((and (cons? V3052) (cons? (tl V3052))) (do (shen.toplevel_evaluate (cons (hd V3052) ()) V3053) (do (nl 1) (shen.toplevel_evaluate (tl V3052) V3053)))) ((and (cons? V3052) (and (= () (tl V3052)) (= true V3053))) (shen.typecheck-and-evaluate (hd V3052) (gensym A))) ((and (cons? V3052) (and (= () (tl V3052)) (= false V3053))) (let Eval (shen.eval-without-macros (hd V3052)) (print Eval))) (true (shen.f_error shen.toplevel_evaluate)))) 104 | 105 | (defun shen.typecheck-and-evaluate (V3056 V3057) (let Typecheck (shen.typecheck V3056 V3057) (if (= Typecheck false) (simple-error "type error 106 | ") (let Eval (shen.eval-without-macros V3056) (let Type (shen.pretty-type Typecheck) (shen.prhush (shen.app Eval (cn " : " (shen.app Type "" shen.r)) shen.s) (stoutput))))))) 107 | 108 | (defun shen.pretty-type (V3059) (shen.mult_subst (value shen.*alphabet*) (shen.extract-pvars V3059) V3059)) 109 | 110 | (defun shen.extract-pvars (V3065) (cond ((shen.pvar? V3065) (cons V3065 ())) ((cons? V3065) (union (shen.extract-pvars (hd V3065)) (shen.extract-pvars (tl V3065)))) (true ()))) 111 | 112 | (defun shen.mult_subst (V3073 V3074 V3075) (cond ((= () V3073) V3075) ((= () V3074) V3075) ((and (cons? V3073) (cons? V3074)) (shen.mult_subst (tl V3073) (tl V3074) (subst (hd V3073) (hd V3074) V3075))) (true (shen.f_error shen.mult_subst)))) 113 | 114 | 115 | 116 | -------------------------------------------------------------------------------- /compiled/track.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/track.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote shen.f_error) 1) (define (kl:shen.f_error V3077) (begin (kl:shen.prhush (string-append "partial function " (kl:shen.app V3077 ";\n" (quote shen.a))) (kl:stoutput)) (begin (if (and (kl:not (kl:shen.tracked? V3077)) (assert-boolean (kl:y-or-n? (string-append "track " (kl:shen.app V3077 "? " (quote shen.a)))))) (kl:shen.track-function (kl:ps V3077)) (quote shen.ok)) (simple-error "aborted")))) (export shen.f_error) (quote shen.f_error)) 4 | (begin (register-function-arity (quote shen.tracked?) 1) (define (kl:shen.tracked? V3079) (kl:element? V3079 (kl:value (quote shen.*tracking*)))) (export shen.tracked?) (quote shen.tracked?)) 5 | (begin (register-function-arity (quote track) 1) (define (kl:track V3081) (let ((Source (kl:ps V3081))) (kl:shen.track-function Source))) (export track) (quote track)) 6 | (begin (register-function-arity (quote shen.track-function) 1) (define (kl:shen.track-function V3083) (cond ((and (pair? V3083) (and (eq? (quote defun) (car V3083)) (and (pair? (cdr V3083)) (and (pair? (cdr (cdr V3083))) (and (pair? (cdr (cdr (cdr V3083)))) (null? (cdr (cdr (cdr (cdr V3083)))))))))) (let ((KL (cons (quote defun) (cons (car (cdr V3083)) (cons (car (cdr (cdr V3083))) (cons (kl:shen.insert-tracking-code (car (cdr V3083)) (car (cdr (cdr V3083))) (car (cdr (cdr (cdr V3083))))) (quote ()))))))) (let ((Ob (kl:eval-kl KL))) (let ((Tr (kl:set (quote shen.*tracking*) (cons Ob (kl:value (quote shen.*tracking*)))))) Ob)))) (#t (kl:shen.f_error (quote shen.track-function))))) (export shen.track-function) (quote shen.track-function)) 7 | (begin (register-function-arity (quote shen.insert-tracking-code) 3) (define (kl:shen.insert-tracking-code V3087 V3088 V3089) (cons (quote do) (cons (cons (quote set) (cons (quote shen.*call*) (cons (cons (quote +) (cons (cons (quote value) (cons (quote shen.*call*) (quote ()))) (cons 1 (quote ())))) (quote ())))) (cons (cons (quote do) (cons (cons (quote shen.input-track) (cons (cons (quote value) (cons (quote shen.*call*) (quote ()))) (cons V3087 (cons (kl:shen.cons_form V3088) (quote ()))))) (cons (cons (quote do) (cons (cons (quote shen.terpri-or-read-char) (quote ())) (cons (cons (quote let) (cons (quote Result) (cons V3089 (cons (cons (quote do) (cons (cons (quote shen.output-track) (cons (cons (quote value) (cons (quote shen.*call*) (quote ()))) (cons V3087 (cons (quote Result) (quote ()))))) (cons (cons (quote do) (cons (cons (quote set) (cons (quote shen.*call*) (cons (cons (quote -) (cons (cons (quote value) (cons (quote shen.*call*) (quote ()))) (cons 1 (quote ())))) (quote ())))) (cons (cons (quote do) (cons (cons (quote shen.terpri-or-read-char) (quote ())) (cons (quote Result) (quote ())))) (quote ())))) (quote ())))) (quote ()))))) (quote ())))) (quote ())))) (quote ()))))) (export shen.insert-tracking-code) (quote shen.insert-tracking-code)) 8 | (begin (register-function-arity (quote step) 1) (define (kl:step V3095) (cond ((eq? (quote +) V3095) (kl:set (quote shen.*step*) #t)) ((eq? (quote -) V3095) (kl:set (quote shen.*step*) #f)) (#t (simple-error "step expects a + or a -.\n")))) (export step) (quote step)) 9 | (begin (register-function-arity (quote spy) 1) (define (kl:spy V3101) (cond ((eq? (quote +) V3101) (kl:set (quote shen.*spy*) #t)) ((eq? (quote -) V3101) (kl:set (quote shen.*spy*) #f)) (#t (simple-error "spy expects a + or a -.\n")))) (export spy) (quote spy)) 10 | (begin (register-function-arity (quote shen.terpri-or-read-char) 0) (define (kl:shen.terpri-or-read-char) (if (assert-boolean (kl:value (quote shen.*step*))) (kl:shen.check-byte (read-u8 (kl:value (quote *stinput*)))) (kl:nl 1))) (export shen.terpri-or-read-char) (quote shen.terpri-or-read-char)) 11 | (begin (register-function-arity (quote shen.check-byte) 1) (define (kl:shen.check-byte V3107) (cond ((kl:= V3107 (kl:shen.hat)) (simple-error "aborted")) (#t #t))) (export shen.check-byte) (quote shen.check-byte)) 12 | (begin (register-function-arity (quote shen.input-track) 3) (define (kl:shen.input-track V3111 V3112 V3113) (begin (kl:shen.prhush (string-append "\n" (kl:shen.app (kl:shen.spaces V3111) (string-append "<" (kl:shen.app V3111 (string-append "> Inputs to " (kl:shen.app V3112 (string-append " \n" (kl:shen.app (kl:shen.spaces V3111) "" (quote shen.a))) (quote shen.a))) (quote shen.a))) (quote shen.a))) (kl:stoutput)) (kl:shen.recursively-print V3113))) (export shen.input-track) (quote shen.input-track)) 13 | (begin (register-function-arity (quote shen.recursively-print) 1) (define (kl:shen.recursively-print V3115) (cond ((null? V3115) (kl:shen.prhush " ==>" (kl:stoutput))) ((pair? V3115) (begin (kl:print (car V3115)) (begin (kl:shen.prhush ", " (kl:stoutput)) (kl:shen.recursively-print (cdr V3115))))) (#t (kl:shen.f_error (quote shen.recursively-print))))) (export shen.recursively-print) (quote shen.recursively-print)) 14 | (begin (register-function-arity (quote shen.spaces) 1) (define (kl:shen.spaces V3117) (cond ((kl:= 0 V3117) "") (#t (string-append " " (kl:shen.spaces (- V3117 1)))))) (export shen.spaces) (quote shen.spaces)) 15 | (begin (register-function-arity (quote shen.output-track) 3) (define (kl:shen.output-track V3121 V3122 V3123) (kl:shen.prhush (string-append "\n" (kl:shen.app (kl:shen.spaces V3121) (string-append "<" (kl:shen.app V3121 (string-append "> Output from " (kl:shen.app V3122 (string-append " \n" (kl:shen.app (kl:shen.spaces V3121) (string-append "==> " (kl:shen.app V3123 "" (quote shen.s))) (quote shen.a))) (quote shen.a))) (quote shen.a))) (quote shen.a))) (kl:stoutput))) (export shen.output-track) (quote shen.output-track)) 16 | (begin (register-function-arity (quote untrack) 1) (define (kl:untrack V3125) (let ((Tracking (kl:value (quote shen.*tracking*)))) (let ((Tracking (kl:set (quote shen.*tracking*) (kl:remove V3125 Tracking)))) (kl:eval (kl:ps V3125))))) (export untrack) (quote untrack)) 17 | (begin (register-function-arity (quote profile) 1) (define (kl:profile V3127) (kl:shen.profile-help (kl:ps V3127))) (export profile) (quote profile)) 18 | (begin (register-function-arity (quote shen.profile-help) 1) (define (kl:shen.profile-help V3133) (cond ((and (pair? V3133) (and (eq? (quote defun) (car V3133)) (and (pair? (cdr V3133)) (and (pair? (cdr (cdr V3133))) (and (pair? (cdr (cdr (cdr V3133)))) (null? (cdr (cdr (cdr (cdr V3133)))))))))) (let ((G (kl:gensym (quote shen.f)))) (let ((Profile (cons (quote defun) (cons (car (cdr V3133)) (cons (car (cdr (cdr V3133))) (cons (kl:shen.profile-func (car (cdr V3133)) (car (cdr (cdr V3133))) (cons G (car (cdr (cdr V3133))))) (quote ()))))))) (let ((Def (cons (quote defun) (cons G (cons (car (cdr (cdr V3133))) (cons (kl:subst G (car (cdr V3133)) (car (cdr (cdr (cdr V3133))))) (quote ()))))))) (let ((CompileProfile (kl:shen.eval-without-macros Profile))) (let ((CompileG (kl:shen.eval-without-macros Def))) (car (cdr V3133)))))))) (#t (simple-error "Cannot profile.\n")))) (export shen.profile-help) (quote shen.profile-help)) 19 | (begin (register-function-arity (quote unprofile) 1) (define (kl:unprofile V3135) (kl:untrack V3135)) (export unprofile) (quote unprofile)) 20 | (begin (register-function-arity (quote shen.profile-func) 3) (define (kl:shen.profile-func V3139 V3140 V3141) (cons (quote let) (cons (quote Start) (cons (cons (quote get-time) (cons (quote run) (quote ()))) (cons (cons (quote let) (cons (quote Result) (cons V3141 (cons (cons (quote let) (cons (quote Finish) (cons (cons (quote -) (cons (cons (quote get-time) (cons (quote run) (quote ()))) (cons (quote Start) (quote ())))) (cons (cons (quote let) (cons (quote Record) (cons (cons (quote shen.put-profile) (cons V3139 (cons (cons (quote +) (cons (cons (quote shen.get-profile) (cons V3139 (quote ()))) (cons (quote Finish) (quote ())))) (quote ())))) (cons (quote Result) (quote ()))))) (quote ()))))) (quote ()))))) (quote ())))))) (export shen.profile-func) (quote shen.profile-func)) 21 | (begin (register-function-arity (quote profile-results) 1) (define (kl:profile-results V3143) (let ((Results (kl:shen.get-profile V3143))) (let ((Initialise (kl:shen.put-profile V3143 0))) (kl:_waspvm_at_p V3143 Results)))) (export profile-results) (quote profile-results)) 22 | (begin (register-function-arity (quote shen.get-profile) 1) (define (kl:shen.get-profile V3145) (guard (lambda (E) 0) (kl:get V3145 (quote profile) (kl:value (quote *property-vector*))))) (export shen.get-profile) (quote shen.get-profile)) 23 | (begin (register-function-arity (quote shen.put-profile) 2) (define (kl:shen.put-profile V3148 V3149) (kl:put V3148 (quote profile) V3149 (kl:value (quote *property-vector*)))) (export shen.put-profile) (quote shen.put-profile)) 24 | -------------------------------------------------------------------------------- /kl/yacc.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun shen.yacc (V4666) (cond ((and (cons? V4666) (and (= defcc (hd V4666)) (cons? (tl V4666)))) (shen.yacc->shen (hd (tl V4666)) (tl (tl V4666)))) (true (shen.f_error shen.yacc)))) 32 | 33 | (defun shen.yacc->shen (V4669 V4670) (let CCRules (shen.split_cc_rules true V4670 ()) (let CCBody (map (lambda X (shen.cc_body X)) CCRules) (let YaccCases (shen.yacc_cases CCBody) (cons define (cons V4669 (cons Stream (cons -> (cons (shen.kill-code YaccCases) ()))))))))) 34 | 35 | (defun shen.kill-code (V4672) (cond ((> (occurrences kill V4672) 0) (cons trap-error (cons V4672 (cons (cons lambda (cons E (cons (cons shen.analyse-kill (cons E ())) ()))) ())))) (true V4672))) 36 | 37 | (defun kill () (simple-error "yacc kill")) 38 | 39 | (defun shen.analyse-kill (V4674) (let String (error-to-string V4674) (if (= String "yacc kill") (fail) V4674))) 40 | 41 | (defun shen.split_cc_rules (V4680 V4681 V4682) (cond ((and (= () V4681) (= () V4682)) ()) ((= () V4681) (cons (shen.split_cc_rule V4680 (reverse V4682) ()) ())) ((and (cons? V4681) (= ; (hd V4681))) (cons (shen.split_cc_rule V4680 (reverse V4682) ()) (shen.split_cc_rules V4680 (tl V4681) ()))) ((cons? V4681) (shen.split_cc_rules V4680 (tl V4681) (cons (hd V4681) V4682))) (true (shen.f_error shen.split_cc_rules)))) 42 | 43 | (defun shen.split_cc_rule (V4690 V4691 V4692) (cond ((and (cons? V4691) (and (= := (hd V4691)) (and (cons? (tl V4691)) (= () (tl (tl V4691)))))) (cons (reverse V4692) (tl V4691))) ((and (cons? V4691) (and (= := (hd V4691)) (and (cons? (tl V4691)) (and (cons? (tl (tl V4691))) (and (= where (hd (tl (tl V4691)))) (and (cons? (tl (tl (tl V4691)))) (= () (tl (tl (tl (tl V4691))))))))))) (cons (reverse V4692) (cons (cons where (cons (hd (tl (tl (tl V4691)))) (cons (hd (tl V4691)) ()))) ()))) ((= () V4691) (do (shen.semantic-completion-warning V4690 V4692) (shen.split_cc_rule V4690 (cons := (cons (shen.default_semantics (reverse V4692)) ())) V4692))) ((cons? V4691) (shen.split_cc_rule V4690 (tl V4691) (cons (hd V4691) V4692))) (true (shen.f_error shen.split_cc_rule)))) 44 | 45 | (defun shen.semantic-completion-warning (V4703 V4704) (cond ((= true V4703) (do (shen.prhush "warning: " (stoutput)) (do (shen.for-each (lambda X (shen.prhush (shen.app X " " shen.a) (stoutput))) (reverse V4704)) (shen.prhush "has no semantics. 46 | " (stoutput))))) (true shen.skip))) 47 | 48 | (defun shen.default_semantics (V4706) (cond ((= () V4706) ()) ((and (cons? V4706) (and (= () (tl V4706)) (shen.grammar_symbol? (hd V4706)))) (hd V4706)) ((and (cons? V4706) (shen.grammar_symbol? (hd V4706))) (cons append (cons (hd V4706) (cons (shen.default_semantics (tl V4706)) ())))) ((cons? V4706) (cons cons (cons (hd V4706) (cons (shen.default_semantics (tl V4706)) ())))) (true (shen.f_error shen.default_semantics)))) 49 | 50 | (defun shen.grammar_symbol? (V4708) (and (symbol? V4708) (let Cs (shen.strip-pathname (explode V4708)) (and (= (hd Cs) "<") (= (hd (reverse Cs)) ">"))))) 51 | 52 | (defun shen.yacc_cases (V4710) (cond ((and (cons? V4710) (= () (tl V4710))) (hd V4710)) ((cons? V4710) (let P YaccParse (cons let (cons P (cons (hd V4710) (cons (cons if (cons (cons = (cons P (cons (cons fail ()) ()))) (cons (shen.yacc_cases (tl V4710)) (cons P ())))) ())))))) (true (shen.f_error shen.yacc_cases)))) 53 | 54 | (defun shen.cc_body (V4712) (cond ((and (cons? V4712) (and (cons? (tl V4712)) (= () (tl (tl V4712))))) (shen.syntax (hd V4712) Stream (hd (tl V4712)))) (true (shen.f_error shen.cc_body)))) 55 | 56 | (defun shen.syntax (V4716 V4717 V4718) (cond ((and (= () V4716) (and (cons? V4718) (and (= where (hd V4718)) (and (cons? (tl V4718)) (and (cons? (tl (tl V4718))) (= () (tl (tl (tl V4718))))))))) (cons if (cons (shen.semantics (hd (tl V4718))) (cons (cons shen.pair (cons (cons hd (cons V4717 ())) (cons (shen.semantics (hd (tl (tl V4718)))) ()))) (cons (cons fail ()) ()))))) ((= () V4716) (cons shen.pair (cons (cons hd (cons V4717 ())) (cons (shen.semantics V4718) ())))) ((cons? V4716) (if (shen.grammar_symbol? (hd V4716)) (shen.recursive_descent V4716 V4717 V4718) (if (variable? (hd V4716)) (shen.variable-match V4716 V4717 V4718) (if (shen.jump_stream? (hd V4716)) (shen.jump_stream V4716 V4717 V4718) (if (shen.terminal? (hd V4716)) (shen.check_stream V4716 V4717 V4718) (if (cons? (hd V4716)) (shen.list-stream (shen.decons (hd V4716)) (tl V4716) V4717 V4718) (simple-error (shen.app (hd V4716) " is not legal syntax 57 | " shen.a)))))))) (true (shen.f_error shen.syntax)))) 58 | 59 | (defun shen.list-stream (V4723 V4724 V4725 V4726) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V4725 ())) ())) (cons (cons cons? (cons (cons shen.hdhd (cons V4725 ())) ())) ()))) (let Placeholder (gensym shen.place) (let RunOn (shen.syntax V4724 (cons shen.pair (cons (cons shen.tlhd (cons V4725 ())) (cons (cons shen.hdtl (cons V4725 ())) ()))) V4726) (let Action (shen.insert-runon RunOn Placeholder (shen.syntax V4723 (cons shen.pair (cons (cons shen.hdhd (cons V4725 ())) (cons (cons shen.hdtl (cons V4725 ())) ()))) Placeholder)) (cons if (cons Test (cons Action (cons (cons fail ()) ()))))))))) 60 | 61 | (defun shen.decons (V4728) (cond ((and (cons? V4728) (and (= cons (hd V4728)) (and (cons? (tl V4728)) (and (cons? (tl (tl V4728))) (and (= () (hd (tl (tl V4728)))) (= () (tl (tl (tl V4728))))))))) (cons (hd (tl V4728)) ())) ((and (cons? V4728) (and (= cons (hd V4728)) (and (cons? (tl V4728)) (and (cons? (tl (tl V4728))) (= () (tl (tl (tl V4728)))))))) (cons (hd (tl V4728)) (shen.decons (hd (tl (tl V4728)))))) (true V4728))) 62 | 63 | (defun shen.insert-runon (V4743 V4744 V4745) (cond ((and (cons? V4745) (and (= shen.pair (hd V4745)) (and (cons? (tl V4745)) (and (cons? (tl (tl V4745))) (and (= () (tl (tl (tl V4745)))) (= (hd (tl (tl V4745))) V4744)))))) V4743) ((cons? V4745) (map (lambda Z (shen.insert-runon V4743 V4744 Z)) V4745)) (true V4745))) 64 | 65 | (defun shen.strip-pathname (V4751) (cond ((not (element? "." V4751)) V4751) ((cons? V4751) (shen.strip-pathname (tl V4751))) (true (shen.f_error shen.strip-pathname)))) 66 | 67 | (defun shen.recursive_descent (V4755 V4756 V4757) (cond ((cons? V4755) (let Test (cons (hd V4755) (cons V4756 ())) (let Action (shen.syntax (tl V4755) (concat Parse_ (hd V4755)) V4757) (let Else (cons fail ()) (cons let (cons (concat Parse_ (hd V4755)) (cons Test (cons (cons if (cons (cons not (cons (cons = (cons (cons fail ()) (cons (concat Parse_ (hd V4755)) ()))) ())) (cons Action (cons Else ())))) ())))))))) (true (shen.f_error shen.recursive_descent)))) 68 | 69 | (defun shen.variable-match (V4761 V4762 V4763) (cond ((cons? V4761) (let Test (cons cons? (cons (cons hd (cons V4762 ())) ())) (let Action (cons let (cons (concat Parse_ (hd V4761)) (cons (cons shen.hdhd (cons V4762 ())) (cons (shen.syntax (tl V4761) (cons shen.pair (cons (cons shen.tlhd (cons V4762 ())) (cons (cons shen.hdtl (cons V4762 ())) ()))) V4763) ())))) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.f_error shen.variable-match)))) 70 | 71 | (defun shen.terminal? (V4773) (cond ((cons? V4773) false) ((variable? V4773) false) (true true))) 72 | 73 | (defun shen.jump_stream? (V4779) (cond ((= V4779 _) true) (true false))) 74 | 75 | (defun shen.check_stream (V4783 V4784 V4785) (cond ((cons? V4783) (let Test (cons and (cons (cons cons? (cons (cons hd (cons V4784 ())) ())) (cons (cons = (cons (hd V4783) (cons (cons shen.hdhd (cons V4784 ())) ()))) ()))) (let NewStr (gensym NewStream) (let Action (cons let (cons NewStr (cons (cons shen.pair (cons (cons shen.tlhd (cons V4784 ())) (cons (cons shen.hdtl (cons V4784 ())) ()))) (cons (shen.syntax (tl V4783) NewStr V4785) ())))) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ()))))))))) (true (shen.f_error shen.check_stream)))) 76 | 77 | (defun shen.jump_stream (V4789 V4790 V4791) (cond ((cons? V4789) (let Test (cons cons? (cons (cons hd (cons V4790 ())) ())) (let Action (shen.syntax (tl V4789) (cons shen.pair (cons (cons shen.tlhd (cons V4790 ())) (cons (cons shen.hdtl (cons V4790 ())) ()))) V4791) (let Else (cons fail ()) (cons if (cons Test (cons Action (cons Else ())))))))) (true (shen.f_error shen.jump_stream)))) 78 | 79 | (defun shen.semantics (V4793) (cond ((= () V4793) ()) ((shen.grammar_symbol? V4793) (cons shen.hdtl (cons (concat Parse_ V4793) ()))) ((variable? V4793) (concat Parse_ V4793)) ((cons? V4793) (map (lambda Z (shen.semantics Z)) V4793)) (true V4793))) 80 | 81 | (defun shen.pair (V4796 V4797) (cons V4796 (cons V4797 ()))) 82 | 83 | (defun shen.hdtl (V4799) (hd (tl V4799))) 84 | 85 | (defun shen.hdhd (V4801) (hd (hd V4801))) 86 | 87 | (defun shen.tlhd (V4803) (tl (hd V4803))) 88 | 89 | (defun shen.snd-or-fail (V4811) (cond ((and (cons? V4811) (and (cons? (tl V4811)) (= () (tl (tl V4811))))) (hd (tl V4811))) (true (fail)))) 90 | 91 | (defun fail () shen.fail!)(defun (V4819) (cond ((and (cons? V4819) (and (cons? (tl V4819)) (= () (tl (tl V4819))))) (cons () (cons (hd V4819) ()))) (true (fail)))) 92 | 93 | (defun (V4825) (cond ((and (cons? V4825) (and (cons? (tl V4825)) (= () (tl (tl V4825))))) (cons (hd V4825) (cons () ()))) (true (shen.f_error )))) 94 | 95 | 96 | 97 | -------------------------------------------------------------------------------- /compiler.ms: -------------------------------------------------------------------------------- 1 | ; Copyright (c) 2017 Chris Double. All rights reserved. 2 | ; BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause 3 | ; 4 | ; Shen Scheme derived soure code is: 5 | ; Copyright (c) 2012-2015 Bruno Deferrari. All rights reserved. 6 | 7 | (define (unbound-symbol? maybe-sym scope) 8 | (and (symbol? maybe-sym) 9 | (not (memq maybe-sym scope)))) 10 | 11 | (define *gensym-counter* 0) 12 | 13 | (define (gensym prefix) 14 | (set! *gensym-counter* (+ 1 *gensym-counter*)) 15 | (string->symbol (string-append prefix (number->string *gensym-counter*)))) 16 | 17 | (define *yields-boolean* 18 | `(or and 19 | kl:= 20 | null? string? vector? number? pair? 21 | < > >= <= = eq? equal? 22 | kl:element? kl:symbol? kl:not kl:variable? kl:boolean? 23 | kl:empty? kl:shen.pvar? kl:tuple?)) 24 | 25 | (define (yields-boolean? expr) 26 | (cond 27 | ((boolean? expr) #t) 28 | ((pair? expr) 29 | (or (memq (car expr) *yields-boolean*) 30 | (and (eq? 'l2r (car expr)) 31 | (yields-boolean? (car (cdr expr)))))) 32 | (else #f))) 33 | 34 | (define (force-boolean expr) 35 | (if (yields-boolean? expr) 36 | expr 37 | `(assert-boolean ,expr))) 38 | 39 | (define (compile-expression expr scope) 40 | (define (unbound? maybe-sym) 41 | (unbound-symbol? maybe-sym scope)) 42 | 43 | (define (ce expr . extra-scope) 44 | (compile-expression expr (append extra-scope scope))) 45 | 46 | (cond 47 | ((null? expr) '(quote ())) 48 | ((unbound? expr) (if (and (symbol? expr) (equal? expr (string->symbol ","))) `(string->symbol ,(symbol->string expr)) `(quote ,expr))) 49 | ((and (pair? expr) (= (length expr) 4) (eq? (car expr) 'let)) 50 | (define var (list-ref expr 1)) 51 | (define value (list-ref expr 2)) 52 | (define body (list-ref expr 3)) 53 | (emit-let var value body (cons var scope))) 54 | ((and (pair? expr) 55 | (> (length expr) 1) 56 | (eq? (car expr) 'cond)) 57 | (emit-cond (cdr expr) scope)) 58 | ((and (pair? expr) 59 | (= (length expr) 3) 60 | (eq? (car expr) 'lambda)) 61 | (define var (list-ref expr 1)) 62 | (define body (list-ref expr 2)) 63 | `(lambda (,var) ,(ce body var))) 64 | ((and (pair? expr) 65 | (= (length expr) 3) 66 | (eq? (car expr) 'and)) 67 | (define expr1 (list-ref expr 1)) 68 | (define expr2 (list-ref expr 2)) 69 | `(and ,(force-boolean (ce expr1)) 70 | ,(force-boolean (ce expr2)))) 71 | ((and (pair? expr) 72 | (= (length expr) 3) 73 | (eq? (car expr) 'or)) 74 | (define expr1 (list-ref expr 1)) 75 | (define expr2 (list-ref expr 2)) 76 | `(or ,(force-boolean (ce expr1)) 77 | ,(force-boolean (ce expr2)))) 78 | ((and (list? expr) 79 | (= (length expr) 4) 80 | (eq? (car expr) 'if)) 81 | (define test (list-ref expr 1)) 82 | (define then (list-ref expr 2)) 83 | (define else (list-ref expr 3)) 84 | `(if ,(force-boolean (ce test)) 85 | ,(ce then) 86 | ,(ce else))) 87 | ((and (list? expr) 88 | (eq? (car expr) 'trap-error) 89 | (= (length expr) 3) 90 | (list? (list-ref expr 2)) 91 | (eq? (car (list-ref expr 2)) 'lambda)) 92 | (define expression (list-ref expr 1)) 93 | (define fun (list-ref expr 2)) 94 | (define args (list-ref fun 1)) 95 | (define body (list-ref fun 2)) 96 | `(guard (lambda (,args) ,(ce body args)) 97 | ,(ce expression))) 98 | ((and (list? expr) 99 | (eq? (car expr) 'trap-error) 100 | (= (length expr) 3)) 101 | (define expression (list-ref expr 1)) 102 | (define handler (list-ref expr 2)) 103 | `(guard (lambda (e) (,(ce handler) e)) 104 | ,(ce expression))) 105 | ((and (list? expr) 106 | (eq? (car expr) 'do) 107 | (= (length expr) 3)) 108 | (define expr1 (list-ref expr 1)) 109 | (define expr2 (list-ref expr 2)) 110 | `(begin ,(ce expr1) ,(ce expr2))) 111 | ((and (list? expr) 112 | (eq? (car expr) 'freeze) 113 | (= (length expr) 2)) 114 | (define expr1 (list-ref expr 1)) 115 | `(lambda () ,(ce expr1))) 116 | ((equal? expr '(fail)) '(quote shen.fail!)) 117 | ((and (pair? expr) 118 | (eq? (car expr) 'type) 119 | (= (length expr) 3)) 120 | (define x (list-ref expr 1)) 121 | (define type (list-ref expr 2)) 122 | (ce x)) 123 | ((and (list? expr) 124 | (eq? (car expr) 'wasp.) 125 | (= (length expr) 2)) 126 | (car (string->exprs (cadr expr)))) 127 | ((and (list? expr) 128 | (eq? (car expr) '=) 129 | (= (length expr) 3)) 130 | (define v1 (list-ref expr 1)) 131 | (define v2 (list-ref expr 2)) 132 | (emit-equality-check v1 v2 scope)) 133 | ((and (list? expr) 134 | (eq? (car expr) '/) 135 | (= (length expr) 3)) 136 | (define a (list-ref expr 1)) 137 | (define b (list-ref expr 2)) 138 | `(/ ,(ce a) ,(ce b))) 139 | ((and (list? expr) 140 | (eq? (car expr) 'pos) 141 | (= (length expr) 3)) 142 | (define str (list-ref expr 1)) 143 | (define n (list-ref expr 2)) 144 | `(make-string 1 (string-ref ,(ce str) ,(ce n)))) 145 | ((and (list? expr) 146 | (eq? (car expr) 'tlstr) 147 | (= (length expr) 2)) 148 | (define str (list-ref expr 1)) 149 | `(string-tail ,(ce str) 1)) 150 | ((and (list? expr) 151 | (eq? (car expr) 'cn) 152 | (= (length expr) 3)) 153 | (define str1 (list-ref expr 1)) 154 | (define str2 (list-ref expr 2)) 155 | `(string-append ,(ce str1) ,(ce str2))) 156 | ((and (list? expr) 157 | (eq? (car expr) 'n->string) 158 | (= (length expr) 2)) 159 | (define n (list-ref expr 1)) 160 | `(make-string 1 ,(ce n))) 161 | ((and (list? expr) 162 | (eq? (car expr) 'string->n) 163 | (= (length expr) 2)) 164 | (define str (list-ref expr 1)) 165 | `(string-ref ,(ce str) 0)) 166 | ((and (list? expr) 167 | (eq? (car expr) 'absvector) 168 | (= (length expr) 2)) 169 | (let ((n (list-ref expr 1))) 170 | `(make-vector ,(ce n) '(quote shen.fail!)))) 171 | ((and (list? expr) 172 | (eq? (car expr) '<-address) 173 | (= (length expr) 3)) 174 | (define v (list-ref expr 1)) 175 | (define n (list-ref expr 2)) 176 | `(vector-ref ,(ce v) ,(ce n))) 177 | ((and (list? expr) 178 | (eq? (car expr) 'address->) 179 | (= (length expr) 4)) 180 | (define v (list-ref expr 1)) 181 | (define n (list-ref expr 2)) 182 | (define x (list-ref expr 3)) 183 | `(let ((_tmp ,(ce v))) 184 | (vector-set! _tmp ,(ce n) ,(ce x)) 185 | _tmp)) 186 | ((list? expr) 187 | (emit-application (car expr) (cdr expr) scope)) 188 | (else expr))) 189 | 190 | (define (emit-let var value body scope) 191 | `(let ((,var ,(compile-expression value scope))) 192 | ,(compile-expression body (cons var scope)))) 193 | 194 | (define (emit-cond clauses scope) 195 | `(cond ,@(emit-cond-clauses clauses scope))) 196 | 197 | (define (emit-cond-clauses clauses scope) 198 | (cond 199 | ((null? clauses) '()) 200 | ((and (pair? clauses) 201 | (pair? (car clauses)) 202 | (= (length (car clauses)) 2)) 203 | (define test (car (car clauses))) 204 | (define body (cadr (car clauses))) 205 | (define rest (cdr clauses)) 206 | (let ((compiled-test (compile-expression test scope)) 207 | (compiled-body (compile-expression body scope)) 208 | (compiled-rest (emit-cond-clauses rest scope))) 209 | `((,(force-boolean compiled-test) ,compiled-body) 210 | ,@compiled-rest))))) 211 | 212 | (define (emit-equality-check v1 v2 scope) 213 | (define lhs (compile-expression v1 scope)) 214 | (define rhs (compile-expression v2 scope)) 215 | (cond ((or (unbound-symbol? v1 scope) 216 | (unbound-symbol? v2 scope) 217 | (equal? '(fail) v1) 218 | (equal? '(fail) v2)) 219 | `(eq? ,lhs ,rhs)) 220 | ((and (string? lhs) (string? rhs)) 221 | `(string=? ,lhs ,rhs)) 222 | ((and (vector? lhs) (vector? rhs)) 223 | `(vector=? ,lhs ,rhs)) 224 | ((and (number? lhs) (number? rhs)) 225 | `(= ,lhs ,rhs)) 226 | ((or (string? v1) (string? v2)) 227 | `(equal? ,lhs ,rhs)) 228 | ((null? v1) `(null? ,(compile-expression v2 scope))) 229 | ((null? v2) `(null? ,(compile-expression v1 scope))) 230 | (else `(kl:= ,lhs ,rhs)))) 231 | 232 | (define binary-op-mappings 233 | '((+ . +) 234 | (- . -) 235 | (* . *) 236 | (> . >) 237 | (< . <) 238 | (>= . >=) 239 | (<= . <=) 240 | (cons . cons) 241 | (write-byte . write-u8))) 242 | 243 | (define (simple-error msg) 244 | (error 'shen msg)) 245 | 246 | (define unary-op-mappings 247 | '((number? . number?) 248 | (string? . string?) 249 | (cons? . pair?) 250 | (absvector? . vector?) 251 | (simple-error . simple-error) 252 | (hd . car) 253 | (tl . cdr) 254 | (read-byte . read-u8))) 255 | 256 | (define (binary-op-mapping op) 257 | (let ((res (assq op binary-op-mappings))) 258 | (and res (cdr res)))) 259 | 260 | (define (unary-op-mapping op) 261 | (let ((res (assq op unary-op-mappings))) 262 | (and res (cdr res)))) 263 | 264 | (define (prefix-op op) 265 | (define sop (symbol->string op)) 266 | (define opl (string-length sop)) 267 | (if (and (> opl 5) 268 | (string=? "wasp." (substring sop 0 5))) 269 | (string->symbol (substring sop 5 (- opl 5))) 270 | (string->symbol (string-append "kl:" sop)))) 271 | 272 | (define (emit-application op params scope) 273 | (define arity (function-arity op)) 274 | (define partial-call? (not (or (= arity -1) (= arity (length params))))) 275 | (define args (map (lambda (exp) (compile-expression exp scope)) params)) 276 | (cond ((and (<= arity 0) (null? args)) 277 | (cond ((pair? op) `(,(compile-expression op scope))) 278 | ((unbound-symbol? op scope) `(,(prefix-op op))) 279 | (else `(,op)))) 280 | (partial-call? 281 | (nest-call (nest-lambda op arity '()) args)) 282 | ((or (pair? op) (not (unbound-symbol? op scope))) 283 | (nest-call (compile-expression op scope) args)) 284 | (else 285 | (cond ((and (= arity 2) (binary-op-mapping op)) 286 | (cons (binary-op-mapping op) args)) 287 | ((and (= arity 1) (unary-op-mapping op)) 288 | (cons (unary-op-mapping op) args)) 289 | (else 290 | (let ((op (prefix-op op))) 291 | (cons op args))))))) 292 | 293 | (define (nest-call op args) 294 | (if (null? args) 295 | op 296 | (nest-call (list op (car args)) (cdr args)))) 297 | 298 | (define (nest-lambda callable arity scope) 299 | (define (merge-args f arg) 300 | (if (pair? f) 301 | (append f (list arg)) 302 | (list f arg))) 303 | 304 | (if (<= arity 0) 305 | (compile-expression callable scope) 306 | (let ((aname (gensym "Y"))) 307 | `(lambda (,aname) 308 | ,(nest-lambda (merge-args callable aname) 309 | (- arity 1) 310 | (cons aname scope)))))) 311 | 312 | (define (kl->wasp expr) 313 | (cond 314 | ((and (pair? expr) (eq? (car expr) 'defun)) 315 | (define name (list-ref expr 1)) 316 | (define args (list-ref expr 2)) 317 | (define body (list-ref expr 3)) 318 | `(begin 319 | (register-function-arity (quote ,name) ,(length args)) 320 | (define (,(prefix-op name) ,@args) ,(compile-expression body args)) 321 | (export ,name) 322 | (quote ,name))) 323 | (else (compile-expression expr '())))) 324 | 325 | -------------------------------------------------------------------------------- /kl/extension-factorise-defun.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2012-2019 Bruno Deferrari. All rights reserved. 2 | BSD 3-Clause License: http://opensource.org/licenses/BSD-3-Clause" 3 | 4 | (defun shen.x.factorise-defun.factorise-defun (V4873) (cond ((and (cons? V4873) (and (= defun (hd V4873)) (and (cons? (tl V4873)) (and (cons? (tl (tl V4873))) (and (cons? (tl (tl (tl V4873)))) (and (cons? (hd (tl (tl (tl V4873))))) (and (= cond (hd (hd (tl (tl (tl V4873)))))) (= () (tl (tl (tl (tl V4873)))))))))))) (cons defun (cons (hd (tl V4873)) (cons (hd (tl (tl V4873))) (cons (shen.x.factorise-defun.factorise-cond (hd (tl (tl (tl V4873)))) (cons shen.f_error (cons (hd (tl V4873)) ())) (hd (tl (tl V4873)))) ()))))) (true V4873))) 5 | 6 | (defun shen.x.factorise-defun.factorise-cond (V4885 V4886 V4887) (cond ((and (cons? V4885) (= cond (hd V4885))) (shen.x.factorise-defun.inline-mono-labels (shen.x.factorise-defun.rebranch (shen.x.factorise-defun.add-returns (tl V4885)) V4886) V4887)) (true V4885))) 7 | 8 | (defun shen.x.factorise-defun.add-returns (V4889) (cond ((= () V4889) ()) ((and (cons? V4889) (and (cons? (hd V4889)) (and (cons? (tl (hd V4889))) (= () (tl (tl (hd V4889))))))) (cons (cons (hd (hd V4889)) (cons (cons %%return (tl (hd V4889))) ())) (shen.x.factorise-defun.add-returns (tl V4889)))) (true (shen.f_error shen.x.factorise-defun.add-returns)))) 9 | 10 | (defun shen.x.factorise-defun.generate-label () (gensym %%label)) 11 | 12 | (defun shen.x.factorise-defun.free-variables (V4892 V4893) (reverse (shen.x.factorise-defun.free-variables-h V4892 V4893 ()))) 13 | 14 | (defun shen.x.factorise-defun.free-variables-h (V4905 V4906 V4907) (cond ((and (cons? V4905) (and (= let (hd V4905)) (and (cons? (tl V4905)) (and (cons? (tl (tl V4905))) (and (cons? (tl (tl (tl V4905)))) (= () (tl (tl (tl (tl V4905)))))))))) (shen.x.factorise-defun.free-variables-h (hd (tl (tl (tl V4905)))) (remove (hd (tl V4905)) V4906) (shen.x.factorise-defun.free-variables-h (hd (tl (tl V4905))) V4906 V4907))) ((and (cons? V4905) (and (= lambda (hd V4905)) (and (cons? (tl V4905)) (and (cons? (tl (tl V4905))) (= () (tl (tl (tl V4905)))))))) (shen.x.factorise-defun.free-variables-h (hd (tl (tl V4905))) (remove (hd (tl V4905)) V4906) V4907)) ((cons? V4905) (shen.x.factorise-defun.free-variables-h (tl V4905) V4906 (shen.x.factorise-defun.free-variables-h (hd V4905) V4906 V4907))) ((element? V4905 V4906) (adjoin V4905 V4907)) (true V4907))) 15 | 16 | (defun shen.x.factorise-defun.attach-free-variables (V4910 V4911) (cond ((and (cons? V4910) (and (= %%let-label (hd V4910)) (and (cons? (tl V4910)) (and (cons? (tl (tl V4910))) (and (cons? (tl (tl (tl V4910)))) (= () (tl (tl (tl (tl V4910)))))))))) (let FreeVars (shen.x.factorise-defun.free-variables (hd (tl (tl V4910))) V4911) (let NewBody (if (= () FreeVars) (hd (tl (tl (tl V4910)))) (subst (cons %%goto-label (cons (hd (tl V4910)) FreeVars)) (cons %%goto-label (cons (hd (tl V4910)) ())) (hd (tl (tl (tl V4910)))))) (cons %%let-label (cons (cons (hd (tl V4910)) FreeVars) (cons (hd (tl (tl V4910))) (cons (shen.x.factorise-defun.inline-mono-labels NewBody V4911) ()))))))) (true (shen.f_error shen.x.factorise-defun.attach-free-variables)))) 17 | 18 | (defun shen.x.factorise-defun.inline-mono-labels (V4918 V4919) (cond ((and (cons? V4918) (and (= %%let-label (hd V4918)) (and (cons? (tl V4918)) (and (cons? (tl (tl V4918))) (and (cons? (tl (tl (tl V4918)))) (and (= () (tl (tl (tl (tl V4918))))) (> (occurrences (cons %%goto-label (cons (hd (tl V4918)) ())) (hd (tl (tl (tl V4918))))) 1))))))) (shen.x.factorise-defun.attach-free-variables (cons %%let-label (cons (hd (tl V4918)) (cons (shen.x.factorise-defun.inline-mono-labels (hd (tl (tl V4918))) V4919) (tl (tl (tl V4918)))))) V4919)) ((and (cons? V4918) (and (= %%let-label (hd V4918)) (and (cons? (tl V4918)) (and (cons? (tl (tl V4918))) (and (cons? (tl (tl (tl V4918)))) (= () (tl (tl (tl (tl V4918)))))))))) (subst (shen.x.factorise-defun.inline-mono-labels (hd (tl (tl V4918))) V4919) (cons %%goto-label (cons (hd (tl V4918)) ())) (shen.x.factorise-defun.inline-mono-labels (hd (tl (tl (tl V4918)))) V4919))) ((and (cons? V4918) (and (= if (hd V4918)) (and (cons? (tl V4918)) (and (cons? (tl (tl V4918))) (and (cons? (tl (tl (tl V4918)))) (= () (tl (tl (tl (tl V4918)))))))))) (cons if (cons (hd (tl V4918)) (cons (shen.x.factorise-defun.inline-mono-labels (hd (tl (tl V4918))) V4919) (cons (shen.x.factorise-defun.inline-mono-labels (hd (tl (tl (tl V4918)))) V4919) ()))))) ((and (cons? V4918) (and (= let (hd V4918)) (and (cons? (tl V4918)) (and (cons? (tl (tl V4918))) (and (cons? (tl (tl (tl V4918)))) (= () (tl (tl (tl (tl V4918)))))))))) (cons let (cons (hd (tl V4918)) (cons (hd (tl (tl V4918))) (cons (shen.x.factorise-defun.inline-mono-labels (hd (tl (tl (tl V4918)))) (cons (hd (tl V4918)) V4919)) ()))))) (true V4918))) 19 | 20 | (defun shen.x.factorise-defun.rebranch (V4926 V4927) (cond ((= () V4926) V4927) ((and (cons? V4926) (and (cons? (hd V4926)) (and (= true (hd (hd V4926))) (and (cons? (tl (hd V4926))) (= () (tl (tl (hd V4926)))))))) (hd (tl (hd V4926)))) ((and (cons? V4926) (and (cons? (hd V4926)) (and (cons? (hd (hd V4926))) (and (= and (hd (hd (hd V4926)))) (and (cons? (tl (hd (hd V4926)))) (and (cons? (tl (tl (hd (hd V4926))))) (and (= () (tl (tl (tl (hd (hd V4926)))))) (and (cons? (tl (hd V4926))) (= () (tl (tl (hd V4926)))))))))))) (let TrueBranch (shen.x.factorise-defun.true-branch (hd (tl (hd (hd V4926)))) V4926) (let FalseBranch (shen.x.factorise-defun.false-branch (hd (tl (hd (hd V4926)))) V4926) (shen.x.factorise-defun.rebranch-h (hd (tl (hd (hd V4926)))) TrueBranch FalseBranch V4927)))) ((and (cons? V4926) (and (cons? (hd V4926)) (and (cons? (tl (hd V4926))) (= () (tl (tl (hd V4926))))))) (let TrueBranch (shen.x.factorise-defun.true-branch (hd (hd V4926)) V4926) (let FalseBranch (shen.x.factorise-defun.false-branch (hd (hd V4926)) V4926) (shen.x.factorise-defun.rebranch-h (hd (hd V4926)) TrueBranch FalseBranch V4927)))) (true (shen.f_error shen.x.factorise-defun.rebranch)))) 21 | 22 | (defun shen.x.factorise-defun.rebranch-h (V4932 V4933 V4934 V4935) (let NewElse (shen.x.factorise-defun.rebranch V4934 V4935) (shen.x.factorise-defun.with-labelled-else NewElse (lambda GotoElse (shen.x.factorise-defun.merge-same-else-ifs (cons if (cons V4932 (cons (shen.x.factorise-defun.optimize-selectors V4932 (shen.x.factorise-defun.rebranch V4933 GotoElse)) (cons GotoElse ()))))))))) 23 | 24 | (defun shen.x.factorise-defun.true-branch (V4948 V4949) (cond ((and (cons? V4949) (and (cons? (hd V4949)) (and (cons? (hd (hd V4949))) (and (= and (hd (hd (hd V4949)))) (and (cons? (tl (hd (hd V4949)))) (and (cons? (tl (tl (hd (hd V4949))))) (and (= () (tl (tl (tl (hd (hd V4949)))))) (and (cons? (tl (hd V4949))) (and (= () (tl (tl (hd V4949)))) (= (hd (tl (hd (hd V4949)))) V4948)))))))))) (cons (cons (hd (tl (tl (hd (hd V4949))))) (tl (hd V4949))) (shen.x.factorise-defun.true-branch (hd (tl (hd (hd V4949)))) (tl V4949)))) ((and (cons? V4949) (and (cons? (hd V4949)) (and (cons? (tl (hd V4949))) (and (= () (tl (tl (hd V4949)))) (= (hd (hd V4949)) V4948))))) (cons (cons true (tl (hd V4949))) ())) (true ()))) 25 | 26 | (defun shen.x.factorise-defun.false-branch (V4958 V4959) (cond ((and (cons? V4959) (and (cons? (hd V4959)) (and (cons? (hd (hd V4959))) (and (= and (hd (hd (hd V4959)))) (and (cons? (tl (hd (hd V4959)))) (and (cons? (tl (tl (hd (hd V4959))))) (and (= () (tl (tl (tl (hd (hd V4959)))))) (and (cons? (tl (hd V4959))) (and (= () (tl (tl (hd V4959)))) (= (hd (tl (hd (hd V4959)))) V4958)))))))))) (shen.x.factorise-defun.false-branch (hd (tl (hd (hd V4959)))) (tl V4959))) ((and (cons? V4959) (and (cons? (hd V4959)) (and (cons? (tl (hd V4959))) (and (= () (tl (tl (hd V4959)))) (= (hd (hd V4959)) V4958))))) (shen.x.factorise-defun.false-branch (hd (hd V4959)) (tl V4959))) (true V4959))) 27 | 28 | (defun shen.x.factorise-defun.with-labelled-else (V4962 V4963) (cond ((and (cons? V4962) (and (= %%return (hd V4962)) (and (cons? (tl V4962)) (and (= () (tl (tl V4962))) (not (cons? (hd (tl V4962)))))))) (V4963 V4962)) ((and (cons? V4962) (and (= fail (hd V4962)) (= () (tl V4962)))) (V4963 V4962)) ((and (cons? V4962) (and (= %%goto-label (hd V4962)) (and (cons? (tl V4962)) (= () (tl (tl V4962)))))) (V4963 V4962)) (true (let Label (shen.x.factorise-defun.generate-label) (cons %%let-label (cons Label (cons V4962 (cons (V4963 (cons %%goto-label (cons Label ()))) ())))))))) 29 | 30 | (defun shen.x.factorise-defun.merge-same-else-ifs (V4966) (cond ((and (cons? V4966) (and (= if (hd V4966)) (and (cons? (tl V4966)) (and (cons? (tl (tl V4966))) (and (cons? (hd (tl (tl V4966)))) (and (= if (hd (hd (tl (tl V4966))))) (and (cons? (tl (hd (tl (tl V4966))))) (and (cons? (tl (tl (hd (tl (tl V4966)))))) (and (cons? (tl (tl (tl (hd (tl (tl V4966))))))) (and (= () (tl (tl (tl (tl (hd (tl (tl V4966)))))))) (and (cons? (tl (tl (tl V4966)))) (and (= () (tl (tl (tl (tl V4966))))) (= (hd (tl (tl (tl V4966)))) (hd (tl (tl (tl (hd (tl (tl V4966)))))))))))))))))))) (cons if (cons (cons and (cons (hd (tl V4966)) (cons (hd (tl (hd (tl (tl V4966))))) ()))) (cons (hd (tl (tl (hd (tl (tl V4966)))))) (tl (tl (tl V4966))))))) (true V4966))) 31 | 32 | (defun shen.x.factorise-defun.concat/ (V4969 V4970) (concat V4969 (concat / V4970))) 33 | 34 | (defun shen.x.factorise-defun.exp-var (V4974) (cond ((and (cons? V4974) (and (cons? (tl V4974)) (and (= () (tl (tl V4974))) (symbol? (hd V4974))))) (shen.x.factorise-defun.concat/ (shen.x.factorise-defun.exp-var (hd (tl V4974))) (hd V4974))) ((cons? V4974) (gensym (hd V4974))) (true V4974))) 35 | 36 | (defun shen.x.factorise-defun.optimize-selectors (V4977 V4978) (shen.x.factorise-defun.bind-repeating-selectors (shen.x.factorise-defun.test->selectors V4977) V4978)) 37 | 38 | (defun shen.x.factorise-defun.test->selectors (V4984) (cond ((and (cons? V4984) (and (= cons? (hd V4984)) (and (cons? (tl V4984)) (= () (tl (tl V4984)))))) (cons (cons hd (tl V4984)) (cons (cons tl (tl V4984)) ()))) ((and (cons? V4984) (and (= tuple? (hd V4984)) (and (cons? (tl V4984)) (= () (tl (tl V4984)))))) (cons (cons fst (tl V4984)) (cons (cons snd (tl V4984)) ()))) ((and (cons? V4984) (and (= shen.+string? (hd V4984)) (and (cons? (tl V4984)) (= () (tl (tl V4984)))))) (cons (cons hdstr (tl V4984)) (cons (cons tlstr (tl V4984)) ()))) ((and (cons? V4984) (and (= shen.+vector? (hd V4984)) (and (cons? (tl V4984)) (= () (tl (tl V4984)))))) (cons (cons hdv (tl V4984)) (cons (cons tlv (tl V4984)) ()))) (true (let Result (shen.x.factorise-defun.apply-selector-handlers (value shen.x.factorise-defun.*selector-handlers*) V4984) (if (= Result (fail)) () Result))))) 39 | 40 | (defun shen.x.factorise-defun.bind-repeating-selectors (V4987 V4988) (cond ((cons? V4987) (shen.x.factorise-defun.bind-selector (hd V4987) (shen.x.factorise-defun.bind-repeating-selectors (tl V4987) V4988))) ((= () V4987) V4988) (true (shen.f_error shen.x.factorise-defun.bind-repeating-selectors)))) 41 | 42 | (defun shen.x.factorise-defun.bind-selector (V4995 V4996) (cond ((> (occurrences V4995 V4996) 1) (let Var (shen.x.factorise-defun.exp-var V4995) (cons let (cons Var (cons V4995 (cons (subst Var V4995 V4996) ())))))) (true V4996))) 43 | 44 | (defun shen.x.factorise-defun.apply-selector-handlers (V5009 V5010) (cond ((= () V5009) (fail)) (true (let Freeze (freeze (cond ((cons? V5009) (shen.x.factorise-defun.apply-selector-handlers (tl V5009) V5010)) (true (shen.f_error shen.x.factorise-defun.apply-selector-handlers)))) (if (cons? V5009) (let Result ((hd V5009) V5010) (if (= Result (fail)) (thaw Freeze) Result)) (thaw Freeze)))))) 45 | 46 | (defun shen.x.factorise-defun.initialise () (do (set shen.x.factorise-defun.*selector-handlers* ()) (do (set shen.x.factorise-defun.*selector-handlers-reg* ()) shen.x.factorise-defun.done))) 47 | 48 | (defun shen.x.factorise-defun.register-selector-handler (V5012) (cond ((element? V5012 (value shen.x.factorise-defun.*selector-handlers*)) V5012) (true (do (set shen.x.factorise-defun.*selector-handlers-reg* (cons V5012 (value shen.x.factorise-defun.*selector-handlers*))) (do (set shen.x.factorise-defun.*selector-handlers* (cons (function V5012) (value shen.x.factorise-defun.*selector-handlers*))) V5012))))) 49 | 50 | (defun shen.x.factorise-defun.findpos (V5015 V5016) (trap-error (shen.findpos V5015 V5016) (lambda _ (simple-error (shen.app V5015 " is not a selector handler 51 | " shen.a))))) 52 | 53 | (defun shen.x.factorise-defun.unregister-selector-handler (V5018) (let Reg (value shen.x.factorise-defun.*selector-handlers-reg*) (let Pos (shen.x.factorise-defun.findpos V5018 Reg) (let RemoveReg (set shen.x.factorise-defun.*selector-handlers-reg* (remove V5018 Reg)) (let RemoveFun (set shen.x.factorise-defun.*selector-handlers* (shen.remove-nth Pos (value shen.x.factorise-defun.*selector-handlers*))) V5018))))) 54 | 55 | 56 | 57 | -------------------------------------------------------------------------------- /kl/macros.kl: -------------------------------------------------------------------------------- 1 | "Copyright (c) 2010-2015, 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 notice, 9 | this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright notice, 12 | this list of conditions and the following disclaimer in the documentation 13 | and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its contributors 16 | may be used to endorse or promote products derived from this software without 17 | specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND 20 | ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED 21 | WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE 22 | DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE 23 | FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 24 | DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR 25 | SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER 26 | CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, 27 | OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 28 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 29 | " 30 | 31 | (defun macroexpand (V690) (let Y (shen.compose (value *macros*) V690) (if (= V690 Y) V690 (shen.walk (lambda Z (macroexpand Z)) Y)))) 32 | 33 | (defun shen.error-macro (V692) (cond ((and (cons? V692) (and (= error (hd V692)) (cons? (tl V692)))) (cons simple-error (cons (shen.mkstr (hd (tl V692)) (tl (tl V692))) ()))) (true V692))) 34 | 35 | (defun shen.output-macro (V694) (cond ((and (cons? V694) (and (= output (hd V694)) (cons? (tl V694)))) (cons shen.prhush (cons (shen.mkstr (hd (tl V694)) (tl (tl V694))) (cons (cons stoutput ()) ())))) ((and (cons? V694) (and (= pr (hd V694)) (and (cons? (tl V694)) (= () (tl (tl V694)))))) (cons pr (cons (hd (tl V694)) (cons (cons stoutput ()) ())))) (true V694))) 36 | 37 | (defun shen.make-string-macro (V696) (cond ((and (cons? V696) (and (= make-string (hd V696)) (cons? (tl V696)))) (shen.mkstr (hd (tl V696)) (tl (tl V696)))) (true V696))) 38 | 39 | (defun shen.input-macro (V698) (cond ((and (cons? V698) (and (= lineread (hd V698)) (= () (tl V698)))) (cons lineread (cons (cons stinput ()) ()))) ((and (cons? V698) (and (= input (hd V698)) (= () (tl V698)))) (cons input (cons (cons stinput ()) ()))) ((and (cons? V698) (and (= read (hd V698)) (= () (tl V698)))) (cons read (cons (cons stinput ()) ()))) ((and (cons? V698) (and (= input+ (hd V698)) (and (cons? (tl V698)) (= () (tl (tl V698)))))) (cons input+ (cons (hd (tl V698)) (cons (cons stinput ()) ())))) ((and (cons? V698) (and (= read-byte (hd V698)) (= () (tl V698)))) (cons read-byte (cons (cons stinput ()) ()))) (true V698))) 40 | 41 | (defun shen.compose (V701 V702) (cond ((= () V701) V702) ((cons? V701) (shen.compose (tl V701) ((hd V701) V702))) (true (shen.f_error shen.compose)))) 42 | 43 | (defun shen.compile-macro (V704) (cond ((and (cons? V704) (and (= compile (hd V704)) (and (cons? (tl V704)) (and (cons? (tl (tl V704))) (= () (tl (tl (tl V704)))))))) (cons compile (cons (hd (tl V704)) (cons (hd (tl (tl V704))) (cons (cons lambda (cons E (cons (cons if (cons (cons cons? (cons E ())) (cons (cons error (cons "parse error here: ~S~%" (cons E ()))) (cons (cons error (cons "parse error~%" ())) ())))) ()))) ()))))) (true V704))) 44 | 45 | (defun shen.prolog-macro (V706) (cond ((and (cons? V706) (= prolog? (hd V706))) (cons let (cons NPP (cons (cons shen.start-new-prolog-process ()) (cons (let Calls (shen.bld-prolog-call NPP (tl V706)) (let Vs (shen.extract_vars (tl V706)) (let External (shen.externally-bound (tl V706)) (let PrologVs (difference Vs External) (shen.locally-bind-prolog-vs NPP PrologVs Calls))))) ()))))) (true V706))) 46 | 47 | (defun shen.externally-bound (V712) (cond ((and (cons? V712) (and (= receive (hd V712)) (and (cons? (tl V712)) (= () (tl (tl V712)))))) (tl V712)) ((cons? V712) (union (shen.externally-bound (hd V712)) (shen.externally-bound (tl V712)))) (true ()))) 48 | 49 | (defun shen.locally-bind-prolog-vs (V730 V731 V732) (cond ((= () V731) V732) ((cons? V731) (cons let (cons (hd V731) (cons (cons shen.newpv (cons V730 ())) (cons (shen.locally-bind-prolog-vs V730 (tl V731) V732) ()))))) (true (simple-error "implementation error inp locally-bind-prolog-vs")))) 50 | 51 | (defun shen.bld-prolog-call (V745 V746) (cond ((= () V746) true) ((and (cons? V746) (= ! (hd V746))) (cons cut (cons false (cons V745 (cons (cons freeze (cons (shen.bld-prolog-call V745 (tl V746)) ())) ()))))) ((and (cons? V746) (and (cons? (hd V746)) (and (= when (hd (hd V746))) (and (cons? (tl (hd V746))) (= () (tl (tl (hd V746)))))))) (cons fwhen (cons (shen.insert-deref (hd (tl (hd V746))) V745) (cons V745 (cons (cons freeze (cons (shen.bld-prolog-call V745 (tl V746)) ())) ()))))) ((and (cons? V746) (and (cons? (hd V746)) (and (= is (hd (hd V746))) (and (cons? (tl (hd V746))) (and (cons? (tl (tl (hd V746)))) (= () (tl (tl (tl (hd V746)))))))))) (cons bind (cons (hd (tl (hd V746))) (cons (shen.insert-deref (hd (tl (tl (hd V746)))) V745) (cons V745 (cons (cons freeze (cons (shen.bld-prolog-call V745 (tl V746)) ())) ())))))) ((and (cons? V746) (and (cons? (hd V746)) (and (= receive (hd (hd V746))) (and (cons? (tl (hd V746))) (= () (tl (tl (hd V746)))))))) (shen.bld-prolog-call V745 (tl V746))) ((and (cons? V746) (and (cons? (hd V746)) (and (= bind (hd (hd V746))) (and (cons? (tl (hd V746))) (and (cons? (tl (tl (hd V746)))) (= () (tl (tl (tl (hd V746)))))))))) (cons bind (cons (hd (tl (hd V746))) (cons (shen.insert-lazyderef (hd (tl (tl (hd V746)))) V745) (cons V745 (cons (cons freeze (cons (shen.bld-prolog-call V745 (tl V746)) ())) ())))))) ((and (cons? V746) (and (cons? (hd V746)) (and (= fwhen (hd (hd V746))) (and (cons? (tl (hd V746))) (= () (tl (tl (hd V746)))))))) (cons fwhen (cons (shen.insert-lazyderef (hd (tl (hd V746))) V745) (cons V745 (cons (cons freeze (cons (shen.bld-prolog-call V745 (tl V746)) ())) ()))))) ((cons? V746) (append (hd V746) (cons V745 (cons (cons freeze (cons (shen.bld-prolog-call V745 (tl V746)) ())) ())))) (true (simple-error "implementation error in bld-prolog-call")))) 52 | 53 | (defun shen.defprolog-macro (V748) (cond ((and (cons? V748) (and (= defprolog (hd V748)) (cons? (tl V748)))) (compile (lambda Y (shen. Y)) (tl V748) (lambda Y (shen.prolog-error (hd (tl V748)) Y)))) (true V748))) 54 | 55 | (defun shen.datatype-macro (V750) (cond ((and (cons? V750) (and (= datatype (hd V750)) (cons? (tl V750)))) (cons shen.process-datatype (cons (shen.intern-type (hd (tl V750))) (cons (cons compile (cons (cons lambda (cons X (cons (cons shen. (cons X ())) ()))) (cons (shen.rcons_form (tl (tl V750))) (cons (cons function (cons shen.datatype-error ())) ())))) ())))) (true V750))) 56 | 57 | (defun shen.intern-type (V752) (intern (cn (str V752) "#type"))) 58 | 59 | (defun shen.@s-macro (V754) (cond ((and (cons? V754) (and (= @s (hd V754)) (and (cons? (tl V754)) (and (cons? (tl (tl V754))) (cons? (tl (tl (tl V754)))))))) (cons @s (cons (hd (tl V754)) (cons (shen.@s-macro (cons @s (tl (tl V754)))) ())))) ((and (cons? V754) (and (= @s (hd V754)) (and (cons? (tl V754)) (and (cons? (tl (tl V754))) (and (= () (tl (tl (tl V754)))) (string? (hd (tl V754)))))))) (let E (explode (hd (tl V754))) (if (> (length E) 1) (shen.@s-macro (cons @s (append E (tl (tl V754))))) V754))) (true V754))) 60 | 61 | (defun shen.synonyms-macro (V756) (cond ((and (cons? V756) (= synonyms (hd V756))) (cons shen.synonyms-help (cons (shen.rcons_form (shen.curry-synonyms (tl V756))) ()))) (true V756))) 62 | 63 | (defun shen.curry-synonyms (V758) (map (lambda X (shen.curry-type X)) V758)) 64 | 65 | (defun shen.nl-macro (V760) (cond ((and (cons? V760) (and (= nl (hd V760)) (= () (tl V760)))) (cons nl (cons 1 ()))) (true V760))) 66 | 67 | (defun shen.assoc-macro (V762) (cond ((and (cons? V762) (and (cons? (tl V762)) (and (cons? (tl (tl V762))) (and (cons? (tl (tl (tl V762)))) (element? (hd V762) (cons @p (cons @v (cons append (cons and (cons or (cons + (cons * (cons do ()))))))))))))) (cons (hd V762) (cons (hd (tl V762)) (cons (shen.assoc-macro (cons (hd V762) (tl (tl V762)))) ())))) (true V762))) 68 | 69 | (defun shen.let-macro (V764) (cond ((and (cons? V764) (and (= let (hd V764)) (and (cons? (tl V764)) (and (cons? (tl (tl V764))) (and (cons? (tl (tl (tl V764)))) (cons? (tl (tl (tl (tl V764)))))))))) (cons let (cons (hd (tl V764)) (cons (hd (tl (tl V764))) (cons (shen.let-macro (cons let (tl (tl (tl V764))))) ()))))) (true V764))) 70 | 71 | (defun shen.abs-macro (V766) (cond ((and (cons? V766) (and (= /. (hd V766)) (and (cons? (tl V766)) (and (cons? (tl (tl V766))) (cons? (tl (tl (tl V766)))))))) (cons lambda (cons (hd (tl V766)) (cons (shen.abs-macro (cons /. (tl (tl V766)))) ())))) ((and (cons? V766) (and (= /. (hd V766)) (and (cons? (tl V766)) (and (cons? (tl (tl V766))) (= () (tl (tl (tl V766)))))))) (cons lambda (tl V766))) (true V766))) 72 | 73 | (defun shen.cases-macro (V770) (cond ((and (cons? V770) (and (= cases (hd V770)) (and (cons? (tl V770)) (and (= true (hd (tl V770))) (cons? (tl (tl V770))))))) (hd (tl (tl V770)))) ((and (cons? V770) (and (= cases (hd V770)) (and (cons? (tl V770)) (and (cons? (tl (tl V770))) (= () (tl (tl (tl V770)))))))) (cons if (cons (hd (tl V770)) (cons (hd (tl (tl V770))) (cons (cons simple-error (cons "error: cases exhausted" ())) ()))))) ((and (cons? V770) (and (= cases (hd V770)) (and (cons? (tl V770)) (cons? (tl (tl V770)))))) (cons if (cons (hd (tl V770)) (cons (hd (tl (tl V770))) (cons (shen.cases-macro (cons cases (tl (tl (tl V770))))) ()))))) ((and (cons? V770) (and (= cases (hd V770)) (and (cons? (tl V770)) (= () (tl (tl V770)))))) (simple-error "error: odd number of case elements 74 | ")) (true V770))) 75 | 76 | (defun shen.timer-macro (V772) (cond ((and (cons? V772) (and (= time (hd V772)) (and (cons? (tl V772)) (= () (tl (tl V772)))))) (shen.let-macro (cons let (cons Start (cons (cons get-time (cons run ())) (cons Result (cons (hd (tl V772)) (cons Finish (cons (cons get-time (cons run ())) (cons Time (cons (cons - (cons Finish (cons Start ()))) (cons Message (cons (cons shen.prhush (cons (cons cn (cons " 77 | run time: " (cons (cons cn (cons (cons str (cons Time ())) (cons " secs 78 | " ()))) ()))) (cons (cons stoutput ()) ()))) (cons Result ())))))))))))))) (true V772))) 79 | 80 | (defun shen.tuple-up (V774) (cond ((cons? V774) (cons @p (cons (hd V774) (cons (shen.tuple-up (tl V774)) ())))) (true V774))) 81 | 82 | (defun shen.put/get-macro (V776) (cond ((and (cons? V776) (and (= put (hd V776)) (and (cons? (tl V776)) (and (cons? (tl (tl V776))) (and (cons? (tl (tl (tl V776)))) (= () (tl (tl (tl (tl V776)))))))))) (cons put (cons (hd (tl V776)) (cons (hd (tl (tl V776))) (cons (hd (tl (tl (tl V776)))) (cons (cons value (cons *property-vector* ())) ())))))) ((and (cons? V776) (and (= get (hd V776)) (and (cons? (tl V776)) (and (cons? (tl (tl V776))) (= () (tl (tl (tl V776)))))))) (cons get (cons (hd (tl V776)) (cons (hd (tl (tl V776))) (cons (cons value (cons *property-vector* ())) ()))))) ((and (cons? V776) (and (= unput (hd V776)) (and (cons? (tl V776)) (and (cons? (tl (tl V776))) (= () (tl (tl (tl V776)))))))) (cons unput (cons (hd (tl V776)) (cons (hd (tl (tl V776))) (cons (cons value (cons *property-vector* ())) ()))))) (true V776))) 83 | 84 | (defun shen.function-macro (V778) (cond ((and (cons? V778) (and (= function (hd V778)) (and (cons? (tl V778)) (= () (tl (tl V778)))))) (shen.function-abstraction (hd (tl V778)) (arity (hd (tl V778))))) (true V778))) 85 | 86 | (defun shen.function-abstraction (V781 V782) (cond ((= 0 V782) (simple-error (shen.app V781 " has no lambda form 87 | " shen.a))) ((= -1 V782) (cons function (cons V781 ()))) (true (shen.function-abstraction-help V781 V782 ())))) 88 | 89 | (defun shen.function-abstraction-help (V786 V787 V788) (cond ((= 0 V787) (cons V786 V788)) (true (let X (gensym V) (cons /. (cons X (cons (shen.function-abstraction-help V786 (- V787 1) (append V788 (cons X ()))) ()))))))) 90 | 91 | (defun undefmacro (V790) (let MacroReg (value shen.*macroreg*) (let Pos (shen.findpos V790 MacroReg) (let Remove1 (set shen.*macroreg* (remove V790 MacroReg)) (let Remove2 (set *macros* (shen.remove-nth Pos (value *macros*))) V790))))) 92 | 93 | (defun shen.findpos (V800 V801) (cond ((= () V801) (simple-error (shen.app V800 " is not a macro 94 | " shen.a))) ((and (cons? V801) (= (hd V801) V800)) 1) ((cons? V801) (+ 1 (shen.findpos V800 (tl V801)))) (true (shen.f_error shen.findpos)))) 95 | 96 | (defun shen.remove-nth (V806 V807) (cond ((and (= 1 V806) (cons? V807)) (tl V807)) ((cons? V807) (cons (hd V807) (shen.remove-nth (- V806 1) (tl V807)))) (true (shen.f_error shen.remove-nth)))) 97 | 98 | 99 | 100 | -------------------------------------------------------------------------------- /compiled/writer.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/writer.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote pr) 2) (define (kl:pr V4536 V4537) (guard (lambda (E) V4536) (kl:shen.prh V4536 V4537 0))) (export pr) (quote pr)) 4 | (begin (register-function-arity (quote shen.prh) 3) (define (kl:shen.prh V4541 V4542 V4543) (kl:shen.prh V4541 V4542 (kl:shen.write-char-and-inc V4541 V4542 V4543))) (export shen.prh) (quote shen.prh)) 5 | (begin (register-function-arity (quote shen.write-char-and-inc) 3) (define (kl:shen.write-char-and-inc V4547 V4548 V4549) (begin (write-u8 (string-ref (make-string 1 (string-ref V4547 V4549)) 0) V4548) (+ V4549 1))) (export shen.write-char-and-inc) (quote shen.write-char-and-inc)) 6 | (begin (register-function-arity (quote print) 1) (define (kl:print V4551) (let ((String (kl:shen.insert V4551 "~S"))) (let ((Print (kl:shen.prhush String (kl:stoutput)))) V4551))) (export print) (quote print)) 7 | (begin (register-function-arity (quote shen.prhush) 2) (define (kl:shen.prhush V4554 V4555) (if (assert-boolean (kl:value (quote *hush*))) V4554 (kl:pr V4554 V4555))) (export shen.prhush) (quote shen.prhush)) 8 | (begin (register-function-arity (quote shen.mkstr) 2) (define (kl:shen.mkstr V4558 V4559) (cond ((string? V4558) (kl:shen.mkstr-l (kl:shen.proc-nl V4558) V4559)) (#t (kl:shen.mkstr-r (cons (quote shen.proc-nl) (cons V4558 (quote ()))) V4559)))) (export shen.mkstr) (quote shen.mkstr)) 9 | (begin (register-function-arity (quote shen.mkstr-l) 2) (define (kl:shen.mkstr-l V4562 V4563) (cond ((null? V4563) V4562) ((pair? V4563) (kl:shen.mkstr-l (kl:shen.insert-l (car V4563) V4562) (cdr V4563))) (#t (kl:shen.f_error (quote shen.mkstr-l))))) (export shen.mkstr-l) (quote shen.mkstr-l)) 10 | (begin (register-function-arity (quote shen.insert-l) 2) (define (kl:shen.insert-l V4568 V4569) (cond ((equal? "" V4569) "") ((and (assert-boolean (kl:shen.+string? V4569)) (and (equal? "~" (make-string 1 (string-ref V4569 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4569 1))) (equal? "A" (make-string 1 (string-ref (string-tail V4569 1) 0)))))) (cons (quote shen.app) (cons V4568 (cons (string-tail (string-tail V4569 1) 1) (cons (quote shen.a) (quote ())))))) ((and (assert-boolean (kl:shen.+string? V4569)) (and (equal? "~" (make-string 1 (string-ref V4569 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4569 1))) (equal? "R" (make-string 1 (string-ref (string-tail V4569 1) 0)))))) (cons (quote shen.app) (cons V4568 (cons (string-tail (string-tail V4569 1) 1) (cons (quote shen.r) (quote ())))))) ((and (assert-boolean (kl:shen.+string? V4569)) (and (equal? "~" (make-string 1 (string-ref V4569 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4569 1))) (equal? "S" (make-string 1 (string-ref (string-tail V4569 1) 0)))))) (cons (quote shen.app) (cons V4568 (cons (string-tail (string-tail V4569 1) 1) (cons (quote shen.s) (quote ())))))) ((assert-boolean (kl:shen.+string? V4569)) (kl:shen.factor-cn (cons (quote cn) (cons (make-string 1 (string-ref V4569 0)) (cons (kl:shen.insert-l V4568 (string-tail V4569 1)) (quote ())))))) ((and (pair? V4569) (and (eq? (quote cn) (car V4569)) (and (pair? (cdr V4569)) (and (pair? (cdr (cdr V4569))) (null? (cdr (cdr (cdr V4569)))))))) (cons (quote cn) (cons (car (cdr V4569)) (cons (kl:shen.insert-l V4568 (car (cdr (cdr V4569)))) (quote ()))))) ((and (pair? V4569) (and (eq? (quote shen.app) (car V4569)) (and (pair? (cdr V4569)) (and (pair? (cdr (cdr V4569))) (and (pair? (cdr (cdr (cdr V4569)))) (null? (cdr (cdr (cdr (cdr V4569)))))))))) (cons (quote shen.app) (cons (car (cdr V4569)) (cons (kl:shen.insert-l V4568 (car (cdr (cdr V4569)))) (cdr (cdr (cdr V4569))))))) (#t (kl:shen.f_error (quote shen.insert-l))))) (export shen.insert-l) (quote shen.insert-l)) 11 | (begin (register-function-arity (quote shen.factor-cn) 1) (define (kl:shen.factor-cn V4571) (cond ((and (pair? V4571) (and (eq? (quote cn) (car V4571)) (and (pair? (cdr V4571)) (and (pair? (cdr (cdr V4571))) (and (pair? (car (cdr (cdr V4571)))) (and (eq? (quote cn) (car (car (cdr (cdr V4571))))) (and (pair? (cdr (car (cdr (cdr V4571))))) (and (pair? (cdr (cdr (car (cdr (cdr V4571)))))) (and (null? (cdr (cdr (cdr (car (cdr (cdr V4571))))))) (and (null? (cdr (cdr (cdr V4571)))) (and (string? (car (cdr V4571))) (string? (car (cdr (car (cdr (cdr V4571))))))))))))))))) (cons (quote cn) (cons (string-append (car (cdr V4571)) (car (cdr (car (cdr (cdr V4571)))))) (cdr (cdr (car (cdr (cdr V4571)))))))) (#t V4571))) (export shen.factor-cn) (quote shen.factor-cn)) 12 | (begin (register-function-arity (quote shen.proc-nl) 1) (define (kl:shen.proc-nl V4573) (cond ((equal? "" V4573) "") ((and (assert-boolean (kl:shen.+string? V4573)) (and (equal? "~" (make-string 1 (string-ref V4573 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4573 1))) (equal? "%" (make-string 1 (string-ref (string-tail V4573 1) 0)))))) (string-append (make-string 1 10) (kl:shen.proc-nl (string-tail (string-tail V4573 1) 1)))) ((assert-boolean (kl:shen.+string? V4573)) (string-append (make-string 1 (string-ref V4573 0)) (kl:shen.proc-nl (string-tail V4573 1)))) (#t (kl:shen.f_error (quote shen.proc-nl))))) (export shen.proc-nl) (quote shen.proc-nl)) 13 | (begin (register-function-arity (quote shen.mkstr-r) 2) (define (kl:shen.mkstr-r V4576 V4577) (cond ((null? V4577) V4576) ((pair? V4577) (kl:shen.mkstr-r (cons (quote shen.insert) (cons (car V4577) (cons V4576 (quote ())))) (cdr V4577))) (#t (kl:shen.f_error (quote shen.mkstr-r))))) (export shen.mkstr-r) (quote shen.mkstr-r)) 14 | (begin (register-function-arity (quote shen.insert) 2) (define (kl:shen.insert V4580 V4581) (kl:shen.insert-h V4580 V4581 "")) (export shen.insert) (quote shen.insert)) 15 | (begin (register-function-arity (quote shen.insert-h) 3) (define (kl:shen.insert-h V4587 V4588 V4589) (cond ((equal? "" V4588) V4589) ((and (assert-boolean (kl:shen.+string? V4588)) (and (equal? "~" (make-string 1 (string-ref V4588 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4588 1))) (equal? "A" (make-string 1 (string-ref (string-tail V4588 1) 0)))))) (string-append V4589 (kl:shen.app V4587 (string-tail (string-tail V4588 1) 1) (quote shen.a)))) ((and (assert-boolean (kl:shen.+string? V4588)) (and (equal? "~" (make-string 1 (string-ref V4588 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4588 1))) (equal? "R" (make-string 1 (string-ref (string-tail V4588 1) 0)))))) (string-append V4589 (kl:shen.app V4587 (string-tail (string-tail V4588 1) 1) (quote shen.r)))) ((and (assert-boolean (kl:shen.+string? V4588)) (and (equal? "~" (make-string 1 (string-ref V4588 0))) (and (assert-boolean (kl:shen.+string? (string-tail V4588 1))) (equal? "S" (make-string 1 (string-ref (string-tail V4588 1) 0)))))) (string-append V4589 (kl:shen.app V4587 (string-tail (string-tail V4588 1) 1) (quote shen.s)))) ((assert-boolean (kl:shen.+string? V4588)) (kl:shen.insert-h V4587 (string-tail V4588 1) (string-append V4589 (make-string 1 (string-ref V4588 0))))) (#t (kl:shen.f_error (quote shen.insert-h))))) (export shen.insert-h) (quote shen.insert-h)) 16 | (begin (register-function-arity (quote shen.app) 3) (define (kl:shen.app V4593 V4594 V4595) (string-append (kl:shen.arg->str V4593 V4595) V4594)) (export shen.app) (quote shen.app)) 17 | (begin (register-function-arity (quote shen.arg->str) 2) (define (kl:shen.arg->str V4603 V4604) (cond ((kl:= V4603 (kl:fail)) "...") ((assert-boolean (kl:shen.list? V4603)) (kl:shen.list->str V4603 V4604)) ((string? V4603) (kl:shen.str->str V4603 V4604)) ((vector? V4603) (kl:shen.vector->str V4603 V4604)) (#t (kl:shen.atom->str V4603)))) (export shen.arg->str) (quote shen.arg->str)) 18 | (begin (register-function-arity (quote shen.list->str) 2) (define (kl:shen.list->str V4607 V4608) (cond ((eq? (quote shen.r) V4608) (kl:_waspvm_at_s "(" (kl:_waspvm_at_s (kl:shen.iter-list V4607 (quote shen.r) (kl:shen.maxseq)) ")"))) (#t (kl:_waspvm_at_s "[" (kl:_waspvm_at_s (kl:shen.iter-list V4607 V4608 (kl:shen.maxseq)) "]"))))) (export shen.list->str) (quote shen.list->str)) 19 | (begin (register-function-arity (quote shen.maxseq) 0) (define (kl:shen.maxseq) (kl:value (quote *maximum-print-sequence-size*))) (export shen.maxseq) (quote shen.maxseq)) 20 | (begin (register-function-arity (quote shen.iter-list) 3) (define (kl:shen.iter-list V4622 V4623 V4624) (cond ((null? V4622) "") ((kl:= 0 V4624) "... etc") ((and (pair? V4622) (null? (cdr V4622))) (kl:shen.arg->str (car V4622) V4623)) ((pair? V4622) (kl:_waspvm_at_s (kl:shen.arg->str (car V4622) V4623) (kl:_waspvm_at_s " " (kl:shen.iter-list (cdr V4622) V4623 (- V4624 1))))) (#t (kl:_waspvm_at_s "|" (kl:_waspvm_at_s " " (kl:shen.arg->str V4622 V4623)))))) (export shen.iter-list) (quote shen.iter-list)) 21 | (begin (register-function-arity (quote shen.str->str) 2) (define (kl:shen.str->str V4631 V4632) (cond ((eq? (quote shen.a) V4632) V4631) (#t (kl:_waspvm_at_s (make-string 1 34) (kl:_waspvm_at_s V4631 (make-string 1 34)))))) (export shen.str->str) (quote shen.str->str)) 22 | (begin (register-function-arity (quote shen.vector->str) 2) (define (kl:shen.vector->str V4635 V4636) (if (assert-boolean (kl:shen.print-vector? V4635)) ((kl:function (vector-ref V4635 0)) V4635) (if (assert-boolean (kl:vector? V4635)) (kl:_waspvm_at_s "<" (kl:_waspvm_at_s (kl:shen.iter-vector V4635 1 V4636 (kl:shen.maxseq)) ">")) (kl:_waspvm_at_s "<" (kl:_waspvm_at_s "<" (kl:_waspvm_at_s (kl:shen.iter-vector V4635 0 V4636 (kl:shen.maxseq)) ">>")))))) (export shen.vector->str) (quote shen.vector->str)) 23 | (begin (register-function-arity (quote shen.empty-absvector?) 1) (define (kl:shen.empty-absvector? V4638) (kl:= V4638 (kl:value (quote shen.*empty-absvector*)))) (export shen.empty-absvector?) (quote shen.empty-absvector?)) 24 | (begin (register-function-arity (quote shen.print-vector?) 1) (define (kl:shen.print-vector? V4640) (and (kl:not (kl:shen.empty-absvector? V4640)) (assert-boolean (let ((First (vector-ref V4640 0))) (or (eq? First (quote shen.tuple)) (or (eq? First (quote shen.pvar)) (or (eq? First (quote shen.dictionary)) (and (kl:not (number? First)) (assert-boolean (kl:shen.fbound? First)))))))))) (export shen.print-vector?) (quote shen.print-vector?)) 25 | (begin (register-function-arity (quote shen.fbound?) 1) (define (kl:shen.fbound? V4642) (guard (lambda (E) #f) (begin (kl:shen.lookup-func V4642) #t))) (export shen.fbound?) (quote shen.fbound?)) 26 | (begin (register-function-arity (quote shen.tuple) 1) (define (kl:shen.tuple V4644) (string-append "(@p " (kl:shen.app (vector-ref V4644 1) (string-append " " (kl:shen.app (vector-ref V4644 2) ")" (quote shen.s))) (quote shen.s)))) (export shen.tuple) (quote shen.tuple)) 27 | (begin (register-function-arity (quote shen.dictionary) 1) (define (kl:shen.dictionary V4646) "(dict ...)") (export shen.dictionary) (quote shen.dictionary)) 28 | (begin (register-function-arity (quote shen.iter-vector) 4) (define (kl:shen.iter-vector V4657 V4658 V4659 V4660) (cond ((kl:= 0 V4660) "... etc") (#t (let ((Item (guard (lambda (E) (quote shen.out-of-bounds)) (vector-ref V4657 V4658)))) (let ((Next (guard (lambda (E) (quote shen.out-of-bounds)) (vector-ref V4657 (+ V4658 1))))) (if (eq? Item (quote shen.out-of-bounds)) "" (if (eq? Next (quote shen.out-of-bounds)) (kl:shen.arg->str Item V4659) (kl:_waspvm_at_s (kl:shen.arg->str Item V4659) (kl:_waspvm_at_s " " (kl:shen.iter-vector V4657 (+ V4658 1) V4659 (- V4660 1))))))))))) (export shen.iter-vector) (quote shen.iter-vector)) 29 | (begin (register-function-arity (quote shen.atom->str) 1) (define (kl:shen.atom->str V4662) (guard (lambda (E) (kl:shen.funexstring)) (kl:str V4662))) (export shen.atom->str) (quote shen.atom->str)) 30 | (begin (register-function-arity (quote shen.funexstring) 0) (define (kl:shen.funexstring) (kl:_waspvm_at_s "\016" (kl:_waspvm_at_s "f" (kl:_waspvm_at_s "u" (kl:_waspvm_at_s "n" (kl:_waspvm_at_s "e" (kl:_waspvm_at_s (kl:shen.arg->str (kl:gensym (kl:intern "x")) (quote shen.a)) "\017"))))))) (export shen.funexstring) (quote shen.funexstring)) 31 | (begin (register-function-arity (quote shen.list?) 1) (define (kl:shen.list? V4664) (or (kl:empty? V4664) (pair? V4664))) (export shen.list?) (quote shen.list?)) 32 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Wasp/Shen, a Wasp Lisp port of the Shen Language 2 | 3 | [Shen](http://shenlanguage.org/) is a functional programming language with a number of interesting features. These include: 4 | 5 | * Optional static type checking 6 | * Pattern matching 7 | * Integrated Prolog system 8 | * Parsing libraries 9 | 10 | Shen can be ported without too much effort to other language systems. Many of the community ports are available from the [Shen download page](http://shenlanguage.org/download_form.html). A commercial port of Shen is available as part of [Shen Professional](http://shenlanguage.org/professional.html). 11 | 12 | This port runs on top of [Wasp Lisp](http://bluishcoder.co.nz/tags/waspvm/), a small Lisp system with concurrency and distributed features. Wasp Lisp is not actively developed but the author [Scott Dunlop](https://waspvm.blogspot.com/) monitors the [github repository](https://github.com/swdunlop/WaspVM/) and processes pull requests. Shen requires features that Wasp Lisp doesn't currently support, like real numbers. I maintain a [fork on github](https://github.com/doublec/WaspVM/tree/shen) that implements the features that Shen needs. 13 | 14 | The reason for this port is that I use Wasp Lisp in some projects and wanted to try Shen in some of the areas where I use Wasp and [MOSREF](https://bluishcoder.co.nz/2009/11/28/using-wasp-lisp-secure-remote-injection.html). 15 | 16 | This port is heavily based on the [Shen Scheme](https://github.com/tizoc/shen-scheme) implementation. Much of the code is ported from Scheme to Wasp Lisp and the structure is kept the same. The license for code I wrote is the same as the Shen Scheme License, BSD3-Clause. 17 | 18 | ## Binaries 19 | 20 | The following compiled binaries are available: 21 | 22 | [shen_static.bz2](https://bluishcoder.co.nz/shen/shen_static.bz2). This is a static 64-bit linux binary with no dependancies. It should run on any 64-bit Linux system. Decompress with: 23 | 24 | $ bunzip2 shen_static.bz2 25 | $ chmod +x shen_static 26 | $ ./shen_static 27 | 28 | [shen_macos.bz2](https://bluishcoder.co.nz/shen/shen_macos.bz2). 64-bit binary for Mac OS. Decompress with `bunzip2` as above. 29 | 30 | [shen.zip](https://bluishcoder.co.nz/shen/shen.zip). The zip file contains a Windows 64-bit binary, `shen.exe`. It should run on any modern 64-bit Windows system. 31 | 32 | Releases and changelog are available on the [Github releases page](https://github.com/doublec/shen-wasp/releases). 33 | 34 | ## Usage 35 | 36 | Running the `shen` executable without command line arguments will start the REPL. Command line handling is done via the Shen OS Kernel [launcher extension](https://github.com/Shen-Language/shen-sources/blob/master/doc/extensions/launcher.md). This makes the following command line arguments available: 37 | 38 | Usage: shen [--version] [--help] [] 39 | 40 | commands: 41 | repl 42 | Launches the interactive REPL. 43 | Default action if no command is supplied. 44 | 45 | script [] 46 | Runs the script in FILE. *argv* is set to [FILE | ARGS]. 47 | 48 | eval 49 | Evaluates expressions and files. ARGS are evaluated from 50 | left to right and can be a combination of: 51 | -e, --eval 52 | Evaluates EXPR and prints result. 53 | -l, --load 54 | Reads and evaluates FILE. 55 | -q, --quiet 56 | Silences interactive output. 57 | -s, --set 58 | Evaluates KEY, VALUE and sets as global. 59 | -r, --repl 60 | Launches the interactive REPL after evaluating 61 | all the previous expresions. 62 | 63 | For example, building the Shen KLambda files from the [Shen source](https://github.com/Shen-Language/shen-sources): 64 | 65 | $ shen eval -l make.shen -e "(make)" 66 | sources directory: "sources/" 67 | klambda directory: "klambda/" 68 | 69 | compiling core 70 | compiling declarations 71 | ... 72 | compiling yacc 73 | 74 | compilation complete. 75 | 76 | ## FFI 77 | 78 | Wasp Lisp functions can be called from Shen. They live under the `wasp` namespace (requiring a `wasp.` prefix). For example, to spawn a Wasp thread to print something after five seconds: 79 | 80 | (wasp.spawn (freeze (do (wasp.pause 5000) (print "Hello World\n")))) 81 | 82 | The Wasp function `spawn` takes a lambda that has no arguments. I couldn't find a way to create such a thing from Shen, but "freeze" is implemented to wrap its expression in a no argument lambda so that worked for this case. Note that Wasp threads are cooperative, not preemptive, and are green threads, not system threads. 83 | 84 | ## Building 85 | 86 | First step, build the fork of Wasp Lisp needed to run: 87 | 88 | $ git clone --branch shen https://github.com/doublec/WaspVM wasp-shen 89 | $ cd wasp-shen 90 | $ make install 91 | 92 | Follow the prompts for the location to install the wasp lisp binaries and add that `bin` directory of that location to your path: 93 | 94 | $ export PATH=$PATH:/path/to/install/bin 95 | 96 | Shen is provided in source code format from the [Shen Sources](https://github.com/Shen-Language/shen-sources) github repository. The code is written in Shen. It needs a working Shen system to compile that code to [KLambda](http://www.shenlanguage.org/learn-shen/shendoc.htm#The%20Primitive%20Functions%20of%20K%20Lambda), a small Lisp subset that Shen uses as a virtual machine. This KLamda code can be found in the `kl` directory in this repository. These KLambda files are compiled to Wasp Lisp and stored as compiled code in the `compiled` directory. The repository includes a recent version of these files. To generate, or re-generate, run the following commands: 97 | 98 | $ rlwrap wasp 99 | >> (import "driver") 100 | >> (compile-all) 101 | Compiling toplevel.kl 102 | Compiling core.kl 103 | Compiling sys.kl 104 | Compiling sequent.kl 105 | Compiling yacc.kl 106 | Compiling reader.kl 107 | Compiling prolog.kl 108 | Compiling track.kl 109 | Compiling load.kl 110 | Compiling writer.kl 111 | Compiling macros.kl 112 | Compiling declarations.kl 113 | Compiling types.kl 114 | Compiling t-star.kl 115 | 116 | This will create files with the Wasp Lisp code in the `compiled/*.ms` files, and the compiled bytecode in `compiled/*.mo` files. 117 | 118 | Creating a Shen executable can be done with: 119 | 120 | $ waspc -exe shen shen.ms 121 | $ chmod +x shen 122 | $ rlwrap ./shen 123 | Shen, copyright (C) 2010-2015 Mark Tarver 124 | www.shenlanguage.org, Shen 22.0 125 | running under Wasp Lisp, implementation: WaspVM 126 | port 0.11 ported by Chris Double 127 | 128 | (0-) 129 | 130 | ## Running from the Wasp REPL 131 | 132 | Shen can be run and debugged from the Wasp REPL. To import the compiled code and run Shen: 133 | 134 | $ rlwrap wasp 135 | >> (import "shen-lib") 136 | >> (kl:shen.repl) 137 | Shen, copyright (C) 2010-2015 Mark Tarver 138 | www.shenlanguage.org, Shen 22.0 139 | running under Wasp Lisp, implementation: WaspVM 140 | port 0.11 ported by Chris Double 141 | 142 | (0-) 143 | 144 | When developing on the compiler it's useful to use `eval-all`. This will load the KLambda files, compile them to Scheme and `eval` them: 145 | 146 | >> (import "driver") 147 | >> (eval-all) 148 | >> (kl:shen.repl) 149 | ... 150 | 151 | A single input line of Shen can be entered and run, returning to the Wasp REPL with: 152 | 153 | >> (kl:shen.read-evaluate-print) 154 | (+ 1 2) 155 | 3:: 3 156 | 157 | KLambda functions can be called from Wasp by prefixing them with `kl:`. For example: 158 | 159 | >> (kl:shen.read-evaluate-print) 160 | (define factorial 161 | 1 -> 1 162 | X -> (* X (factorial (- X 1)))) 163 | factorial:: factorial 164 | >> (kl:factorial 10) 165 | :: 3628800 166 | 167 | Shen allows introspecting compiled Shen functions and examining the KLambda code. From the Wasp REPL this is useful for viewing the KLambda and comparing with the generated Wasp Lisp: 168 | 169 | >> (kl:ps 'factorial) 170 | :: (defun factorial (V1172) (cond (...) (...))) 171 | >> (pretty (kl:ps 'factorial)) 172 | (defun factorial (V1172 ) (cond ((= 1 V1172 ) 1 ) (#t (* V1172 (factorial (- V1172 1 ) ) ) ) ) ) :: null 173 | >> (pretty (kl->wasp (kl:ps 'factorial))) 174 | (begin (register-function-arity (quote factorial ) 1 ) 175 | (define (kl:factorial V1172) 176 | (cond 177 | ((kl:= 1 V1172) 1) 178 | (#t (* V1172 (kl:factorial (- V1172 1)))))) 179 | (quote factorial ) ) :: null 180 | 181 | ## Cross Compilation 182 | 183 | Wasp binaries are a small Wasp VM stub plus the compiled Lisp code appended to it. This makes building for other platforms easy as long as you have the stub for that platform. 184 | 185 | Wasp can be built for [Android](https://bluishcoder.co.nz/2013/05/09/building-wasp-lisp-and-mosref-for-android.html) and [static binaries via musl](https://bluishcoder.co.nz/2016/06/05/building-static-wasp-lisp-binaries.html) are possible. 186 | 187 | I've made the following stubs available for building binaries for other systems: 188 | 189 | * [Musl 64-bit Linux static stub](https://bluishcoder.co.nz/shen/waspvm-static-linux-x86_64.bz2) 190 | * [64-bit Linux stub](https://bluishcoder.co.nz/shen/waspvm-linux-x86_64.bz2) 191 | * [64-bit Windows stub](https://bluishcoder.co.nz/shen/waspvm-win-x86_64.exe.bz2) 192 | * [64-bit Mac OS stub](https://bluishcoder.co.nz/shen/waspvm-Darwin-x86_64.bz2) 193 | 194 | Decompress them and copy into the `lib/waspvm-stubs` directory where Wasp Lisp was installed. Shen can then be built on your platform for 64 bit linux, 64 bit Linux static binaries or 64 bit Windows with: 195 | 196 | $ waspc -exe shen -platform linux-x86_64 shen.ms 197 | $ waspc -exe shen_static -platform static-linux-x86_64 shen.ms 198 | $ waspc -exe shen.exe -platform win-x86_64 shen.ms 199 | $ waspc -exe shen_macos -platform Darwin-x86_64 shen.ms 200 | 201 | ## Building KLambda files from Shen Source 202 | 203 | To generate new KLambda files from the original [Shen source](https://github.com/Shen-Language/shen-sources) requires loading the `make.shen` and running the `make` function. Once generated the KLambda files can be recompiled as described above to generate a new Wasp Shen system with updated Shen kernel code. The following shows how this can be done using an existing Wasp Shen executable: 204 | 205 | $ git clone https://github.com/Shen-Language/shen-sources 206 | $ cd shen-sources 207 | $ mkdir klambda 208 | $ shen eval -l make.shen -e "(make)" 209 | sources directory: "sources/" 210 | klambda directory: "klambda/" 211 | 212 | compiling core 213 | compiling declarations 214 | ... 215 | compiling yacc 216 | 217 | compilation complete. 218 | 219 | Copy the KLambda files from the `klambda` directory to the `kl` directory of this repository and rebuild the Wasp Shen system: 220 | 221 | $ cp klambda/*.kl ...path to wasp shen.../kl/ 222 | $ cd ...path to wasp shen... 223 | $ rlwrap wasp 224 | >> (import "driver") 225 | >> (compile-all) 226 | Compiling toplevel.kl 227 | ... 228 | 229 | $ make 230 | ... 231 | 232 | ## Running Shen Kernel Tests 233 | 234 | The Shen kernel tests are in the Shen Sources repository. They can be run with: 235 | 236 | $ git clone https://github.com/Shen-Language/shen-sources 237 | $ cd shen-sources/tests 238 | $ shen eval -l README.shen -l tests.shen 239 | 240 | ## Current Port State 241 | 242 | This is a very early version. I've only just got it working. The [Shen tests](https://github.com/Shen-Language/shen-sources/tree/master/tests) pass. 243 | 244 | The port is quite slow - about half the speed of the Shen C interpreter and significantly slower than Shen Scheme and Shen on SBCL. I've done some work on optimizing tail calls in the fork of the Wasp VM for Shen but there's much more work on the entire port that could improve things. 245 | 246 | I'd like to wrap some of the Wasp concurrency code and see how well Shen works in areas I use Wasp for. 247 | 248 | ## Learning Shen 249 | 250 | Some places to go to learn Shen: 251 | 252 | * The [Shen OS Kernel Manual](http://shenlanguage.org/learn-shen/index.html) has a good overview of what the open source version of Shen can do. 253 | * [Shen System Functions](https://github.com/Shen-Language/shen-sources/blob/master/doc/system-functions.md) 254 | * [Kicking the tires of Shen Prolog](https://bluishcoder.co.nz/2016/08/30/kicking-the-tires-of-shen-prolog.html) 255 | * [Shen, A Sufficiently Advanced Lisp](https://www.youtube.com/watch?v=lMcRBdSdO_U) 256 | * [Shen Trick Shots](https://www.youtube.com/watch?v=BUJNyHAeAc8) 257 | * [The Book of Shen](https://www.amazon.co.uk/Book-Shen-Third-Mark-Tarver/dp/1784562130) 258 | 259 | ## Other Ports 260 | 261 | * [Shen Scheme](https://github.com/tizoc/shen-scheme) 262 | * [Shen Elisp](http://github.com/deech/shen-elisp) 263 | * [Shen Ruby](https://github.com/gregspurrier/shen-ruby) 264 | * [Shen Haskell](https://github.com/mthom/shentong) 265 | * [Shen C](https://github.com/otabat/shen-c/) 266 | 267 | ## License 268 | 269 | - Shen, Copyright © 2010-2015 Mark Tarver - [License](http://www.shenlanguage.org/license.pdf). 270 | - Portions of the code adapted from shen-scheme, Copyright © 2012-2015 Bruno Deferrari under [BSD 3-Clause License](http://opensource.org/licenses/BSD-3-Clause). 271 | - shen-wasp, Coyright © 2017 Chris Double under [BSD 3-Clause License](http://opensource.org/licenses/BSD-3-Clause). 272 | -------------------------------------------------------------------------------- /compiled/toplevel.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/toplevel.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote shen.repl) 0) (define (kl:shen.repl) (begin (kl:shen.credits) (kl:shen.loop))) (export shen.repl) (quote shen.repl)) 4 | (begin (register-function-arity (quote shen.loop) 0) (define (kl:shen.loop) (begin (kl:shen.initialise_environment) (begin (kl:shen.prompt) (begin (guard (lambda (E) (kl:shen.toplevel-display-exception E)) (kl:shen.read-evaluate-print)) (kl:shen.loop))))) (export shen.loop) (quote shen.loop)) 5 | (begin (register-function-arity (quote shen.toplevel-display-exception) 1) (define (kl:shen.toplevel-display-exception V2964) (kl:pr (kl:error-to-string V2964) (kl:stoutput))) (export shen.toplevel-display-exception) (quote shen.toplevel-display-exception)) 6 | (begin (register-function-arity (quote shen.credits) 0) (define (kl:shen.credits) (begin (kl:shen.prhush "\nShen, copyright (C) 2010-2015 Mark Tarver\n" (kl:stoutput)) (begin (kl:shen.prhush (string-append "www.shenlanguage.org, " (kl:shen.app (kl:value (quote *version*)) "\n" (quote shen.a))) (kl:stoutput)) (begin (kl:shen.prhush (string-append "running under " (kl:shen.app (kl:value (quote *language*)) (string-append ", implementation: " (kl:shen.app (kl:value (quote *implementation*)) "" (quote shen.a))) (quote shen.a))) (kl:stoutput)) (kl:shen.prhush (string-append "\nport " (kl:shen.app (kl:value (quote *port*)) (string-append " ported by " (kl:shen.app (kl:value (quote *porters*)) "\n" (quote shen.a))) (quote shen.a))) (kl:stoutput)))))) (export shen.credits) (quote shen.credits)) 7 | (begin (register-function-arity (quote shen.initialise_environment) 0) (define (kl:shen.initialise_environment) (kl:shen.multiple-set (cons (quote shen.*call*) (cons 0 (cons (quote shen.*infs*) (cons 0 (cons (quote shen.*process-counter*) (cons 0 (cons (quote shen.*catch*) (cons 0 (quote ()))))))))))) (export shen.initialise_environment) (quote shen.initialise_environment)) 8 | (begin (register-function-arity (quote shen.multiple-set) 1) (define (kl:shen.multiple-set V2966) (cond ((null? V2966) (quote ())) ((and (pair? V2966) (pair? (cdr V2966))) (begin (kl:set (car V2966) (car (cdr V2966))) (kl:shen.multiple-set (cdr (cdr V2966))))) (#t (kl:shen.f_error (quote shen.multiple-set))))) (export shen.multiple-set) (quote shen.multiple-set)) 9 | (begin (register-function-arity (quote destroy) 1) (define (kl:destroy V2968) (kl:declare V2968 (quote symbol))) (export destroy) (quote destroy)) 10 | (begin (register-function-arity (quote shen.read-evaluate-print) 0) (define (kl:shen.read-evaluate-print) (let ((Lineread (kl:shen.toplineread))) (let ((History (kl:value (quote shen.*history*)))) (let ((NewLineread (kl:shen.retrieve-from-history-if-needed Lineread History))) (let ((NewHistory (kl:shen.update_history NewLineread History))) (let ((Parsed (kl:fst NewLineread))) (kl:shen.toplevel Parsed))))))) (export shen.read-evaluate-print) (quote shen.read-evaluate-print)) 11 | (begin (register-function-arity (quote shen.retrieve-from-history-if-needed) 2) (define (kl:shen.retrieve-from-history-if-needed V2980 V2981) (cond ((and (kl:tuple? V2980) (and (pair? (kl:snd V2980)) (kl:element? (car (kl:snd V2980)) (cons (kl:shen.space) (cons (kl:shen.newline) (quote ())))))) (kl:shen.retrieve-from-history-if-needed (kl:_waspvm_at_p (kl:fst V2980) (cdr (kl:snd V2980))) V2981)) ((and (kl:tuple? V2980) (and (pair? (kl:snd V2980)) (and (pair? (cdr (kl:snd V2980))) (and (null? (cdr (cdr (kl:snd V2980)))) (and (pair? V2981) (and (kl:= (car (kl:snd V2980)) (kl:shen.exclamation)) (kl:= (car (cdr (kl:snd V2980))) (kl:shen.exclamation)))))))) (let ((PastPrint (kl:shen.prbytes (kl:snd (car V2981))))) (car V2981))) ((and (kl:tuple? V2980) (and (pair? (kl:snd V2980)) (kl:= (car (kl:snd V2980)) (kl:shen.exclamation)))) (let ((Key? (kl:shen.make-key (cdr (kl:snd V2980)) V2981))) (let ((Find (kl:head (kl:shen.find-past-inputs Key? V2981)))) (let ((PastPrint (kl:shen.prbytes (kl:snd Find)))) Find)))) ((and (kl:tuple? V2980) (and (pair? (kl:snd V2980)) (and (null? (cdr (kl:snd V2980))) (kl:= (car (kl:snd V2980)) (kl:shen.percent))))) (begin (kl:shen.print-past-inputs (lambda (X) #t) (kl:reverse V2981) 0) (kl:abort))) ((and (kl:tuple? V2980) (and (pair? (kl:snd V2980)) (kl:= (car (kl:snd V2980)) (kl:shen.percent)))) (let ((Key? (kl:shen.make-key (cdr (kl:snd V2980)) V2981))) (let ((Pastprint (kl:shen.print-past-inputs Key? (kl:reverse V2981) 0))) (kl:abort)))) (#t V2980))) (export shen.retrieve-from-history-if-needed) (quote shen.retrieve-from-history-if-needed)) 12 | (begin (register-function-arity (quote shen.percent) 0) (define (kl:shen.percent) 37) (export shen.percent) (quote shen.percent)) 13 | (begin (register-function-arity (quote shen.exclamation) 0) (define (kl:shen.exclamation) 33) (export shen.exclamation) (quote shen.exclamation)) 14 | (begin (register-function-arity (quote shen.prbytes) 1) (define (kl:shen.prbytes V2983) (begin (kl:shen.for-each (lambda (Byte) (kl:pr (make-string 1 Byte) (kl:stoutput))) V2983) (kl:nl 1))) (export shen.prbytes) (quote shen.prbytes)) 15 | (begin (register-function-arity (quote shen.update_history) 2) (define (kl:shen.update_history V2986 V2987) (kl:set (quote shen.*history*) (cons V2986 V2987))) (export shen.update_history) (quote shen.update_history)) 16 | (begin (register-function-arity (quote shen.toplineread) 0) (define (kl:shen.toplineread) (kl:shen.toplineread_loop (kl:shen.read-char-code (kl:stinput)) (quote ()))) (export shen.toplineread) (quote shen.toplineread)) 17 | (begin (register-function-arity (quote shen.toplineread_loop) 2) (define (kl:shen.toplineread_loop V2991 V2992) (cond ((kl:= V2991 (kl:shen.hat)) (simple-error "line read aborted")) ((kl:element? V2991 (cons (kl:shen.newline) (cons (kl:shen.carriage-return) (quote ())))) (let ((Line (kl:compile (lambda (X) (kl:shen. X)) V2992 (lambda (E) (quote shen.nextline))))) (let ((It (kl:shen.record-it V2992))) (if (or (eq? Line (quote shen.nextline)) (kl:empty? Line)) (kl:shen.toplineread_loop (kl:shen.read-char-code (kl:stinput)) (kl:append V2992 (cons V2991 (quote ())))) (kl:_waspvm_at_p Line V2992))))) (#t (kl:shen.toplineread_loop (kl:shen.read-char-code (kl:stinput)) (if (kl:= V2991 -1) V2992 (kl:append V2992 (cons V2991 (quote ())))))))) (export shen.toplineread_loop) (quote shen.toplineread_loop)) 18 | (begin (register-function-arity (quote shen.hat) 0) (define (kl:shen.hat) 94) (export shen.hat) (quote shen.hat)) 19 | (begin (register-function-arity (quote shen.newline) 0) (define (kl:shen.newline) 10) (export shen.newline) (quote shen.newline)) 20 | (begin (register-function-arity (quote shen.carriage-return) 0) (define (kl:shen.carriage-return) 13) (export shen.carriage-return) (quote shen.carriage-return)) 21 | (begin (register-function-arity (quote tc) 1) (define (kl:tc V2998) (cond ((eq? (quote +) V2998) (kl:set (quote shen.*tc*) #t)) ((eq? (quote -) V2998) (kl:set (quote shen.*tc*) #f)) (#t (simple-error "tc expects a + or -")))) (export tc) (quote tc)) 22 | (begin (register-function-arity (quote shen.prompt) 0) (define (kl:shen.prompt) (if (assert-boolean (kl:value (quote shen.*tc*))) (kl:shen.prhush (string-append "\n\n(" (kl:shen.app (kl:length (kl:value (quote shen.*history*))) "+) " (quote shen.a))) (kl:stoutput)) (kl:shen.prhush (string-append "\n\n(" (kl:shen.app (kl:length (kl:value (quote shen.*history*))) "-) " (quote shen.a))) (kl:stoutput)))) (export shen.prompt) (quote shen.prompt)) 23 | (begin (register-function-arity (quote shen.toplevel) 1) (define (kl:shen.toplevel V3000) (kl:shen.toplevel_evaluate V3000 (kl:value (quote shen.*tc*)))) (export shen.toplevel) (quote shen.toplevel)) 24 | (begin (register-function-arity (quote shen.find-past-inputs) 2) (define (kl:shen.find-past-inputs V3003 V3004) (let ((F (kl:shen.find V3003 V3004))) (if (kl:empty? F) (simple-error "input not found\n") F))) (export shen.find-past-inputs) (quote shen.find-past-inputs)) 25 | (begin (register-function-arity (quote shen.make-key) 2) (define (kl:shen.make-key V3007 V3008) (let ((Atom (car (kl:compile (lambda (X) (kl:shen. X)) V3007 (lambda (E) (if (pair? E) (simple-error (string-append "parse error here: " (kl:shen.app E "\n" (quote shen.s)))) (simple-error "parse error\n"))))))) (if (assert-boolean (kl:integer? Atom)) (lambda (X) (kl:= X (kl:nth (+ Atom 1) (kl:reverse V3008)))) (lambda (X) (kl:shen.prefix? V3007 (kl:shen.trim-gubbins (kl:snd X))))))) (export shen.make-key) (quote shen.make-key)) 26 | (begin (register-function-arity (quote shen.trim-gubbins) 1) (define (kl:shen.trim-gubbins V3010) (cond ((and (pair? V3010) (kl:= (car V3010) (kl:shen.space))) (kl:shen.trim-gubbins (cdr V3010))) ((and (pair? V3010) (kl:= (car V3010) (kl:shen.newline))) (kl:shen.trim-gubbins (cdr V3010))) ((and (pair? V3010) (kl:= (car V3010) (kl:shen.carriage-return))) (kl:shen.trim-gubbins (cdr V3010))) ((and (pair? V3010) (kl:= (car V3010) (kl:shen.tab))) (kl:shen.trim-gubbins (cdr V3010))) ((and (pair? V3010) (kl:= (car V3010) (kl:shen.left-round))) (kl:shen.trim-gubbins (cdr V3010))) (#t V3010))) (export shen.trim-gubbins) (quote shen.trim-gubbins)) 27 | (begin (register-function-arity (quote shen.space) 0) (define (kl:shen.space) 32) (export shen.space) (quote shen.space)) 28 | (begin (register-function-arity (quote shen.tab) 0) (define (kl:shen.tab) 9) (export shen.tab) (quote shen.tab)) 29 | (begin (register-function-arity (quote shen.left-round) 0) (define (kl:shen.left-round) 40) (export shen.left-round) (quote shen.left-round)) 30 | (begin (register-function-arity (quote shen.find) 2) (define (kl:shen.find V3019 V3020) (cond ((null? V3020) (quote ())) ((and (pair? V3020) (assert-boolean (V3019 (car V3020)))) (cons (car V3020) (kl:shen.find V3019 (cdr V3020)))) ((pair? V3020) (kl:shen.find V3019 (cdr V3020))) (#t (kl:shen.f_error (quote shen.find))))) (export shen.find) (quote shen.find)) 31 | (begin (register-function-arity (quote shen.prefix?) 2) (define (kl:shen.prefix? V3034 V3035) (cond ((null? V3034) #t) ((and (pair? V3034) (and (pair? V3035) (kl:= (car V3035) (car V3034)))) (kl:shen.prefix? (cdr V3034) (cdr V3035))) (#t #f))) (export shen.prefix?) (quote shen.prefix?)) 32 | (begin (register-function-arity (quote shen.print-past-inputs) 3) (define (kl:shen.print-past-inputs V3047 V3048 V3049) (cond ((null? V3048) (quote _)) ((and (pair? V3048) (kl:not (V3047 (car V3048)))) (kl:shen.print-past-inputs V3047 (cdr V3048) (+ V3049 1))) ((and (pair? V3048) (kl:tuple? (car V3048))) (begin (kl:shen.prhush (kl:shen.app V3049 ". " (quote shen.a)) (kl:stoutput)) (begin (kl:shen.prbytes (kl:snd (car V3048))) (kl:shen.print-past-inputs V3047 (cdr V3048) (+ V3049 1))))) (#t (kl:shen.f_error (quote shen.print-past-inputs))))) (export shen.print-past-inputs) (quote shen.print-past-inputs)) 33 | (begin (register-function-arity (quote shen.toplevel_evaluate) 2) (define (kl:shen.toplevel_evaluate V3052 V3053) (cond ((and (pair? V3052) (and (pair? (cdr V3052)) (and (eq? (quote :) (car (cdr V3052))) (and (pair? (cdr (cdr V3052))) (and (null? (cdr (cdr (cdr V3052)))) (kl:= #t V3053)))))) (kl:shen.typecheck-and-evaluate (car V3052) (car (cdr (cdr V3052))))) ((and (pair? V3052) (pair? (cdr V3052))) (begin (kl:shen.toplevel_evaluate (cons (car V3052) (quote ())) V3053) (begin (kl:nl 1) (kl:shen.toplevel_evaluate (cdr V3052) V3053)))) ((and (pair? V3052) (and (null? (cdr V3052)) (kl:= #t V3053))) (kl:shen.typecheck-and-evaluate (car V3052) (kl:gensym (quote A)))) ((and (pair? V3052) (and (null? (cdr V3052)) (kl:= #f V3053))) (let ((Eval (kl:shen.eval-without-macros (car V3052)))) (kl:print Eval))) (#t (kl:shen.f_error (quote shen.toplevel_evaluate))))) (export shen.toplevel_evaluate) (quote shen.toplevel_evaluate)) 34 | (begin (register-function-arity (quote shen.typecheck-and-evaluate) 2) (define (kl:shen.typecheck-and-evaluate V3056 V3057) (let ((Typecheck (kl:shen.typecheck V3056 V3057))) (if (kl:= Typecheck #f) (simple-error "type error\n") (let ((Eval (kl:shen.eval-without-macros V3056))) (let ((Type (kl:shen.pretty-type Typecheck))) (kl:shen.prhush (kl:shen.app Eval (string-append " : " (kl:shen.app Type "" (quote shen.r))) (quote shen.s)) (kl:stoutput))))))) (export shen.typecheck-and-evaluate) (quote shen.typecheck-and-evaluate)) 35 | (begin (register-function-arity (quote shen.pretty-type) 1) (define (kl:shen.pretty-type V3059) (kl:shen.mult_subst (kl:value (quote shen.*alphabet*)) (kl:shen.extract-pvars V3059) V3059)) (export shen.pretty-type) (quote shen.pretty-type)) 36 | (begin (register-function-arity (quote shen.extract-pvars) 1) (define (kl:shen.extract-pvars V3065) (cond ((kl:shen.pvar? V3065) (cons V3065 (quote ()))) ((pair? V3065) (kl:union (kl:shen.extract-pvars (car V3065)) (kl:shen.extract-pvars (cdr V3065)))) (#t (quote ())))) (export shen.extract-pvars) (quote shen.extract-pvars)) 37 | (begin (register-function-arity (quote shen.mult_subst) 3) (define (kl:shen.mult_subst V3073 V3074 V3075) (cond ((null? V3073) V3075) ((null? V3074) V3075) ((and (pair? V3073) (pair? V3074)) (kl:shen.mult_subst (cdr V3073) (cdr V3074) (kl:subst (car V3073) (car V3074) V3075))) (#t (kl:shen.f_error (quote shen.mult_subst))))) (export shen.mult_subst) (quote shen.mult_subst)) 38 | -------------------------------------------------------------------------------- /compiled/yacc.kl.ms: -------------------------------------------------------------------------------- 1 | (module "compiled/yacc.kl") 2 | "Copyright (c) 2010-2015, Mark Tarver\n\nAll rights reserved.\n\nRedistribution and use in source and binary forms, with or without\nmodification, are permitted provided that the following conditions are met:\n\n1. Redistributions of source code must retain the above copyright notice,\nthis list of conditions and the following disclaimer.\n\n2. Redistributions in binary form must reproduce the above copyright notice,\nthis list of conditions and the following disclaimer in the documentation\nand/or other materials provided with the distribution.\n\n3. Neither the name of the copyright holder nor the names of its contributors\nmay be used to endorse or promote products derived from this software without\nspecific prior written permission.\n\nTHIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ''AS IS'' AND\nANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED\nWARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE\nDISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE\nFOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL\nDAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\nSERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER\nCAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,\nOR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE\nOF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n" 3 | (begin (register-function-arity (quote shen.yacc) 1) (define (kl:shen.yacc V4666) (cond ((and (pair? V4666) (and (eq? (quote defcc) (car V4666)) (pair? (cdr V4666)))) (kl:shen.yacc->shen (car (cdr V4666)) (cdr (cdr V4666)))) (#t (kl:shen.f_error (quote shen.yacc))))) (export shen.yacc) (quote shen.yacc)) 4 | (begin (register-function-arity (quote shen.yacc->shen) 2) (define (kl:shen.yacc->shen V4669 V4670) (let ((CCRules (kl:shen.split_cc_rules #t V4670 (quote ())))) (let ((CCBody (kl:map (lambda (X) (kl:shen.cc_body X)) CCRules))) (let ((YaccCases (kl:shen.yacc_cases CCBody))) (cons (quote define) (cons V4669 (cons (quote Stream) (cons (quote ->) (cons (kl:shen.kill-code YaccCases) (quote ())))))))))) (export shen.yacc->shen) (quote shen.yacc->shen)) 5 | (begin (register-function-arity (quote shen.kill-code) 1) (define (kl:shen.kill-code V4672) (cond ((> (kl:occurrences (quote kill) V4672) 0) (cons (quote trap-error) (cons V4672 (cons (cons (quote lambda) (cons (quote E) (cons (cons (quote shen.analyse-kill) (cons (quote E) (quote ()))) (quote ())))) (quote ()))))) (#t V4672))) (export shen.kill-code) (quote shen.kill-code)) 6 | (begin (register-function-arity (quote kill) 0) (define (kl:kill) (simple-error "yacc kill")) (export kill) (quote kill)) 7 | (begin (register-function-arity (quote shen.analyse-kill) 1) (define (kl:shen.analyse-kill V4674) (let ((String (kl:error-to-string V4674))) (if (equal? String "yacc kill") (kl:fail) V4674))) (export shen.analyse-kill) (quote shen.analyse-kill)) 8 | (begin (register-function-arity (quote shen.split_cc_rules) 3) (define (kl:shen.split_cc_rules V4680 V4681 V4682) (cond ((and (null? V4681) (null? V4682)) (quote ())) ((null? V4681) (cons (kl:shen.split_cc_rule V4680 (kl:reverse V4682) (quote ())) (quote ()))) ((and (pair? V4681) (eq? (quote _waspvm_sc_) (car V4681))) (cons (kl:shen.split_cc_rule V4680 (kl:reverse V4682) (quote ())) (kl:shen.split_cc_rules V4680 (cdr V4681) (quote ())))) ((pair? V4681) (kl:shen.split_cc_rules V4680 (cdr V4681) (cons (car V4681) V4682))) (#t (kl:shen.f_error (quote shen.split_cc_rules))))) (export shen.split_cc_rules) (quote shen.split_cc_rules)) 9 | (begin (register-function-arity (quote shen.split_cc_rule) 3) (define (kl:shen.split_cc_rule V4690 V4691 V4692) (cond ((and (pair? V4691) (and (eq? (quote :=) (car V4691)) (and (pair? (cdr V4691)) (null? (cdr (cdr V4691)))))) (cons (kl:reverse V4692) (cdr V4691))) ((and (pair? V4691) (and (eq? (quote :=) (car V4691)) (and (pair? (cdr V4691)) (and (pair? (cdr (cdr V4691))) (and (eq? (quote where) (car (cdr (cdr V4691)))) (and (pair? (cdr (cdr (cdr V4691)))) (null? (cdr (cdr (cdr (cdr V4691))))))))))) (cons (kl:reverse V4692) (cons (cons (quote where) (cons (car (cdr (cdr (cdr V4691)))) (cons (car (cdr V4691)) (quote ())))) (quote ())))) ((null? V4691) (begin (kl:shen.semantic-completion-warning V4690 V4692) (kl:shen.split_cc_rule V4690 (cons (quote :=) (cons (kl:shen.default_semantics (kl:reverse V4692)) (quote ()))) V4692))) ((pair? V4691) (kl:shen.split_cc_rule V4690 (cdr V4691) (cons (car V4691) V4692))) (#t (kl:shen.f_error (quote shen.split_cc_rule))))) (export shen.split_cc_rule) (quote shen.split_cc_rule)) 10 | (begin (register-function-arity (quote shen.semantic-completion-warning) 2) (define (kl:shen.semantic-completion-warning V4703 V4704) (cond ((kl:= #t V4703) (begin (kl:shen.prhush "warning: " (kl:stoutput)) (begin (kl:shen.for-each (lambda (X) (kl:shen.prhush (kl:shen.app X " " (quote shen.a)) (kl:stoutput))) (kl:reverse V4704)) (kl:shen.prhush "has no semantics.\n" (kl:stoutput))))) (#t (quote shen.skip)))) (export shen.semantic-completion-warning) (quote shen.semantic-completion-warning)) 11 | (begin (register-function-arity (quote shen.default_semantics) 1) (define (kl:shen.default_semantics V4706) (cond ((null? V4706) (quote ())) ((and (pair? V4706) (and (null? (cdr V4706)) (assert-boolean (kl:shen.grammar_symbol? (car V4706))))) (car V4706)) ((and (pair? V4706) (assert-boolean (kl:shen.grammar_symbol? (car V4706)))) (cons (quote append) (cons (car V4706) (cons (kl:shen.default_semantics (cdr V4706)) (quote ()))))) ((pair? V4706) (cons (quote cons) (cons (car V4706) (cons (kl:shen.default_semantics (cdr V4706)) (quote ()))))) (#t (kl:shen.f_error (quote shen.default_semantics))))) (export shen.default_semantics) (quote shen.default_semantics)) 12 | (begin (register-function-arity (quote shen.grammar_symbol?) 1) (define (kl:shen.grammar_symbol? V4708) (and (kl:symbol? V4708) (assert-boolean (let ((Cs (kl:shen.strip-pathname (kl:explode V4708)))) (and (equal? (car Cs) "<") (equal? (car (kl:reverse Cs)) ">")))))) (export shen.grammar_symbol?) (quote shen.grammar_symbol?)) 13 | (begin (register-function-arity (quote shen.yacc_cases) 1) (define (kl:shen.yacc_cases V4710) (cond ((and (pair? V4710) (null? (cdr V4710))) (car V4710)) ((pair? V4710) (let ((P (quote YaccParse))) (cons (quote let) (cons P (cons (car V4710) (cons (cons (quote if) (cons (cons (quote =) (cons P (cons (cons (quote fail) (quote ())) (quote ())))) (cons (kl:shen.yacc_cases (cdr V4710)) (cons P (quote ()))))) (quote ()))))))) (#t (kl:shen.f_error (quote shen.yacc_cases))))) (export shen.yacc_cases) (quote shen.yacc_cases)) 14 | (begin (register-function-arity (quote shen.cc_body) 1) (define (kl:shen.cc_body V4712) (cond ((and (pair? V4712) (and (pair? (cdr V4712)) (null? (cdr (cdr V4712))))) (kl:shen.syntax (car V4712) (quote Stream) (car (cdr V4712)))) (#t (kl:shen.f_error (quote shen.cc_body))))) (export shen.cc_body) (quote shen.cc_body)) 15 | (begin (register-function-arity (quote shen.syntax) 3) (define (kl:shen.syntax V4716 V4717 V4718) (cond ((and (null? V4716) (and (pair? V4718) (and (eq? (quote where) (car V4718)) (and (pair? (cdr V4718)) (and (pair? (cdr (cdr V4718))) (null? (cdr (cdr (cdr V4718))))))))) (cons (quote if) (cons (kl:shen.semantics (car (cdr V4718))) (cons (cons (quote shen.pair) (cons (cons (quote hd) (cons V4717 (quote ()))) (cons (kl:shen.semantics (car (cdr (cdr V4718)))) (quote ())))) (cons (cons (quote fail) (quote ())) (quote ())))))) ((null? V4716) (cons (quote shen.pair) (cons (cons (quote hd) (cons V4717 (quote ()))) (cons (kl:shen.semantics V4718) (quote ()))))) ((pair? V4716) (if (assert-boolean (kl:shen.grammar_symbol? (car V4716))) (kl:shen.recursive_descent V4716 V4717 V4718) (if (kl:variable? (car V4716)) (kl:shen.variable-match V4716 V4717 V4718) (if (assert-boolean (kl:shen.jump_stream? (car V4716))) (kl:shen.jump_stream V4716 V4717 V4718) (if (assert-boolean (kl:shen.terminal? (car V4716))) (kl:shen.check_stream V4716 V4717 V4718) (if (pair? (car V4716)) (kl:shen.list-stream (kl:shen.decons (car V4716)) (cdr V4716) V4717 V4718) (simple-error (kl:shen.app (car V4716) " is not legal syntax\n" (quote shen.a))))))))) (#t (kl:shen.f_error (quote shen.syntax))))) (export shen.syntax) (quote shen.syntax)) 16 | (begin (register-function-arity (quote shen.list-stream) 4) (define (kl:shen.list-stream V4723 V4724 V4725 V4726) (let ((Test (cons (quote and) (cons (cons (quote cons?) (cons (cons (quote hd) (cons V4725 (quote ()))) (quote ()))) (cons (cons (quote cons?) (cons (cons (quote shen.hdhd) (cons V4725 (quote ()))) (quote ()))) (quote ())))))) (let ((Placeholder (kl:gensym (quote shen.place)))) (let ((RunOn (kl:shen.syntax V4724 (cons (quote shen.pair) (cons (cons (quote shen.tlhd) (cons V4725 (quote ()))) (cons (cons (quote shen.hdtl) (cons V4725 (quote ()))) (quote ())))) V4726))) (let ((Action (kl:shen.insert-runon RunOn Placeholder (kl:shen.syntax V4723 (cons (quote shen.pair) (cons (cons (quote shen.hdhd) (cons V4725 (quote ()))) (cons (cons (quote shen.hdtl) (cons V4725 (quote ()))) (quote ())))) Placeholder)))) (cons (quote if) (cons Test (cons Action (cons (cons (quote fail) (quote ())) (quote ())))))))))) (export shen.list-stream) (quote shen.list-stream)) 17 | (begin (register-function-arity (quote shen.decons) 1) (define (kl:shen.decons V4728) (cond ((and (pair? V4728) (and (eq? (quote cons) (car V4728)) (and (pair? (cdr V4728)) (and (pair? (cdr (cdr V4728))) (and (null? (car (cdr (cdr V4728)))) (null? (cdr (cdr (cdr V4728))))))))) (cons (car (cdr V4728)) (quote ()))) ((and (pair? V4728) (and (eq? (quote cons) (car V4728)) (and (pair? (cdr V4728)) (and (pair? (cdr (cdr V4728))) (null? (cdr (cdr (cdr V4728)))))))) (cons (car (cdr V4728)) (kl:shen.decons (car (cdr (cdr V4728)))))) (#t V4728))) (export shen.decons) (quote shen.decons)) 18 | (begin (register-function-arity (quote shen.insert-runon) 3) (define (kl:shen.insert-runon V4743 V4744 V4745) (cond ((and (pair? V4745) (and (eq? (quote shen.pair) (car V4745)) (and (pair? (cdr V4745)) (and (pair? (cdr (cdr V4745))) (and (null? (cdr (cdr (cdr V4745)))) (kl:= (car (cdr (cdr V4745))) V4744)))))) V4743) ((pair? V4745) (kl:map (lambda (Z) (kl:shen.insert-runon V4743 V4744 Z)) V4745)) (#t V4745))) (export shen.insert-runon) (quote shen.insert-runon)) 19 | (begin (register-function-arity (quote shen.strip-pathname) 1) (define (kl:shen.strip-pathname V4751) (cond ((kl:not (kl:element? "." V4751)) V4751) ((pair? V4751) (kl:shen.strip-pathname (cdr V4751))) (#t (kl:shen.f_error (quote shen.strip-pathname))))) (export shen.strip-pathname) (quote shen.strip-pathname)) 20 | (begin (register-function-arity (quote shen.recursive_descent) 3) (define (kl:shen.recursive_descent V4755 V4756 V4757) (cond ((pair? V4755) (let ((Test (cons (car V4755) (cons V4756 (quote ()))))) (let ((Action (kl:shen.syntax (cdr V4755) (kl:concat (quote Parse_) (car V4755)) V4757))) (let ((Else (cons (quote fail) (quote ())))) (cons (quote let) (cons (kl:concat (quote Parse_) (car V4755)) (cons Test (cons (cons (quote if) (cons (cons (quote not) (cons (cons (quote =) (cons (cons (quote fail) (quote ())) (cons (kl:concat (quote Parse_) (car V4755)) (quote ())))) (quote ()))) (cons Action (cons Else (quote ()))))) (quote ()))))))))) (#t (kl:shen.f_error (quote shen.recursive_descent))))) (export shen.recursive_descent) (quote shen.recursive_descent)) 21 | (begin (register-function-arity (quote shen.variable-match) 3) (define (kl:shen.variable-match V4761 V4762 V4763) (cond ((pair? V4761) (let ((Test (cons (quote cons?) (cons (cons (quote hd) (cons V4762 (quote ()))) (quote ()))))) (let ((Action (cons (quote let) (cons (kl:concat (quote Parse_) (car V4761)) (cons (cons (quote shen.hdhd) (cons V4762 (quote ()))) (cons (kl:shen.syntax (cdr V4761) (cons (quote shen.pair) (cons (cons (quote shen.tlhd) (cons V4762 (quote ()))) (cons (cons (quote shen.hdtl) (cons V4762 (quote ()))) (quote ())))) V4763) (quote ()))))))) (let ((Else (cons (quote fail) (quote ())))) (cons (quote if) (cons Test (cons Action (cons Else (quote ()))))))))) (#t (kl:shen.f_error (quote shen.variable-match))))) (export shen.variable-match) (quote shen.variable-match)) 22 | (begin (register-function-arity (quote shen.terminal?) 1) (define (kl:shen.terminal? V4773) (cond ((pair? V4773) #f) ((kl:variable? V4773) #f) (#t #t))) (export shen.terminal?) (quote shen.terminal?)) 23 | (begin (register-function-arity (quote shen.jump_stream?) 1) (define (kl:shen.jump_stream? V4779) (cond ((eq? V4779 (quote _)) #t) (#t #f))) (export shen.jump_stream?) (quote shen.jump_stream?)) 24 | (begin (register-function-arity (quote shen.check_stream) 3) (define (kl:shen.check_stream V4783 V4784 V4785) (cond ((pair? V4783) (let ((Test (cons (quote and) (cons (cons (quote cons?) (cons (cons (quote hd) (cons V4784 (quote ()))) (quote ()))) (cons (cons (quote =) (cons (car V4783) (cons (cons (quote shen.hdhd) (cons V4784 (quote ()))) (quote ())))) (quote ())))))) (let ((NewStr (kl:gensym (quote NewStream)))) (let ((Action (cons (quote let) (cons NewStr (cons (cons (quote shen.pair) (cons (cons (quote shen.tlhd) (cons V4784 (quote ()))) (cons (cons (quote shen.hdtl) (cons V4784 (quote ()))) (quote ())))) (cons (kl:shen.syntax (cdr V4783) NewStr V4785) (quote ()))))))) (let ((Else (cons (quote fail) (quote ())))) (cons (quote if) (cons Test (cons Action (cons Else (quote ())))))))))) (#t (kl:shen.f_error (quote shen.check_stream))))) (export shen.check_stream) (quote shen.check_stream)) 25 | (begin (register-function-arity (quote shen.jump_stream) 3) (define (kl:shen.jump_stream V4789 V4790 V4791) (cond ((pair? V4789) (let ((Test (cons (quote cons?) (cons (cons (quote hd) (cons V4790 (quote ()))) (quote ()))))) (let ((Action (kl:shen.syntax (cdr V4789) (cons (quote shen.pair) (cons (cons (quote shen.tlhd) (cons V4790 (quote ()))) (cons (cons (quote shen.hdtl) (cons V4790 (quote ()))) (quote ())))) V4791))) (let ((Else (cons (quote fail) (quote ())))) (cons (quote if) (cons Test (cons Action (cons Else (quote ()))))))))) (#t (kl:shen.f_error (quote shen.jump_stream))))) (export shen.jump_stream) (quote shen.jump_stream)) 26 | (begin (register-function-arity (quote shen.semantics) 1) (define (kl:shen.semantics V4793) (cond ((null? V4793) (quote ())) ((assert-boolean (kl:shen.grammar_symbol? V4793)) (cons (quote shen.hdtl) (cons (kl:concat (quote Parse_) V4793) (quote ())))) ((kl:variable? V4793) (kl:concat (quote Parse_) V4793)) ((pair? V4793) (kl:map (lambda (Z) (kl:shen.semantics Z)) V4793)) (#t V4793))) (export shen.semantics) (quote shen.semantics)) 27 | (begin (register-function-arity (quote shen.pair) 2) (define (kl:shen.pair V4796 V4797) (cons V4796 (cons V4797 (quote ())))) (export shen.pair) (quote shen.pair)) 28 | (begin (register-function-arity (quote shen.hdtl) 1) (define (kl:shen.hdtl V4799) (car (cdr V4799))) (export shen.hdtl) (quote shen.hdtl)) 29 | (begin (register-function-arity (quote shen.hdhd) 1) (define (kl:shen.hdhd V4801) (car (car V4801))) (export shen.hdhd) (quote shen.hdhd)) 30 | (begin (register-function-arity (quote shen.tlhd) 1) (define (kl:shen.tlhd V4803) (cdr (car V4803))) (export shen.tlhd) (quote shen.tlhd)) 31 | (begin (register-function-arity (quote shen.snd-or-fail) 1) (define (kl:shen.snd-or-fail V4811) (cond ((and (pair? V4811) (and (pair? (cdr V4811)) (null? (cdr (cdr V4811))))) (car (cdr V4811))) (#t (kl:fail)))) (export shen.snd-or-fail) (quote shen.snd-or-fail)) 32 | (begin (register-function-arity (quote fail) 0) (define (kl:fail) (quote shen.fail!)) (export fail) (quote fail)) 33 | (begin (register-function-arity (quote ) 1) (define (kl: V4819) (cond ((and (pair? V4819) (and (pair? (cdr V4819)) (null? (cdr (cdr V4819))))) (cons (quote ()) (cons (car V4819) (quote ())))) (#t (kl:fail)))) (export ) (quote )) 34 | (begin (register-function-arity (quote ) 1) (define (kl: V4825) (cond ((and (pair? V4825) (and (pair? (cdr V4825)) (null? (cdr (cdr V4825))))) (cons (car V4825) (cons (quote ()) (quote ())))) (#t (kl:shen.f_error (quote ))))) (export ) (quote )) 35 | --------------------------------------------------------------------------------