294 lines
11 KiB
Scheme
294 lines
11 KiB
Scheme
; Checking of a LAND* special form


;


; LAND* is a generalized AND: it evaluates a sequence of forms one after another


; till the first one that yields #f; the non#f result of a form can be bound


; to a fresh variable and used in the subsequent forms.


;


; When an ordinary AND is formed of _proper_ boolean expressions:


; (AND E1 E2 ...)


; expression E2, if it gets to be evaluated, knows that E1 has returned non#f.


; Moreover, E2 knows exactly what the result of E1 was  #t  so E2 can use


; this knowledge to its advantage. If E1 however is an _extended_


; boolean expression, E2 can no longer tell which particular non#f


; value E1 has returned. Chances are it took a lot of work to evaluate E1,


; and the produced result (a number, a vector, a string, etc) may be of


; value to E2. Alas, the AND form merely checks that the result is not an #f,


; and throws it away. If E2 needs it, it has to recompute the value again.


; This proposed LAND* special form lets constituent expressions get


; hold of the results of already evaluated expressions, without redoing


; their work.


;


; Syntax:


; LAND* (CLAWS) BODY


;


; where CLAWS is a list of expressions or bindings:


; CLAWS ::= '()  (cons CLAW CLAWS)


; Every element of the CLAWS list, a CLAW, must be one of the following:


; (VARIABLE EXPRESSION)


; or


; (EXPRESSION)


; or


; BOUNDVARIABLE


; These CLAWS are evaluated in the strict lefttoright order. For each


; CLAW, the EXPRESSION part is evaluated first (or BOUNDVARIABLE is looked up).


; If the result is #f, LAND* immediately returns #f, thus disregarding the rest


; of the CLAWS and the BODY. If the EXPRESSION evaluates to not#f, and


; the CLAW is of the form


; (VARIABLE EXPRESSION)


; the EXPRESSION's value is bound to a freshly made VARIABLE. The VARIABLE is


; available for _the rest_ of the CLAWS, and the BODY. As usual, all


; VARIABLEs must be unique (like in let*).


;


; Thus LAND* is a sort of crossbreed between LET* and AND.


;


; Denotation semantics:


;


; Eval[ (LAND* (CLAW1 ...) BODY), Env] =


; EvalClaw[ CLAW1, Env ] andalso


; Eval[ (LAND* ( ...) BODY), ExtClawEnv[ CLAW1, Env]]


;


; Eval[ (LAND* (CLAW) ), Env] = EvalClaw[ CLAW, Env ]


; Eval[ (LAND* () FORM1 ...), Env] = Eval[ (BEGIN FORM1 ...), Env ]


; Eval[ (LAND* () ), Env] = #t


;


; EvalClaw[ BOUNDVARIABLE, Env ] = Eval[ BOUNDVARIABLE, Env ]


; EvalClaw[ (EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]


; EvalClaw[ (VARIABLE EXPRESSION), Env ] = Eval[ EXPRESSION, Env ]


;


; ExtClawEnv[ BOUNDVARIABLE, Env ] = Env


; ExtClawEnv[ (EXPRESSION), Env ] = EnvAfterEval[ EXPRESSION, Env ]


; ExtClawEnv[ (VARIABLE EXPRESSION), Env ] =


; ExtendEnv[ EnvAfterEval[ EXPRESSION, Env ],


; VARIABLE boundto Eval[ EXPRESSION, Env ]]


;


;


; If one has a Scheme interpreter written in Prolog/ML/Haskell, he can


; implement the above semantics right away. Within Scheme, it is trivial to


; code LAND* with R4RS "definesyntax". Alas, Gambit does not have this


; facility. So this implementation uses macros instead.


;


; The following LAND* macro will convert a LAND* expression into a "tree" of


; AND and LET expressions. For example,


; (LAND* ((mylist (computelist)) ((not (null? mylist))))


; (dosomething mylist))


; is transformed into


; (and (let ((mylist (computelist)))


; (and mylist (not (null? mylist)) (begin (dosomething mylist)))))


;


; I must admit the LAND* macro is written in a pathetic antifunctional style.


; To my excuse, the macro's goal is a syntactic transformation of source


; code, that is, performing a rewriting. IMHO, rewriting kind of suggests


; mutating.


;


; Sample applications:


;


; The following piece of code (from my treap package)


; (let ((newroot (node:dispatchonkey root key ...)))


; (if newroot (set! root newroot)))


; could be elegantly rewritten as


; (land* ((newroot (node:dispatchonkey root key ...)))


; (set! root newroot))


;


; A very common application of land* is looking up a value


; associated with a given key in an assoc list, returning #f in case of a


; lookup failure:


;


; ; Standard implementation


; (define (lookup key alist)


; (let ((foundassoc (assq key alist)))


; (and foundassoc (cdr foundassoc))))


;


; ; A more elegant solution


; (define (lookup key alist)


; (cdr (or (assq key alist) '(#f . #f))))


;


; ; An implementation which is just as graceful as the latter


; ; and just as efficient as the former:


; (define (lookup key alist)


; (land* ((x (assq key alist))) (cdr x)))


;


; Generalized cond:


;


; (or


; (land* (bindingscond1) body1)


; (land* (bindingscond2) body2)


; (begin elseclause))


;


; Unlike => (cond's send), LAND* applies beyond cond. LAND* can also be used


; to generalize cond, as => is limited to sending of only a single value;


; LAND* allows as many bindings as necessary (which are performed in sequence)


;


; (or


; (land* ((c (readchar)) ((not (eofobject? c))))


; (stringset! somestr i c) (++! i))


; (begin (doprocesseof)))


;


; Another concept LAND* is reminiscent of is programming with guards:


; a LAND* form can be considered a sequence of _guarded_ expressions.


; In a regular program, forms may produce results, bind them to variables


; and let other forms use these results. LAND* differs in that it checks


; to make sure that every produced result "makes sense" (that is, not an #f).


; The first "failure" triggers the guard and aborts the rest of the


; sequence (which presumably would not make any sense to execute anyway).


;


; $Id: vlandgambit.scm,v 1.1 1998/12/28 23:54:29 srfimgr Exp $






(library (SRFI2)


(export land*)


(import (ikarus))


(definesyntax land*


(lambda (x)


(define freeid (car (generatetemporaries '(_))))


(define (boundidentifier? x)


(and (identifier? x)


(not


(freeidentifier=? x


(datum>syntax freeid (syntax>datum x))))))


(syntaxcase x ()


[(_ ()) #t]


[(_ (claws ...) b b* ...)


#'(land* (claws ... (tmp (begin b b* ...))))]


[(_ ([var expr])) #'expr]


[(_ ([expr])) #'expr]


[(_ (var))


(if (boundidentifier? #'var)


#'var


(syntaxerror #'var "var is unbound in land* clause"))]


[(_ ([var expr] claws ...)) (identifier? #'var)


#'(cond


[expr => (lambda (var) (land* (claws ...)))]


[else #f])]


[(_ ([expr] claws ...))


#'(and expr (land* (claws ...)))]


[(_ (var claws ...))


(if (boundidentifier? #'var)


#'(and var (land* (claws ...)))


(syntaxerror #'var "var is unbound in land*


clause"))]))))




#!eof


#


(definemacro (LAND* claws . body)


(let* ((newvars '()) (result (cons 'and '())) (growthpoint result))




; We need a way to report a syntax error


; the following is how Gambit compiler does it...


(##definemacro (cterrorsyntax msg . args)


`(##signal '##signal.syntaxerror #t ,msg ,@args))




(define (andjoin! clause)


(let ((prevpoint growthpoint) (clausecell (cons clause '())))


(setcdr! growthpoint clausecell)


(set! growthpoint clausecell)))




(if (not (list? claws))


(cterrorsyntax "bindings must be a list " bindings))


(foreach


(lambda (claw)


(cond


((symbol? claw) ; BOUNDVARIABLE form


(andjoin! claw))


((and (pair? claw) (null? (cdr claw))) ; (EXPRESSION) form


(andjoin! (car claw)))


; (VARIABLE EXPRESSION) form


((and (pair? claw) (symbol? (car claw))


(pair? (cdr claw)) (null? (cddr claw)))


(let* ((var (car claw)) (varcell (cons var '())))


(if (memq var newvars)


(cterrorsyntax "duplicate variable " var " in the bindings"))


(set! newvars (cons var newvars))


(setcdr! growthpoint `((LET (,claw) (AND . ,varcell))))


(set! growthpoint varcell)))


(else


(cterrorsyntax "An illformed binding in a syntactic form land* "


claw))


))


claws)


(if (not (null? body))


(andjoin! `(begin ,@body)))


result))


#




; Validation tests


(##include "myenv.scm")


(##include "catcherror.scm")




(display "\nValidating LAND*...\n\n")




; make sure that the 'FORM' gave upon evaluation the


; EXPECTEDRESULT


(definemacro (expect form expectedresult)


`(begin


(display "evaluating ")


(write ',form)


(let ((realresult (eval ',form)))


(if (equal? realresult ,expectedresult)


(cout "... gave the expected result: " realresult nl)


(error "... yielded: " realresult


" which differs from the expected result: " ,expectedresult)


))))




; Check to see that 'form' has indeed a wrong syntax


(definemacro (mustbeasyntaxerror form)


`(callwithcurrentcontinuation


(lambda (k)


(##catchsignal '##signal.syntaxerror


(lambda x


(display "catching a syntax error: ") (display x) (newline)


(k #f))


(lambda ()


(eval ',form)


(error "No syntax error detected, unexpectedly"))))))




(expect (land* () 1) 1)


(expect (land* () 1 2) 2)


(expect (land* () ) #t)




(expect (let ((x #f)) (land* (x))) #f)


(expect (let ((x 1)) (land* (x))) 1)


(expect (land* ((x #f)) ) #f)


(expect (land* ((x 1)) ) 1)


(mustbeasyntaxerror (land* ( #f (x 1))) )


(expect (land* ( (#f) (x 1)) ) #f)


(mustbeasyntaxerror (land* (2 (x 1))) )


(expect (land* ( (2) (x 1)) ) 1)


(expect (land* ( (x 1) (2)) ) 2)


(expect (let ((x #f)) (land* (x) x)) #f)


(expect (let ((x "")) (land* (x) x)) "")


(expect (let ((x "")) (land* (x) )) "")


(expect (let ((x 1)) (land* (x) (+ x 1))) 2)


(expect (let ((x #f)) (land* (x) (+ x 1))) #f)


(expect (let ((x 1)) (land* (((positive? x))) (+ x 1))) 2)


(expect (let ((x 1)) (land* (((positive? x))) )) #t)


(expect (let ((x 0)) (land* (((positive? x))) (+ x 1))) #f)


(expect (let ((x 1)) (land* (((positive? x)) (x (+ x 1))) (+ x 1))) 3)


(mustbeasyntaxerror


(let ((x 1)) (land* (((positive? x)) (x (+ x 1)) (x (+ x 1))) (+ x 1)))


)




(expect (let ((x 1)) (land* (x ((positive? x))) (+ x 1))) 2)


(expect (let ((x 1)) (land* ( ((begin x)) ((positive? x))) (+ x 1))) 2)


(expect (let ((x 0)) (land* (x ((positive? x))) (+ x 1))) #f)


(expect (let ((x #f)) (land* (x ((positive? x))) (+ x 1))) #f)


(expect (let ((x #f)) (land* ( ((begin x)) ((positive? x))) (+ x 1))) #f)




(expect (let ((x 1)) (land* (x (y ( x 1)) ((positive? y))) (/ x y))) #f)


(expect (let ((x 0)) (land* (x (y ( x 1)) ((positive? y))) (/ x y))) #f)


(expect (let ((x #f)) (land* (x (y ( x 1)) ((positive? y))) (/ x y))) #f)


(expect (let ((x 3)) (land* (x (y ( x 1)) ((positive? y))) (/ x y))) 3/2)




(display "\nAll tests passed\n")




(let


((adefinition


'(define (bbb)


(LAND* ((mylist (computelist)) acondition ((not (null? mylist)))


(mylisttail (cdr mylist)))


(dosomething mylisttail)))))


(cout "The result of compiling of\n"


(lambda () (pp adefinition)) "\nis the following\n")


(eval adefinition)


(pp bbb)


)
