module/slib/scainit.scm

   1 ;;; "scainit.scm" Syntax-case macros port to SLIB       -*- Scheme -*-
   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 ;;; From: Harald Hanche-Olsen <hanche@imf.unit.no>
  15
  16 ;;; compat.ss
  17 ;;; Robert Hieb & Kent Dybvig
  18 ;;; 92/06/18
  19
  20 (require 'common-list-functions)        ;to pick up EVERY
  21 (define syncase:andmap comlist:every)
  22
  23 ; In Chez Scheme "(syncase:void)" returns an object that is ignored by the
  24 ; REP loop.  It is returned whenever a "nonspecified" value is specified
  25 ; by the standard.  The following should pick up an appropriate value.
  26
  27 (define syncase:void
  28    (let ((syncase:void-object (if #f #f)))
  29       (lambda () syncase:void-object)))
  30
  31 (define syncase:eval-hook slib:eval)
  32
  33 (define syncase:error-hook slib:error)
  34
  35 (define syncase:new-symbol-hook
  36   (let ((c 0))
  37     (lambda (string)
  38       (set! c (+ c 1))
  39       (string->symbol
  40        (string-append string ":Sca" (number->string c))))))
  41
  42 (define syncase:put-global-definition-hook #f)
  43 (define syncase:get-global-definition-hook #f)
  44 (let ((*macros* '()))
  45   (set! syncase:put-global-definition-hook
  46         (lambda (symbol binding)
  47           (let ((pair (assq symbol *macros*)))
  48             (if pair
  49                 (set-cdr! pair binding)
  50                 (set! *macros* (cons (cons symbol binding) *macros*))))))
  51   (set! syncase:get-global-definition-hook
  52         (lambda (symbol)
  53           (let ((pair (assq symbol *macros*)))
  54             (and pair (cdr pair))))))
  55
  56
  57 ;;;! expand.pp requires list*
  58 (define (syncase:list* . args)
  59   (if (null? args)
  60       '()
  61       (let ((r (reverse args)))
  62         (append (reverse (cdr r))
  63                 (car r)                 ; Last arg
  64                 '()))))                 ; Make sure the last arg is copied
  65
  66 (define syntax-error syncase:error-hook)
  67 (define impl-error slib:error)
  68
  69 (define base:eval slib:eval)
  70 (define syncase:eval base:eval)
  71 (define macro:eval base:eval)
  72 (define syncase:expand #f)
  73 (define macro:expand #f)
  74 (define (syncase:expand-install-hook expand)
  75   (set! syncase:eval (lambda (x) (base:eval (expand x))))
  76   (set! macro:eval syncase:eval)
  77   (set! syncase:expand expand)
  78   (set! macro:expand syncase:expand))
  79 ;;; We Need This for bootstrapping purposes:
  80 (define (syncase:load <pathname>)
  81   (slib:eval-load <pathname> syncase:eval))
  82 (define macro:load syncase:load)
  83
  84 (define syncase:sanity-check #f)
  85 ;;; LOADING THE SYSTEM ITSELF:
  86 (let ((here (lambda (file)
  87               (in-vicinity (library-vicinity) file)))
  88       (scmhere (lambda (file)
  89                  (in-vicinity (library-vicinity)
  90                               (string-append file (scheme-file-suffix))))))
  91   (for-each (lambda (file) (slib:load (here file)))
  92             '("scaoutp"
  93               "scaglob"
  94               "scaexpp"))
  95   (syncase:expand-install-hook expand-syntax)
  96   (syncase:load (here "scamacr"))
  97   (set! syncase:sanity-check
  98         (lambda ()
  99           (syncase:load (scmhere "sca-exp"))
 100           (syncase:expand-install-hook expand-syntax)
 101           (syncase:load (scmhere "sca-macr")))))
 102
 103 (provide 'syntax-case)
 104 (provide 'macro)