shen-ruby 0.1.0

data/shen/release/k_lambda/sys.kl

@@ -0,0 +1,582 @@
+
+"                                                   The License
+ 
+ The user is free to produce commercial applications with the software, to distribute these applications in source or binary  form, and to charge monies for them as he sees fit and in concordance with the laws of the land subject to the following  license.
+ 
+ 1. The license applies to all the software and all derived software and must appear on such.
+ 2. It is illegal to distribute the software without this license attached to it and use of the software implies agreement 
+    with the license as such. It is illegal for anyone who is not the copyright holder to tamper with or change the license.
+ 3. Neither the names of Lambda Associates or the copyright holder may be used to endorse or promote products built using
+     the software without specific prior written permission from the copyright holder.
+ 4. That possession of this license does not confer on the copyright holder any special contractual obligation towards the    user. That in no event shall the copyright holder be liable for any direct, indirect, incidental, special, exemplary or   consequential damages (including but not limited to procurement of substitute goods or services, loss of use, data, or    profits; or business interruption), however caused and on any theory of liability, whether in contract, strict liability   or tort (including negligence) arising in any way out of the use of the software, even if advised of the possibility of   such damage. 
+5. It is permitted for the user to change the software, for the purpose of improving performance, correcting an error, or    porting to a new platform, and distribute the modified version of Shen (hereafter the modified version) provided the     resulting program conforms in all respects to the Shen standard and is issued under that title. The user must make it clear   with his distribution that he/she is the author of the changes and what these changes are and why. 
+6. Derived versions of this software in whatever form are subject to the same restrictions. In particular it is not          permitted to make derived copies of this software which do not conform to the Shen standard or appear under a different title.
+7. It is permitted to distribute versions of Shen which incorporate libraries, graphics or other facilities which are not    part of the Shen standard.
+
+For an explication of this license see http://www.lambdassociates.org/News/june11/license.htm which explains this license in full."
+
+(defun thaw (V650) (V650))
+
+(defun eval (V651)
+ (let Macroexpand (shen-walk (lambda V652 (macroexpand V652)) V651)
+  (if (shen-packaged? Macroexpand)
+   (map (lambda V653 (shen-eval-without-macros V653))
+    (shen-package-contents Macroexpand))
+   (shen-eval-without-macros Macroexpand))))
+
+(defun shen-eval-without-macros (V654)
+ (eval-kl (shen-elim-define (shen-proc-input+ V654))))
+
+(defun shen-proc-input+ (V655)
+ (cond
+  ((and (cons? V655)
+    (and (= input+ (hd V655))
+     (and (cons? (tl V655))
+      (and (cons? (tl (tl V655))) (= () (tl (tl (tl V655))))))))
+   (cons input+
+    (cons (hd (tl V655)) (cons (shen-rcons_form (hd (tl (tl V655)))) ()))))
+  ((cons? V655) (map (lambda V656 (shen-proc-input+ V656)) V655)) (true V655)))
+
+(defun shen-elim-define (V657)
+ (cond
+  ((and (cons? V657) (and (= define (hd V657)) (cons? (tl V657))))
+   (shen-shen->kl (hd (tl V657)) (tl (tl V657))))
+  ((cons? V657) (map (lambda V658 (shen-elim-define V658)) V657)) (true V657)))
+
+(defun shen-packaged? (V665)
+ (cond
+  ((and (cons? V665)
+    (and (= package (hd V665))
+     (and (cons? (tl V665)) (cons? (tl (tl V665))))))
+   true)
+  (true false)))
+
+(defun external (V666)
+ (trap-error (get V666 shen-external-symbols (value shen-*property-vector*))
+  (lambda E (interror "package ~A has not been used.~%" (@p V666 ())))))
+
+(defun shen-package-contents (V669)
+ (cond
+  ((and (cons? V669)
+    (and (= package (hd V669))
+     (and (cons? (tl V669))
+      (and (= null (hd (tl V669))) (cons? (tl (tl V669)))))))
+   (tl (tl (tl V669))))
+  ((and (cons? V669)
+    (and (= package (hd V669))
+     (and (cons? (tl V669)) (cons? (tl (tl V669))))))
+   (shen-packageh (hd (tl V669)) (hd (tl (tl V669))) Code))
+  (true (shen-sys-error shen-package-contents))))
+
+(defun shen-walk (V670 V671)
+ (cond ((cons? V671) (V670 (map (lambda Z (shen-walk V670 Z)) V671)))
+  (true (V670 V671))))
+
+(defun compile (V672 V673 V674)
+ (let O (V672 (@p V673 ()))
+  (if (or (= (fail) O) (not (empty? (fst O)))) (shen-compile-error O V674)
+   (snd O))))
+
+(defun shen-compile-error (V687 V688)
+ (cond ((= () V688) (fail))
+  ((and (tuple? V687) (cons? (fst V687))) (V688 (fst V687)))
+  (true (interror "syntax error~%" ()))))
+
+(defun <e> (V693)
+ (cond ((tuple? V693) (@p (fst V693) ())) (true (shen-sys-error <e>))))
+
+(defun fail-if (V694 V695) (if (V694 V695) (fail) V695))
+
+(defun @s (V696 V697) (cn V696 V697))
+
+(defun tc? (V702) (value shen-*tc*))
+
+(defun ps (V703)
+ (trap-error (get V703 shen-source (value shen-*property-vector*))
+  (lambda E (interror "~A not found.~%" (@p V703 ())))))
+
+(defun explode (V704)
+ (if (string? V704) (shen-explode-string V704)
+  (explode (intmake-string "~A" (@p V704 ())))))
+
+(defun shen-explode-string (V705)
+ (cond ((= "" V705) ())
+  (true
+   (let S (pos V705 0)
+    (let Ss (tlstr V705)
+     (if (= Ss shen-eos) () (cons S (shen-explode-string Ss))))))))
+
+(defun stinput (V710) (value *stinput*))
+
+(defun shen-+vector? (V711)
+ (and (absvector? V711) (> (<-address V711 0) 0)))
+
+(defun vector (V712)
+ (let Vector (absvector (+ V712 1))
+  (let ZeroStamp (address-> Vector 0 V712)
+   (let Standard
+    (if (= V712 0) ZeroStamp (shen-fillvector ZeroStamp 1 V712 (fail)))
+    Standard))))
+
+(defun shen-fillvector (V713 V714 V715 V716)
+ (cond ((= V715 V714) (address-> V713 V715 V716))
+  (true (shen-fillvector (address-> V713 V714 V716) (+ 1 V714) V715 V716))))
+
+(defun vector? (V718)
+ (and (absvector? V718)
+  (trap-error (>= (<-address V718 0) 0) (lambda E false))))
+
+(defun vector-> (V719 V720 V721)
+ (if (= V720 0) (interror "cannot access 0th element of a vector~%" ())
+  (address-> V719 V720 V721)))
+
+(defun <-vector (V722 V723)
+ (if (= V723 0) (interror "cannot access 0th element of a vector~%" ())
+  (let VectorElement (<-address V722 V723)
+   (if (= VectorElement (fail)) (interror "vector element not found~%" ())
+    VectorElement))))
+
+(defun shen-posint? (V724) (and (integer? V724) (>= V724 0)))
+
+(defun limit (V725) (<-address V725 0))
+
+(defun symbol? (V726)
+ (cond ((or (boolean? V726) (or (number? V726) (string? V726))) false)
+  (true
+   (trap-error (let Explode (explode V726) (shen-analyse-symbol? Explode))
+    (lambda E false)))))
+
+(defun shen-analyse-symbol? (V727)
+ (cond ((cons? V727) (and (shen-alpha? (hd V727)) (shen-alphanums? (tl V727))))
+  (true (shen-sys-error shen-analyse-symbol?))))
+
+(defun shen-alpha? (V728)
+ (element? V728
+  (cons "A"
+   (cons "B"
+    (cons "C"
+     (cons "D"
+      (cons "E"
+       (cons "F"
+        (cons "G"
+         (cons "H"
+          (cons "I"
+           (cons "J"
+            (cons "K"
+             (cons "L"
+              (cons "M"
+               (cons "N"
+                (cons "O"
+                 (cons "P"
+                  (cons "Q"
+                   (cons "R"
+                    (cons "S"
+                     (cons "T"
+                      (cons "U"
+                       (cons "V"
+                        (cons "W"
+                         (cons "X"
+                          (cons "Y"
+                           (cons "Z"
+                            (cons "a"
+                             (cons "b"
+                              (cons "c"
+                               (cons "d"
+                                (cons "e"
+                                 (cons "f"
+                                  (cons "g"
+                                   (cons "h"
+                                    (cons "i"
+                                     (cons "j"
+                                      (cons "k"
+                                       (cons "l"
+                                        (cons "m"
+                                         (cons "n"
+                                          (cons "o"
+                                           (cons "p"
+                                            (cons "q"
+                                             (cons "r"
+                                              (cons "s"
+                                               (cons "t"
+                                                (cons "u"
+                                                 (cons "v"
+                                                  (cons "w"
+                                                   (cons "x"
+                                                    (cons "y"
+                                                     (cons "z"
+                                                      (cons "="
+                                                       (cons "*"
+                                                        (cons "/"
+                                                         (cons "+"
+                                                          (cons "-"
+                                                           (cons "_"
+                                                            (cons "?"
+                                                             (cons "$"
+                                                              (cons "!"
+                                                               (cons "@"
+                                                                (cons "~"
+                                                                 (cons ">"
+                                                                  (cons "<"
+                                                                   (cons "&"
+                                                                    (cons "%"
+                                                                     (cons "{"
+                                                                      (cons "}"
+                                                                       (cons
+                                                                        ":"
+                                                                        (cons
+                                                                         ";"
+                                                                         (cons
+                                                                          "`"
+                                                                          (cons
+                                                                           "#"
+                                                                           (cons
+                                                                            "'"
+                                                                            (cons
+                                                                             "."
+                                                                             ())))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
+
+(defun shen-alphanums? (V729)
+ (cond ((= () V729) true)
+  ((cons? V729) (and (shen-alphanum? (hd V729)) (shen-alphanums? (tl V729))))
+  (true (shen-sys-error shen-alphanums?))))
+
+(defun shen-alphanum? (V730) (or (shen-alpha? V730) (shen-digit? V730)))
+
+(defun shen-digit? (V731)
+ (element? V731
+  (cons "1"
+   (cons "2"
+    (cons "3"
+     (cons "4"
+      (cons "5"
+       (cons "6" (cons "7" (cons "8" (cons "9" (cons "0" ()))))))))))))
+
+(defun variable? (V732)
+ (cond ((or (boolean? V732) (or (number? V732) (string? V732))) false)
+  (true
+   (trap-error (let Explode (explode V732) (shen-analyse-variable? Explode))
+    (lambda E false)))))
+
+(defun shen-analyse-variable? (V733)
+ (cond
+  ((cons? V733) (and (shen-uppercase? (hd V733)) (shen-alphanums? (tl V733))))
+  (true (shen-sys-error shen-analyse-variable?))))
+
+(defun shen-uppercase? (V734)
+ (element? V734
+  (cons "A"
+   (cons "B"
+    (cons "C"
+     (cons "D"
+      (cons "E"
+       (cons "F"
+        (cons "G"
+         (cons "H"
+          (cons "I"
+           (cons "J"
+            (cons "K"
+             (cons "L"
+              (cons "M"
+               (cons "N"
+                (cons "O"
+                 (cons "P"
+                  (cons "Q"
+                   (cons "R"
+                    (cons "S"
+                     (cons "T"
+                      (cons "U"
+                       (cons "V"
+                        (cons "W"
+                         (cons "X"
+                          (cons "Y" (cons "Z" ()))))))))))))))))))))))))))))
+
+(defun gensym (V735)
+ (concat V735 (set shen-*gensym* (+ 1 (value shen-*gensym*)))))
+
+(defun concat (V736 V737) (intern (cn (str V736) (str V737))))
+
+(defun @p (V738 V739)
+ (let Vector (absvector 3)
+  (let Tag (address-> Vector 0 shen-tuple)
+   (let Fst (address-> Vector 1 V738)
+    (let Snd (address-> Vector 2 V739) Vector)))))
+
+(defun fst (V740) (<-address V740 1))
+
+(defun snd (V741) (<-address V741 2))
+
+(defun tuple? (V742)
+ (trap-error (and (absvector? V742) (= shen-tuple (<-address V742 0)))
+  (lambda E false)))
+
+(defun append (V743 V744)
+ (cond ((= () V743) V744)
+  ((cons? V743) (cons (hd V743) (append (tl V743) V744)))
+  (true (shen-sys-error append))))
+
+(defun @v (V745 V746)
+ (let Limit (limit V746)
+  (let NewVector (vector (+ Limit 1))
+   (let X+NewVector (vector-> NewVector 1 V745)
+    (if (= Limit 0) X+NewVector (shen-@v-help V746 1 Limit X+NewVector))))))
+
+(defun shen-@v-help (V747 V748 V749 V750)
+ (cond ((= V749 V748) (shen-copyfromvector V747 V750 V749 (+ V749 1)))
+  (true
+   (shen-@v-help V747 (+ V748 1) V749
+    (shen-copyfromvector V747 V750 V748 (+ V748 1))))))
+
+(defun shen-copyfromvector (V752 V753 V754 V755)
+ (trap-error (vector-> V753 V755 (<-vector V752 V754)) (lambda E V753)))
+
+(defun hdv (V756)
+ (trap-error (<-vector V756 1)
+  (lambda E
+   (interror "hdv needs a non-empty vector as an argument; not ~S~%"
+    (@p V756 ())))))
+
+(defun tlv (V757)
+ (let Limit (limit V757)
+  (if (= Limit 0)
+   (interror "cannot take the tail of the empty vector~%" ())
+   (if (= Limit 1) (vector 0)
+    (let NewVector (vector (- Limit 1))
+     (shen-tlv-help V757 2 Limit (vector (- Limit 1))))))))
+
+(defun shen-tlv-help (V758 V759 V760 V761)
+ (cond ((= V760 V759) (shen-copyfromvector V758 V761 V760 (- V760 1)))
+  (true
+   (shen-tlv-help V758 (+ V759 1) V760
+    (shen-copyfromvector V758 V761 V759 (- V759 1))))))
+
+(defun assoc (V771 V772)
+ (cond ((= () V772) ())
+  ((and (cons? V772) (and (cons? (hd V772)) (= (hd (hd V772)) V771)))
+   (hd V772))
+  ((cons? V772) (assoc V771 (tl V772))) (true (shen-sys-error assoc))))
+
+(defun boolean? (V778)
+ (cond ((= true V778) true) ((= false V778) true) (true false)))
+
+(defun nl (V779)
+ (cond ((= 0 V779) 0) (true (do (intoutput "~%" ()) (nl (- V779 1))))))
+
+(defun difference (V782 V783)
+ (cond ((= () V782) ())
+  ((cons? V782)
+   (if (element? (hd V782) V783) (difference (tl V782) V783)
+    (cons (hd V782) (difference (tl V782) V783))))
+  (true (shen-sys-error difference))))
+
+(defun do (V784 V785) V785)
+
+(defun element? (V794 V795)
+ (cond ((= () V795) false) ((and (cons? V795) (= (hd V795) V794)) true)
+  ((cons? V795) (element? V794 (tl V795))) (true (shen-sys-error element?))))
+
+(defun empty? (V801) (cond ((= () V801) true) (true false)))
+
+(defun fix (V802 V803) (shen-fix-help V802 V803 (V802 V803)))
+
+(defun shen-fix-help (V810 V811 V812)
+ (cond ((= V812 V811) V812) (true (shen-fix-help V810 V812 (V810 V812)))))
+
+(defun put (V814 V815 V816 V817)
+ (let N (hash V814 (limit V817))
+  (let Entry (trap-error (<-vector V817 N) (lambda E ()))
+   (let Change
+    (vector-> V817 N (shen-change-pointer-value V814 V815 V816 Entry)) V816))))
+
+(defun shen-change-pointer-value (V820 V821 V822 V823)
+ (cond ((= () V823) (cons (cons (cons V820 (cons V821 ())) V822) ()))
+  ((and (cons? V823)
+    (and (cons? (hd V823))
+     (and (cons? (hd (hd V823)))
+      (and (cons? (tl (hd (hd V823))))
+       (and (= () (tl (tl (hd (hd V823)))))
+        (and (= (hd (tl (hd (hd V823)))) V821)
+         (= (hd (hd (hd V823))) V820)))))))
+   (cons (cons (hd (hd V823)) V822) (tl V823)))
+  ((cons? V823)
+   (cons (hd V823) (shen-change-pointer-value V820 V821 V822 (tl V823))))
+  (true (shen-sys-error shen-change-pointer-value))))
+
+(defun get (V826 V827 V828)
+ (let N (hash V826 (limit V828))
+  (let Entry
+   (trap-error (<-vector V828 N)
+    (lambda E (interror "pointer not found~%" ())))
+   (let Result (assoc (cons V826 (cons V827 ())) Entry)
+    (if (empty? Result) (interror "value not found~%" ()) (tl Result))))))
+
+(defun hash (V829 V830)
+ (let Hash
+  (shen-mod (sum (map (lambda V831 (string->n V831)) (explode V829))) V830)
+  (if (= 0 Hash) 1 Hash)))
+
+(defun shen-mod (V832 V833)
+ (shen-modh V832 (shen-multiples V832 (cons V833 ()))))
+
+(defun shen-multiples (V834 V835)
+ (cond ((and (cons? V835) (> (hd V835) V834)) (tl V835))
+  ((cons? V835) (shen-multiples V834 (cons (* 2 (hd V835)) V835)))
+  (true (shen-sys-error shen-multiples))))
+
+(defun shen-modh (V838 V839)
+ (cond ((= 0 V838) 0) ((= () V839) V838)
+  ((and (cons? V839) (> (hd V839) V838))
+   (if (empty? (tl V839)) V838 (shen-modh V838 (tl V839))))
+  ((cons? V839) (shen-modh (- V838 (hd V839)) V839))
+  (true (shen-sys-error shen-modh))))
+
+(defun sum (V840)
+ (cond ((= () V840) 0) ((cons? V840) (+ (hd V840) (sum (tl V840))))
+  (true (shen-sys-error sum))))
+
+(defun head (V847)
+ (cond ((cons? V847) (hd V847))
+  (true (interror "head expects a non-empty list" ()))))
+
+(defun tail (V854)
+ (cond ((cons? V854) (tl V854))
+  (true (interror "tail expects a non-empty list" ()))))
+
+(defun hdstr (V855) (pos V855 0))
+
+(defun intersection (V858 V859)
+ (cond ((= () V858) ())
+  ((cons? V858)
+   (if (element? (hd V858) V859) (cons (hd V858) (intersection (tl V858) V859))
+    (intersection (tl V858) V859)))
+  (true (shen-sys-error intersection))))
+
+(defun reverse (V860) (shen-reverse_help V860 ()))
+
+(defun shen-reverse_help (V861 V862)
+ (cond ((= () V861) V862)
+  ((cons? V861) (shen-reverse_help (tl V861) (cons (hd V861) V862)))
+  (true (shen-sys-error shen-reverse_help))))
+
+(defun union (V863 V864)
+ (cond ((= () V863) V864)
+  ((cons? V863)
+   (if (element? (hd V863) V864) (union (tl V863) V864)
+    (cons (hd V863) (union (tl V863) V864))))
+  (true (shen-sys-error union))))
+
+(defun y-or-n? (V865)
+ (let Message (intoutput V865 ())
+  (let Y-or-N (intoutput " (y/n) " ())
+   (let Input (intmake-string "~S" (@p (input) ()))
+    (if (= "y" Input) true
+     (if (= "n" Input) false
+      (do (intoutput "please answer y or n~%" ()) (y-or-n? V865))))))))
+
+(defun not (V866) (if V866 false true))
+
+(defun subst (V875 V876 V877)
+ (cond ((= V877 V876) V875)
+  ((cons? V877) (cons (subst V875 V876 (hd V877)) (subst V875 V876 (tl V877))))
+  (true V877)))
+
+(defun cd (V879)
+ (set *home-directory*
+  (if (= V879 "") "" (intmake-string "~A/" (@p V879 ())))))
+
+(defun map (V880 V881) (shen-map-h V880 V881 ()))
+
+(defun shen-map-h (V884 V885 V886)
+ (cond ((= () V885) (reverse V886))
+  ((cons? V885) (shen-map-h V884 (tl V885) (cons (V884 (hd V885)) V886)))
+  (true (shen-sys-error shen-map-h))))
+
+(defun length (V887) (shen-length-h V887 0))
+
+(defun shen-length-h (V888 V889)
+ (cond ((= () V888) V889) (true (shen-length-h (tl V888) (+ V889 1)))))
+
+(defun occurrences (V898 V899)
+ (cond ((= V899 V898) 1)
+  ((cons? V899) (+ (occurrences V898 (hd V899)) (occurrences V898 (tl V899))))
+  (true 0)))
+
+(defun nth (V907 V908)
+ (cond ((and (= 1 V907) (cons? V908)) (hd V908))
+  ((cons? V908) (nth (- V907 1) (tl V908))) (true (shen-sys-error nth))))
+
+(defun integer? (V909)
+ (and (number? V909)
+  (let Abs (shen-abs V909) (shen-integer-test? Abs (shen-magless Abs 1)))))
+
+(defun shen-abs (V910) (if (> V910 0) V910 (- 0 V910)))
+
+(defun shen-magless (V911 V912)
+ (let Nx2 (* V912 2) (if (> Nx2 V911) V912 (shen-magless V911 Nx2))))
+
+(defun shen-integer-test? (V916 V917)
+ (cond ((= 0 V916) true) ((> 1 V916) false)
+  (true
+   (let Abs-N (- V916 V917)
+    (if (> 0 Abs-N) (integer? V916) (shen-integer-test? Abs-N V917))))))
+
+(defun mapcan (V920 V921)
+ (cond ((= () V921) ())
+  ((cons? V921) (append (V920 (hd V921)) (mapcan V920 (tl V921))))
+  (true (shen-sys-error mapcan))))
+
+(defun read-file-as-bytelist (V922)
+ (let Stream (open file V922 in)
+  (let Byte (read-byte Stream)
+   (let Bytes (shen-read-file-as-bytelist-help Stream Byte ())
+    (let Close (close Stream) (reverse Bytes))))))
+
+(defun shen-read-file-as-bytelist-help (V923 V924 V925)
+ (cond ((= -1 V924) V925)
+  (true
+   (shen-read-file-as-bytelist-help V923 (read-byte V923) (cons V924 V925)))))
+
+(defun read-file-as-string (V926)
+ (let Stream (open file V926 in) (shen-rfas-h Stream (read-byte Stream) "")))
+
+(defun shen-rfas-h (V927 V928 V929)
+ (cond ((= -1 V928) (do (close V927) V929))
+  (true (shen-rfas-h V927 (read-byte V927) (cn V929 (n->string V928))))))
+
+(defun == (V938 V939) (cond ((= V939 V938) true) (true false)))
+
+(defun abort () (simple-error ""))
+
+(defun read () (hd (lineread)))
+
+(defun input () (eval (read)))
+
+(defun input+ (V945 V946)
+ (let Input (read)
+  (let Check (shen-typecheck Input V946)
+   (if (= false Check)
+    (do (intoutput "input is not of type ~R: please re-enter " (@p V946 ()))
+     (input+ : V946))
+    (eval Input)))))
+
+(defun bound? (V947)
+ (and (symbol? V947)
+  (let Val (trap-error (value V947) (lambda E shen-this-symbol-is-unbound))
+   (if (= Val shen-this-symbol-is-unbound) false true))))
+
+(defun shen-string->bytes (V948)
+ (cond ((= "" V948) ())
+  (true (cons (string->n (pos V948 0)) (shen-string->bytes (tlstr V948))))))
+
+(defun maxinferences (V949) (set shen-*maxinferences* V949))
+
+(defun inferences (V954) (value shen-*infs*))
+
+(defun shen-hush (V959)
+ (cond ((= + V959) (set shen-*hush* shen-hushed))
+  ((= - V959) (set shen-*hush* shen-unhushed))
+  (true (interror "'hush' expects a + or a -~%" ()))))
+
+(defun protect (V960) V960)
+
+(defun shen-stoutput (V965) (value *stoutput*))
+