module/slib/scaoutp.scm

   1 ;;; "scaoutp.scm" syntax-case output
   2 ;;; Copyright (C) 1992 R. Kent Dybvig
   3 ;;;
   4 ;;; Permission to copy this software, in whole or in part, to use this
   5 ;;; software for any lawful purpose, and to redistribute this software
   6 ;;; is granted subject to the restriction that all copies made of this
   7 ;;; software must include this copyright notice in full.  This software
   8 ;;; is provided AS IS, with NO WARRANTY, EITHER EXPRESS OR IMPLIED,
   9 ;;; INCLUDING BUT NOT LIMITED TO IMPLIED WARRANTIES OF MERCHANTABILITY
  10 ;;; OR FITNESS FOR ANY PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
  11 ;;; AUTHORS BE LIABLE FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES OF ANY
  12 ;;; NATURE WHATSOEVER.
  13
  14 ;;; Written by Robert Hieb & Kent Dybvig
  15
  16 ;;; This file was munged by a simple minded sed script since it left
  17 ;;; its original authors' hands.  See syncase.sh for the horrid details.
  18
  19 ;;; output.ss
  20 ;;; Robert Hieb & Kent Dybvig
  21 ;;; 92/06/18
  22
  23 ; The output routines can be tailored to feed a specific system or compiler.
  24 ; They are set up here to generate the following subset of standard Scheme:
  25
  26 ;  <expression> :== <application>
  27 ;                |  <variable>
  28 ;                |  (set! <variable> <expression>)
  29 ;                |  (define <variable> <expression>)
  30 ;                |  (lambda (<variable>*) <expression>)
  31 ;                |  (lambda <variable> <expression>)
  32 ;                |  (lambda (<variable>+ . <variable>) <expression>)
  33 ;                |  (letrec (<binding>+) <expression>)
  34 ;                |  (if <expression> <expression> <expression>)
  35 ;                |  (begin <expression> <expression>)
  36 ;                |  (quote <datum>)
  37 ; <application> :== (<expression>+)
  38 ;     <binding> :== (<variable> <expression>)
  39 ;    <variable> :== <symbol>
  40
  41 ; Definitions are generated only at top level.
  42
  43 (define syncase:build-application
  44    (lambda (fun-exp arg-exps)
  45       `(,fun-exp ,@arg-exps)))
  46
  47 (define syncase:build-conditional
  48    (lambda (test-exp then-exp else-exp)
  49       `(if ,test-exp ,then-exp ,else-exp)))
  50
  51 (define syncase:build-lexical-reference (lambda (var) var))
  52
  53 (define syncase:build-lexical-assignment
  54    (lambda (var exp)
  55       `(set! ,var ,exp)))
  56
  57 (define syncase:build-global-reference (lambda (var) var))
  58
  59 (define syncase:build-global-assignment
  60    (lambda (var exp)
  61       `(set! ,var ,exp)))
  62
  63 (define syncase:build-lambda
  64    (lambda (vars exp)
  65       `(lambda ,vars ,exp)))
  66
  67 (define syncase:build-improper-lambda
  68    (lambda (vars var exp)
  69       `(lambda (,@vars . ,var) ,exp)))
  70
  71 (define syncase:build-data
  72    (lambda (exp)
  73       `(quote ,exp)))
  74
  75 (define syncase:build-identifier
  76    (lambda (id)
  77       `(quote ,id)))
  78
  79 (define syncase:build-sequence
  80    (lambda (exps)
  81       (if (null? (cdr exps))
  82           (car exps)
  83           `(begin ,(car exps) ,(syncase:build-sequence (cdr exps))))))
  84
  85 (define syncase:build-letrec
  86    (lambda (vars val-exps body-exp)
  87       (if (null? vars)
  88           body-exp
  89           `(letrec ,(map list vars val-exps) ,body-exp))))
  90
  91 (define syncase:build-global-definition
  92    (lambda (var val)
  93       `(define ,var ,val)))