mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-11 16:20:19 +02:00
93 lines
3 KiB
Scheme
93 lines
3 KiB
Scheme
;;; "scaoutp.scm" syntax-case output
|
|
;;; Copyright (C) 1992 R. Kent Dybvig
|
|
;;;
|
|
;;; Permission to copy this software, in whole or in part, to use this
|
|
;;; software for any lawful purpose, and to redistribute this software
|
|
;;; is granted subject to the restriction that all copies made of this
|
|
;;; software must include this copyright notice in full. This software
|
|
;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
|
|
;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
|
|
;;; OR FITNESS FOR ANY PARTICULAR PURPOSE. IN NO EVENT SHALL THE
|
|
;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
|
|
;;; NATURE WHATSOEVER.
|
|
|
|
;;; Written by Robert Hieb & Kent Dybvig
|
|
|
|
;;; This file was munged by a simple minded sed script since it left
|
|
;;; its original authors' hands. See syncase.sh for the horrid details.
|
|
|
|
;;; output.ss
|
|
;;; Robert Hieb & Kent Dybvig
|
|
;;; 92/06/18
|
|
|
|
; The output routines can be tailored to feed a specific system or compiler.
|
|
; They are set up here to generate the following subset of standard Scheme:
|
|
|
|
; <expression> :== <application>
|
|
; | <variable>
|
|
; | (set! <variable> <expression>)
|
|
; | (define <variable> <expression>)
|
|
; | (lambda (<variable>*) <expression>)
|
|
; | (lambda <variable> <expression>)
|
|
; | (lambda (<variable>+ . <variable>) <expression>)
|
|
; | (letrec (<binding>+) <expression>)
|
|
; | (if <expression> <expression> <expression>)
|
|
; | (begin <expression> <expression>)
|
|
; | (quote <datum>)
|
|
; <application> :== (<expression>+)
|
|
; <binding> :== (<variable> <expression>)
|
|
; <variable> :== <symbol>
|
|
|
|
; Definitions are generated only at top level.
|
|
|
|
(define syncase:build-application
|
|
(lambda (fun-exp arg-exps)
|
|
`(,fun-exp ,@arg-exps)))
|
|
|
|
(define syncase:build-conditional
|
|
(lambda (test-exp then-exp else-exp)
|
|
`(if ,test-exp ,then-exp ,else-exp)))
|
|
|
|
(define syncase:build-lexical-reference (lambda (var) var))
|
|
|
|
(define syncase:build-lexical-assignment
|
|
(lambda (var exp)
|
|
`(set! ,var ,exp)))
|
|
|
|
(define syncase:build-global-reference (lambda (var) var))
|
|
|
|
(define syncase:build-global-assignment
|
|
(lambda (var exp)
|
|
`(set! ,var ,exp)))
|
|
|
|
(define syncase:build-lambda
|
|
(lambda (vars exp)
|
|
`(lambda ,vars ,exp)))
|
|
|
|
(define syncase:build-improper-lambda
|
|
(lambda (vars var exp)
|
|
`(lambda (,@vars . ,var) ,exp)))
|
|
|
|
(define syncase:build-data
|
|
(lambda (exp)
|
|
`(quote ,exp)))
|
|
|
|
(define syncase:build-identifier
|
|
(lambda (id)
|
|
`(quote ,id)))
|
|
|
|
(define syncase:build-sequence
|
|
(lambda (exps)
|
|
(if (null? (cdr exps))
|
|
(car exps)
|
|
`(begin ,(car exps) ,(syncase:build-sequence (cdr exps))))))
|
|
|
|
(define syncase:build-letrec
|
|
(lambda (vars val-exps body-exp)
|
|
(if (null? vars)
|
|
body-exp
|
|
`(letrec ,(map list vars val-exps) ,body-exp))))
|
|
|
|
(define syncase:build-global-definition
|
|
(lambda (var val)
|
|
`(define ,var ,val)))
|