111 lines
3.8 KiB
ArmAsm
111 lines
3.8 KiB
ArmAsm
|
;
|
|||
|
|
; Following are a few macro definitions which implement constructs in other
|
|||
|
|
; LISPs. They are not intended to be fully compatible to COMMON LISP or any
|
|||
|
|
; other dialect, but are included as examples of how other constructs may
|
|||
|
|
; be implemented, and how Scheme itself can be extended. Note also that the
|
|||
|
|
; examples lack sufficient error checking - feel free to modify, extend,
|
|||
|
|
; and add to any or all of macros for your own purposes.
|
|||
|
|
;
|
|||
|
|
|
|||
|
|
;
|
|||
|
|
; CATCH/THROW - A catch form evaluates some subforms in such a way that, if
|
|||
|
|
; a throw is executed during such evaluation, the evaluation is aborted at
|
|||
|
|
; that point and the catch form returns a value specified by the throw. The
|
|||
|
|
; catch/throw mechanism works even if the throw form is not within the lexical
|
|||
|
|
; scope of the catch.
|
|||
|
|
;
|
|||
|
|
; The tags used for this implementation of catch/throw can be either symbols,
|
|||
|
|
; strings, or numbers. Note the use of fluids and continuations in this
|
|||
|
|
; implementation.
|
|||
|
|
;
|
|||
|
|
|
|||
|
|
(macro catch ;(catch tag expression)
|
|||
|
|
(lambda (e)
|
|||
|
|
(let ((tag (cadr e))
|
|||
|
|
(form (caddr e)))
|
|||
|
|
(cond ((string? tag)
|
|||
|
|
(set! tag (string->symbol tag)))
|
|||
|
|
((number? tag)
|
|||
|
|
(set! tag (implode (explode tag))))
|
|||
|
|
((and (pair? tag) (eq? (car tag) 'quote))
|
|||
|
|
(set! tag (cadr tag))) )
|
|||
|
|
|
|||
|
|
`(call/cc (fluid-lambda (,tag) ,form)))))
|
|||
|
|
|
|||
|
|
|
|||
|
|
(macro throw ;(throw tag value)
|
|||
|
|
(lambda (e)
|
|||
|
|
(let ((tag (cadr e))
|
|||
|
|
(value (caddr e)))
|
|||
|
|
(cond ((string? tag)
|
|||
|
|
(set! tag (string->symbol tag)))
|
|||
|
|
((number? tag)
|
|||
|
|
(set! tag (implode (explode tag))))
|
|||
|
|
((and (pair? tag) (eq? (car tag) 'quote))
|
|||
|
|
(set! tag (cadr tag))) )
|
|||
|
|
|
|||
|
|
`(if (and (fluid-bound? ,tag)
|
|||
|
|
(continuation? (fluid ,tag)))
|
|||
|
|
((fluid ,tag) ,value)
|
|||
|
|
(error "Bad tag on throw" ,tag)))))
|
|||
|
|
|
|||
|
|
;
|
|||
|
|
; PROG - The prog construct allows one to write in a statement-oriented style
|
|||
|
|
; (ala FORTRAN), using go statements that can refer to tags in the body of the
|
|||
|
|
; prog. Modern LISP programming tends to use prog infrequently, however the
|
|||
|
|
; following exercise is a good example of how Scheme may be extended to take
|
|||
|
|
; on characteristics of other LISPs.
|
|||
|
|
;
|
|||
|
|
|
|||
|
|
(macro go
|
|||
|
|
(lambda (form)
|
|||
|
|
(if (integer? (cadr form))
|
|||
|
|
`(implode (explode ,(cadr form)))
|
|||
|
|
;else
|
|||
|
|
(cdr form))))
|
|||
|
|
|
|||
|
|
(macro prog
|
|||
|
|
(lambda (form)
|
|||
|
|
(letrec
|
|||
|
|
((tagstart '())
|
|||
|
|
(buildvars
|
|||
|
|
(lambda (proglist varlist)
|
|||
|
|
(if (null? proglist)
|
|||
|
|
varlist
|
|||
|
|
;else
|
|||
|
|
(buildvars (cdr proglist)
|
|||
|
|
(if (pair? (car proglist))
|
|||
|
|
`(,(car proglist) ,@varlist)
|
|||
|
|
;else
|
|||
|
|
`( (,(car proglist) '()) ,@varlist))))))
|
|||
|
|
(buildtags
|
|||
|
|
(lambda (tbodys)
|
|||
|
|
(if (null? tagstart)
|
|||
|
|
tbodys
|
|||
|
|
;else
|
|||
|
|
(buildtags
|
|||
|
|
`( ( ,(car tagstart)
|
|||
|
|
(lambda () ,@(getbody (cdr tagstart) '())))
|
|||
|
|
,@tbodys)))))
|
|||
|
|
(getbody
|
|||
|
|
(lambda (exprs body)
|
|||
|
|
(cond ((null? exprs)
|
|||
|
|
(set! tagstart '())
|
|||
|
|
(reverse! `((return ()) ,@body)))
|
|||
|
|
((or (symbol? (car exprs)) (integer? (car exprs)))
|
|||
|
|
(set! tagstart
|
|||
|
|
(if (integer? (car exprs))
|
|||
|
|
`(,(implode (explode (car exprs))) ,@(cdr exprs))
|
|||
|
|
;else
|
|||
|
|
exprs))
|
|||
|
|
(reverse! `( (,(car tagstart)) ,@body)))
|
|||
|
|
(else
|
|||
|
|
(getbody (cdr exprs) `(,(car exprs) ,@body)))))))
|
|||
|
|
|
|||
|
|
(let ((letrec_body (getbody (cddr form) '()))
|
|||
|
|
(letrec_vars (reverse! (buildtags (buildvars (cadr form) '())))))
|
|||
|
|
|
|||
|
|
`(call/cc (lambda (return)
|
|||
|
|
(letrec ,letrec_vars ,@letrec_body)))) )))
|
|||
|
|
|
|||
|
|
|