"********************************************************************************** * 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, * * 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 derived version of Shen 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. * * * * 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 www.shenlanguage.org/license.htm which * * explains this license in full. * * * ***************************************************************************************** "(defun macroexpand (V868) (let Y (shen.compose (value *macros*) V868) (if (= V868 Y) V868 (shen.walk (lambda V867 (macroexpand V867)) Y)))) (set *macros* (cons shen.timer-macro (cons shen.cases-macro (cons shen.abs-macro (cons shen.put/get-macro (cons shen.compile-macro (cons shen.datatype-macro (cons shen.let-macro (cons shen.assoc-macro (cons shen.make-string-macro (cons shen.output-macro (cons shen.input-macro (cons shen.error-macro (cons shen.prolog-macro (cons shen.synonyms-macro (cons shen.nl-macro (cons shen.@s-macro (cons shen.defprolog-macro (cons shen.function-macro ()))))))))))))))))))) (defun shen.error-macro (V869) (cond ((and (cons? V869) (and (= error (hd V869)) (cons? (tl V869)))) (cons simple-error (cons (shen.mkstr (hd (tl V869)) (tl (tl V869))) ()))) (true V869))) (defun shen.output-macro (V870) (cond ((and (cons? V870) (and (= output (hd V870)) (cons? (tl V870)))) (cons shen.prhush (cons (shen.mkstr (hd (tl V870)) (tl (tl V870))) (cons (cons stoutput ()) ())))) ((and (cons? V870) (and (= pr (hd V870)) (and (cons? (tl V870)) (= () (tl (tl V870)))))) (cons pr (cons (hd (tl V870)) (cons (cons stoutput ()) ())))) (true V870))) (defun shen.make-string-macro (V871) (cond ((and (cons? V871) (and (= make-string (hd V871)) (cons? (tl V871)))) (shen.mkstr (hd (tl V871)) (tl (tl V871)))) (true V871))) (defun shen.input-macro (V872) (cond ((and (cons? V872) (and (= lineread (hd V872)) (= () (tl V872)))) (cons lineread (cons (cons stinput ()) ()))) ((and (cons? V872) (and (= input (hd V872)) (= () (tl V872)))) (cons input (cons (cons stinput ()) ()))) ((and (cons? V872) (and (= read (hd V872)) (= () (tl V872)))) (cons read (cons (cons stinput ()) ()))) ((and (cons? V872) (and (= input+ (hd V872)) (and (cons? (tl V872)) (= () (tl (tl V872)))))) (cons input+ (cons (hd (tl V872)) (cons (cons stinput ()) ())))) ((and (cons? V872) (and (= read+ (hd V872)) (and (cons? (tl V872)) (= () (tl (tl V872)))))) (cons read+ (cons (hd (tl V872)) (cons (cons stinput ()) ())))) (true V872))) (defun shen.compose (V873 V874) (cond ((= () V873) V874) ((cons? V873) (shen.compose (tl V873) ((hd V873) V874))) (true (shen.sys-error shen.compose)))) (defun shen.compile-macro (V875) (cond ((and (cons? V875) (and (= compile (hd V875)) (and (cons? (tl V875)) (and (cons? (tl (tl V875))) (= () (tl (tl (tl V875)))))))) (cons compile (cons (hd (tl V875)) (cons (hd (tl (tl V875))) (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 V875))) (defun shen.prolog-macro (V876) (cond ((and (cons? V876) (= prolog? (hd V876))) (let F (gensym shen.f) (let Receive (shen.receive-terms (tl V876)) (let PrologDef (eval (append (cons defprolog (cons F ())) (append Receive (append (cons <-- ()) (append (shen.pass-literals (tl V876)) (cons ; ())))))) (let Query (cons F (append Receive (cons (cons shen.start-new-prolog-process ()) (cons (cons freeze (cons true ())) ())))) Query))))) (true V876))) (defun shen.receive-terms (V881) (cond ((= () V881) ()) ((and (cons? V881) (and (cons? (hd V881)) (and (= receive (hd (hd V881))) (and (cons? (tl (hd V881))) (= () (tl (tl (hd V881)))))))) (cons (hd (tl (hd V881))) (shen.receive-terms (tl V881)))) ((cons? V881) (shen.receive-terms (tl V881))) (true (shen.sys-error shen.receive-terms)))) (defun shen.pass-literals (V884) (cond ((= () V884) ()) ((and (cons? V884) (and (cons? (hd V884)) (and (= receive (hd (hd V884))) (and (cons? (tl (hd V884))) (= () (tl (tl (hd V884)))))))) (shen.pass-literals (tl V884))) ((cons? V884) (cons (hd V884) (shen.pass-literals (tl V884)))) (true (shen.sys-error shen.pass-literals)))) (defun shen.defprolog-macro (V885) (cond ((and (cons? V885) (and (= defprolog (hd V885)) (cons? (tl V885)))) (compile shen. (tl V885) (lambda Y (shen.prolog-error (hd (tl V885)) Y)))) (true V885))) (defun shen.datatype-macro (V886) (cond ((and (cons? V886) (and (= datatype (hd V886)) (cons? (tl V886)))) (cons shen.process-datatype (cons (shen.intern-type (hd (tl V886))) (cons (cons compile (cons (cons function (cons shen. ())) (cons (shen.rcons_form (tl (tl V886))) (cons (cons function (cons shen.datatype-error ())) ())))) ())))) (true V886))) (defun shen.intern-type (V887) (intern (cn "type#" (str V887)))) "(defcc := [define | ];) (defcc ; := (append [(protect X) -> (protect X)]);) (defcc -> where ; -> ; <- where ; <- ;) (defcc := [[walk [function macroexpand] ]];)" (defun shen.@s-macro (V888) (cond ((and (cons? V888) (and (= @s (hd V888)) (and (cons? (tl V888)) (and (cons? (tl (tl V888))) (cons? (tl (tl (tl V888)))))))) (cons @s (cons (hd (tl V888)) (cons (shen.@s-macro (cons @s (tl (tl V888)))) ())))) ((and (cons? V888) (and (= @s (hd V888)) (and (cons? (tl V888)) (and (cons? (tl (tl V888))) (and (= () (tl (tl (tl V888)))) (string? (hd (tl V888)))))))) (let E (explode (hd (tl V888))) (if (> (length E) 1) (shen.@s-macro (cons @s (append E (tl (tl V888))))) V888))) (true V888))) (defun shen.synonyms-macro (V889) (cond ((and (cons? V889) (= synonyms (hd V889))) (cons shen.synonyms-help (cons (shen.rcons_form (tl V889)) ()))) (true V889))) (defun shen.nl-macro (V890) (cond ((and (cons? V890) (and (= nl (hd V890)) (= () (tl V890)))) (cons nl (cons 1 ()))) (true V890))) (defun shen.assoc-macro (V891) (cond ((and (cons? V891) (and (cons? (tl V891)) (and (cons? (tl (tl V891))) (and (cons? (tl (tl (tl V891)))) (element? (hd V891) (cons @p (cons @v (cons append (cons and (cons or (cons + (cons * (cons do ()))))))))))))) (cons (hd V891) (cons (hd (tl V891)) (cons (shen.assoc-macro (cons (hd V891) (tl (tl V891)))) ())))) (true V891))) (defun shen.let-macro (V892) (cond ((and (cons? V892) (and (= let (hd V892)) (and (cons? (tl V892)) (and (cons? (tl (tl V892))) (and (cons? (tl (tl (tl V892)))) (cons? (tl (tl (tl (tl V892)))))))))) (cons let (cons (hd (tl V892)) (cons (hd (tl (tl V892))) (cons (shen.let-macro (cons let (tl (tl (tl V892))))) ()))))) (true V892))) (defun shen.abs-macro (V893) (cond ((and (cons? V893) (and (= /. (hd V893)) (and (cons? (tl V893)) (and (cons? (tl (tl V893))) (cons? (tl (tl (tl V893)))))))) (cons lambda (cons (hd (tl V893)) (cons (shen.abs-macro (cons /. (tl (tl V893)))) ())))) ((and (cons? V893) (and (= /. (hd V893)) (and (cons? (tl V893)) (and (cons? (tl (tl V893))) (= () (tl (tl (tl V893)))))))) (cons lambda (tl V893))) (true V893))) (defun shen.cases-macro (V896) (cond ((and (cons? V896) (and (= cases (hd V896)) (and (cons? (tl V896)) (and (= true (hd (tl V896))) (cons? (tl (tl V896))))))) (hd (tl (tl V896)))) ((and (cons? V896) (and (= cases (hd V896)) (and (cons? (tl V896)) (and (cons? (tl (tl V896))) (= () (tl (tl (tl V896)))))))) (cons if (cons (hd (tl V896)) (cons (hd (tl (tl V896))) (cons (cons simple-error (cons "error: cases exhausted" ())) ()))))) ((and (cons? V896) (and (= cases (hd V896)) (and (cons? (tl V896)) (cons? (tl (tl V896)))))) (cons if (cons (hd (tl V896)) (cons (hd (tl (tl V896))) (cons (shen.cases-macro (cons cases (tl (tl (tl V896))))) ()))))) ((and (cons? V896) (and (= cases (hd V896)) (and (cons? (tl V896)) (= () (tl (tl V896)))))) (simple-error "error: odd number of case elements ")) (true V896))) (defun shen.timer-macro (V897) (cond ((and (cons? V897) (and (= time (hd V897)) (and (cons? (tl V897)) (= () (tl (tl V897)))))) (shen.let-macro (cons let (cons Start (cons (cons get-time (cons run ())) (cons Result (cons (hd (tl V897)) (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 " run time: " (cons (cons cn (cons (cons str (cons Time ())) (cons " secs " ()))) ()))) (cons (cons stoutput ()) ()))) (cons Result ())))))))))))))) (true V897))) (defun shen.tuple-up (V898) (cond ((cons? V898) (cons @p (cons (hd V898) (cons (shen.tuple-up (tl V898)) ())))) (true V898))) (defun shen.put/get-macro (V899) (cond ((and (cons? V899) (and (= put (hd V899)) (and (cons? (tl V899)) (and (cons? (tl (tl V899))) (and (cons? (tl (tl (tl V899)))) (= () (tl (tl (tl (tl V899)))))))))) (cons put (cons (hd (tl V899)) (cons (hd (tl (tl V899))) (cons (hd (tl (tl (tl V899)))) (cons (cons value (cons *property-vector* ())) ())))))) ((and (cons? V899) (and (= get (hd V899)) (and (cons? (tl V899)) (and (cons? (tl (tl V899))) (= () (tl (tl (tl V899)))))))) (cons get (cons (hd (tl V899)) (cons (hd (tl (tl V899))) (cons (cons value (cons *property-vector* ())) ()))))) (true V899))) (defun shen.function-macro (V900) (cond ((and (cons? V900) (and (= function (hd V900)) (and (cons? (tl V900)) (= () (tl (tl V900)))))) (shen.function-abstraction (hd (tl V900)) (arity (hd (tl V900))))) (true V900))) (defun shen.function-abstraction (V901 V902) (cond ((= 0 V902) (cons freeze (cons V901 ()))) ((= -1 V902) V901) (true (shen.function-abstraction-help V901 V902 ())))) (defun shen.function-abstraction-help (V903 V904 V905) (cond ((= 0 V904) (cons V903 V905)) (true (let X (gensym V) (cons /. (cons X (cons (shen.function-abstraction-help V903 (- V904 1) (append V905 (cons X ()))) ()))))))) (defun undefmacro (V906) (do (set *macros* (remove V906 (value *macros*))) V906))