shen-ruby 0.1.0

data/shen/release/k_lambda/writer.kl

@@ -0,0 +1,108 @@
+
+"                                                   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 print (V1081)
+ (do
+  (pr (shen-ms-h (cons "~" (cons "S" ())) (@p V1081 shen-skip))
+   (shen-stoutput 0))
+  V1081))
+
+(defun format (V1082 V1083 V1084)
+ (cond ((= true V1082) (intoutput V1083 (@p V1084 ())))
+  ((= false V1082) (intmake-string V1083 (@p V1084 ())))
+  (true (pr (shen-ms-h (explode V1083) V1084) V1082))))
+
+(defun intoutput (V1085 V1086)
+ (pr (shen-ms-h (shen-explode-string V1085) V1086) (shen-stoutput 0)))
+
+(defun interror (V1087 V1088)
+ (simple-error (shen-ms-h (shen-explode-string V1087) V1088)))
+
+(defun intmake-string (V1089 V1090)
+ (shen-ms-h (shen-explode-string V1089) V1090))
+
+(defun shen-ms-h (V1093 V1094)
+ (cond ((= () V1093) "")
+  ((and (cons? V1093)
+    (and (= "~" (hd V1093))
+     (and (cons? (tl V1093)) (= "%" (hd (tl V1093))))))
+   (cn (n->string 10) (shen-ms-h (tl (tl V1093)) V1094)))
+  ((and (cons? V1093)
+    (and (= "~" (hd V1093))
+     (and (cons? (tl V1093))
+      (and (tuple? V1094)
+       (element? (hd (tl V1093)) (cons "A" (cons "S" (cons "R" ()))))))))
+   (cn (shen-ob->str (hd (tl V1093)) (fst V1094))
+    (shen-ms-h (tl (tl V1093)) (snd V1094))))
+  ((cons? V1093) (cn (hd V1093) (shen-ms-h (tl V1093) V1094)))
+  (true (shen-sys-error shen-ms-h))))
+
+(defun shen-ob->str (V1098 V1099)
+ (cond ((= V1099 (fail)) "...")
+  ((= () V1099) (if (= V1098 "R") "()" "[]"))
+  ((= V1099 (vector 0)) "<>")
+  ((cons? V1099)
+   (shen-cn-all
+    (append (if (= V1098 "R") (cons "(" ()) (cons "[" ()))
+     (append (cons (shen-ob->str V1098 (hd V1099)) ())
+      (append
+       (shen-xmapcan (value *maximum-print-sequence-size*)
+        (lambda Z (cons " " (cons (shen-ob->str V1098 Z) ()))) (tl V1099))
+       (if (= V1098 "R") (cons ")" ()) (cons "]" ())))))))
+  ((vector? V1099)
+   (let L (shen-vector->list V1099 1)
+    (let E
+     (tlstr
+      (shen-cn-all
+       (shen-xmapcan (- (value *maximum-print-sequence-size*) 1)
+        (lambda Z
+         (cons " " (cons (shen-ob->str V1098 Z) ())))
+        L)))
+     (let V (cn "<" (cn E ">")) V))))
+  ((and (not (string? V1099)) (absvector? V1099))
+   (trap-error (shen-ob->str "A" ((<-address V1099 0) V1099))
+    (lambda Ignore
+     (let L (shen-vector->list V1099 0)
+      (let E
+       (tlstr
+        (shen-cn-all
+         (shen-xmapcan (- (value *maximum-print-sequence-size*) 1)
+          (lambda Z (cons " " (cons (shen-ob->str V1098 Z) ()))) L)))
+       (let V (cn "<" (cn E ">")) V))))))
+  (true (if (and (= V1098 "A") (string? V1099)) V1099 (str V1099)))))
+
+(defun shen-tuple (V1101)
+ (intmake-string "(@p ~S ~S)" (@p (fst V1101) (@p (snd V1101) ()))))
+
+(defun shen-cn-all (V1102)
+ (cond ((= () V1102) "")
+  ((cons? V1102) (cn (hd V1102) (shen-cn-all (tl V1102))))
+  (true (shen-sys-error shen-cn-all))))
+
+(defun shen-xmapcan (V1115 V1116 V1117)
+ (cond ((= () V1117) ()) ((= 0 V1115) (cons "... etc" ()))
+  ((cons? V1117)
+   (append (V1116 (hd V1117)) (shen-xmapcan (- V1115 1) V1116 (tl V1117))))
+  (true (cons " |" (V1116 V1117)))))
+
+(defun shen-vector->list (V1118 V1119) (shen-vector->listh V1118 V1119 ()))
+
+(defun shen-vector->listh (V1120 V1121 V1122)
+ (let Y (trap-error (<-address V1120 V1121) (lambda E shen-out-of-range))
+  (if (= Y shen-out-of-range) (reverse V1122)
+   (shen-vector->listh V1120 (+ V1121 1) (cons Y V1122)))))
+

data/shen/release/k_lambda/yacc.kl

@@ -0,0 +1,280 @@
+
+"                                                   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 shen-yacc (V293)
+ (cond
+  ((and (cons? V293) (and (= defcc (hd V293)) (cons? (tl V293))))
+   (shen-yacc->shen (hd (tl V293)) (tl (tl V293))
+    (shen-extract-segvars (tl (tl V293)))))
+  (true (shen-sys-error shen-yacc))))
+
+(defun shen-extract-segvars (V298)
+ (cond ((shen-segvar? V298) (cons V298 ()))
+  ((cons? V298)
+   (union (shen-extract-segvars (hd V298)) (shen-extract-segvars (tl V298))))
+  (true ())))
+
+(defun shen-yacc->shen (V299 V300 V301)
+ (let Main
+  (cons define
+   (cons V299
+    (shen-yacc_cases
+     (map (lambda V302 (shen-cc_body V302)) (shen-split_cc_rules V300 ())))))
+  (if (empty? V301) Main
+   (cons package
+    (cons null
+     (cons () (cons Main (map (lambda V303 (shen-segdef V303)) V301))))))))
+
+(defun shen-segdef (V304)
+ (cons define
+  (cons V304
+   (cons (cons @p (cons In (cons Out ())))
+    (cons Continuation
+     (cons ->
+      (cons
+       (cons let
+        (cons Continue
+         (cons
+          (cons Continuation
+           (cons (cons reverse (cons Out ()))
+            (cons (cons @p (cons In (cons () ()))) ())))
+          (cons
+           (cons if
+            (cons
+             (cons and
+              (cons (cons = (cons Continue (cons (cons fail ()) ())))
+               (cons (cons cons? (cons In ())) ())))
+             (cons
+              (cons V304
+               (cons
+                (cons @p
+                 (cons (cons tl (cons In ()))
+                  (cons
+                   (cons cons (cons (cons hd (cons In ())) (cons Out ())))
+                   ())))
+                (cons Continuation ())))
+              (cons Continue ()))))
+           ()))))
+       ())))))))
+
+(defun shen-yacc_cases (V305)
+ (append (mapcan (lambda Case (cons Stream (cons <- (cons Case ())))) V305)
+  (cons _ (cons -> (cons (cons fail ()) ())))))
+
+(defun shen-first_n (V310 V311)
+ (cond ((= 0 V310) ()) ((= () V311) ())
+  ((cons? V311) (cons (hd V311) (shen-first_n (- V310 1) (tl V311))))
+  (true (shen-sys-error shen-first_n))))
+
+(defun shen-split_cc_rules (V312 V313)
+ (cond ((and (= () V312) (= () V313)) ())
+  ((= () V312) (cons (shen-split_cc_rule (reverse V313) ()) ()))
+  ((and (cons? V312) (= ; (hd V312)))
+   (cons (shen-split_cc_rule (reverse V313) ())
+    (shen-split_cc_rules (tl V312) ())))
+  ((cons? V312) (shen-split_cc_rules (tl V312) (cons (hd V312) V313)))
+  (true (shen-sys-error shen-split_cc_rules))))
+
+(defun shen-split_cc_rule (V314 V315)
+ (cond
+  ((and (cons? V314)
+    (and (= := (hd V314))
+     (and (cons? (tl V314)) (= () (tl (tl V314))))))
+   (cons (reverse V315) (tl V314)))
+  ((and (cons? V314) (= := (hd V314)))
+   (cons (reverse V315) (cons (shen-cons_form (tl V314)) ())))
+  ((= () V314)
+   (do (intoutput "warning: " ())
+    (do (map (lambda X (intoutput "~A " (@p X ()))) (reverse V315))
+     (do (intoutput "has no semantics.~%" ())
+      (shen-split_cc_rule
+       (cons := (cons (shen-default_semantics (reverse V315)) ())) V315)))))
+  ((cons? V314) (shen-split_cc_rule (tl V314) (cons (hd V314) V315)))
+  (true (shen-sys-error shen-split_cc_rule))))
+
+(defun shen-default_semantics (V316)
+ (cond ((= () V316) ())
+  ((and (cons? V316) (shen-grammar_symbol? (hd V316)))
+   (let PS (cons snd (cons (concat Parse_ (hd V316)) ()))
+    (if (empty? (tl V316)) PS
+     (cons append (cons PS (cons (shen-default_semantics (tl V316)) ()))))))
+  ((cons? V316)
+   (cons cons (cons (hd V316) (cons (shen-default_semantics (tl V316)) ()))))
+  (true (shen-sys-error shen-default_semantics))))
+
+(defun shen-cc_body (V317)
+ (cond
+  ((and (cons? V317) (and (cons? (tl V317)) (= () (tl (tl V317)))))
+   (shen-syntax (hd V317) Stream (hd (tl V317))))
+  (true (shen-sys-error shen-cc_body))))
+
+(defun shen-syntax (V318 V319 V320)
+ (cond
+  ((= () V318)
+   (cons shen-reassemble
+    (cons (cons fst (cons V319 ())) (cons (shen-semantics V320) ()))))
+  ((cons? V318)
+   (if (shen-grammar_symbol? (hd V318)) (shen-recursive_descent V318 V319 V320)
+    (if (shen-segvar? (hd V318)) (shen-segment-match V318 V319 V320)
+     (if (shen-terminal? (hd V318)) (shen-check_stream V318 V319 V320)
+      (if (shen-jump_stream? (hd V318)) (shen-jump_stream V318 V319 V320)
+       (if (shen-list_stream? (hd V318))
+        (shen-list_stream (shen-decons (hd V318)) (tl V318) V319 V320)
+        (interror "~A is not legal syntax~%" (@p (hd V318) ()))))))))
+  (true (shen-sys-error shen-syntax))))
+
+(defun shen-list_stream? (V329) (cond ((cons? V329) true) (true false)))
+
+(defun shen-decons (V330)
+ (cond
+  ((and (cons? V330)
+    (and (= cons (hd V330))
+     (and (cons? (tl V330))
+      (and (cons? (tl (tl V330))) (= () (tl (tl (tl V330))))))))
+   (cons (hd (tl V330)) (shen-decons (hd (tl (tl V330))))))
+  (true V330)))
+
+(defun shen-list_stream (V331 V332 V333 V334)
+ (let Test
+  (cons and
+   (cons (cons cons? (cons (cons fst (cons V333 ())) ()))
+    (cons
+     (cons cons? (cons (cons hd (cons (cons fst (cons V333 ())) ())) ()))
+     ())))
+  (let Action
+   (cons shen-snd-or-fail
+    (cons
+     (shen-syntax V331
+      (cons shen-reassemble
+       (cons (cons hd (cons (cons fst (cons V333 ())) ()))
+        (cons (cons snd (cons V333 ())) ())))
+      (cons shen-leave!
+       (cons
+        (shen-syntax V332
+         (cons shen-reassemble
+          (cons (cons tl (cons (cons fst (cons V333 ())) ()))
+           (cons (cons snd (cons V333 ())) ())))
+         V334)
+        ())))
+     ()))
+   (let Else (cons fail ())
+    (cons if (cons Test (cons Action (cons Else ()))))))))
+
+(defun shen-snd-or-fail (V341) (cond ((tuple? V341) (snd V341)) (true (fail))))
+
+(defun shen-grammar_symbol? (V342)
+ (and (symbol? V342)
+  (let Cs (explode V342)
+   (and (= (hd Cs) "<") (= (hd (reverse Cs)) ">")))))
+
+(defun shen-recursive_descent (V343 V344 V345)
+ (cond
+  ((cons? V343)
+   (let Test (cons (hd V343) (cons V344 ()))
+    (let Action (shen-syntax (tl V343) (concat Parse_ (hd V343)) V345)
+     (let Else (cons fail ())
+      (cons let
+       (cons (concat Parse_ (hd V343))
+        (cons Test
+         (cons
+          (cons if
+           (cons
+            (cons not
+             (cons
+              (cons =
+               (cons (cons fail ()) (cons (concat Parse_ (hd V343)) ())))
+              ()))
+            (cons Action (cons Else ()))))
+          ()))))))))
+  (true (shen-sys-error shen-recursive_descent))))
+
+(defun shen-segvar? (V346) (and (symbol? V346) (= (hd (explode V346)) "?")))
+
+(defun shen-segment-match (V347 V348 V349)
+ (cond
+  ((cons? V347)
+   (let Continuation
+    (cons lambda
+     (cons (hd V347)
+      (cons
+       (cons lambda
+        (cons Restart (cons (shen-syntax (tl V347) Restart V349) ())))
+       ())))
+    (cons (hd V347) (cons V348 (cons Continuation ())))))
+  (true (shen-sys-error shen-segment-match))))
+
+(defun shen-terminal? (V358)
+ (cond ((cons? V358) false) ((= -*- V358) false) (true true)))
+
+(defun shen-jump_stream? (V363) (cond ((= -*- V363) true) (true false)))
+
+(defun shen-check_stream (V364 V365 V366)
+ (cond
+  ((cons? V364)
+   (let Test
+    (cons and
+     (cons (cons cons? (cons (cons fst (cons V365 ())) ()))
+      (cons
+       (cons =
+        (cons (hd V364)
+         (cons (cons hd (cons (cons fst (cons V365 ())) ())) ())))
+       ())))
+    (let Action
+     (shen-syntax (tl V364)
+      (cons shen-reassemble
+       (cons (cons tl (cons (cons fst (cons V365 ())) ()))
+        (cons (cons snd (cons V365 ())) ())))
+      V366)
+     (let Else (cons fail ())
+      (cons if (cons Test (cons Action (cons Else ()))))))))
+  (true (shen-sys-error shen-check_stream))))
+
+(defun shen-reassemble (V368 V369)
+ (cond ((= V369 (fail)) V369) (true (@p V368 V369))))
+
+(defun shen-jump_stream (V370 V371 V372)
+ (cond
+  ((cons? V370)
+   (let Test (cons cons? (cons (cons fst (cons V371 ())) ()))
+    (let Action
+     (shen-syntax (tl V370)
+      (cons shen-reassemble
+       (cons (cons tl (cons (cons fst (cons V371 ())) ()))
+        (cons (cons snd (cons V371 ())) ())))
+      V372)
+     (let Else (cons fail ())
+      (cons if (cons Test (cons Action (cons Else ()))))))))
+  (true (shen-sys-error shen-jump_stream))))
+
+(defun shen-semantics (V373)
+ (cond
+  ((and (cons? V373)
+    (and (= shen-leave! (hd V373))
+     (and (cons? (tl V373)) (= () (tl (tl V373))))))
+   (hd (tl V373)))
+  ((= () V373) ())
+  ((shen-grammar_symbol? V373) (cons snd (cons (concat Parse_ V373) ())))
+  ((= -o- V373) (cons snd (cons Stream ())))
+  ((= -*- V373) (cons hd (cons (cons fst (cons Stream ())) ())))
+  ((= -s- V373) (cons fst (cons Stream ())))
+  ((cons? V373) (map (lambda V374 (shen-semantics V374)) V373)) (true V373)))
+
+(defun fail () shen-fail!)
+
+(defun <!> (V379)
+ (cond ((tuple? V379) (@p () (fst V379))) (true (shen-sys-error <!>))))
+

data/shen/release/test_programs/Chap13/problems.txt

@@ -0,0 +1,26 @@
+
+[[[y-combinator [/. ADD [/. X [/. Y [if [= X 0] Y [[ADD [-- X]] [++ Y]]]]]]]  2] 3]
+
+
+[[[y-combinator [/. ADD [/. X [/. Y [if [= X 0] Y [[ADD [-- X]] [++ Y]]]]]]] 33] 4]
+
+[[[/. [@p X Y] X] 
+[y-combinator  [/. T 
+[@p [/. A [cases [[/. 1 false] A]
+                 [[/. X [[[/. [@p X Y] Y] T] [-- X]]] A]]]
+    [/. A [cases [[/. 1 true] A]
+                 [[/. X [[[/. [@p X Y] X] T] [-- X]]] A]]]]]]] 6]
+
+
+
+
+
+
+
+
+
+
+
+  
+
+  

data/shen/release/test_programs/README.shen

@@ -0,0 +1,53 @@
+\* 
+
+This is the test harness for Shen.  Assuming your port to Blub is in the directory Platforms/Blub; do the
+following.
+
+(cd "../../Test Programs")
+(load "README.shen")
+(load "tests.shen")
+
+  *\
+
+(package test-harness- [report reset ok passed failed]
+
+(define reset
+  -> (set *passed* (set *failed* 0)))
+
+(defmacro exec-macro
+  [exec Name Expr Prediction] -> [trap-error [let (protect Output) [output "~%~A: ~R = ~S" Name (rcons Expr) Prediction]
+                                                  (protect Result) [time Expr]
+                                                  [if [= (protect Result) Prediction] [passed] [failed (protect Result)]]] 
+                                                      [/. (protect E) [err (protect E)]]])
+                                              
+(define rcons
+  [X | Y] -> [cons (rcons X) (rcons Y)] 
+  X -> X)                                             
+                                              
+(define passed
+  -> (do (trap-error (set *passed* (+ 1 (value *passed*))) (/. E (set *passed* 1)))
+          (print passed)))
+          
+(define failed
+  Result -> (let Fail+ (trap-error (set *failed* (+ 1 (value *failed*))) (/. E (set *failed* 1)))
+                 ShowResult (output "~S returned~%" Result)
+                 (if (y-or-n? "failed; continue?") ok (error "kill"))))  
+
+(define err
+  E -> (error "")  where (= (error-to-string E) "kill")
+  E -> (do (trap-error (set *failed* (+ 1 (value *failed*))) (/. E (set *failed* 1)))
+           (output "~%failed with error ~A~%" (error-to-string E))))
+
+(defmacro report-results-macro
+  [report Name | Tests] -> (let NewTests (create-tests Name Tests)
+                                         [do | NewTests]))
+                                         
+(define create-tests
+  Name [] -> [[results] ok]  
+  Name [Test Prediction | Tests] -> [[exec Name Test Prediction] | (create-tests Name Tests)])                 
+                                         
+(define results
+  -> (let Passed (trap-error (value *passed*) (/. E 0))
+          Failed (trap-error (value *failed*) (/. E 0))
+          Percent (* (/ Passed (+ Passed Failed)) 100)
+          (output "~%passed ... ~A~%failed ...~A~%pass rate ...~A%~%~%" Passed Failed Percent)))     )