home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / scainit < prev    next >
Text File  |  1995-01-02  |  3KB  |  88 lines
  1. ;;; "scainit.scm" Syntax-case macros port to SLIB    -*- Scheme -*-
  2. ;;; From: Harald Hanche-Olsen <hanche@imf.unit.no>
  3.  
  4. (require 'common-list-functions)    ;to pick up EVERY
  5. (define syncase:andmap comlist:every)
  6.  
  7. ; In Chez Scheme "(syncase:void)" returns an object that is ignored by the
  8. ; REP loop.  It is returned whenever a "nonspecified" value is specified
  9. ; by the standard.  The following should pick up an appropriate value.
  10.  
  11. (define syncase:void
  12.    (let ((syncase:void-object (if #f #f)))
  13.       (lambda () syncase:void-object)))
  14.  
  15. (define syncase:eval-hook slib:eval)
  16.  
  17. (define syncase:error-hook slib:error)
  18.  
  19. (define syncase:new-symbol-hook
  20.   (let ((c 0))
  21.     (lambda (string)
  22.       (set! c (+ c 1))
  23.       (string->symbol
  24.        (string-append string ":Sca" (number->string c))))))
  25.  
  26. (define syncase:put-global-definition-hook #f)
  27. (define syncase:get-global-definition-hook #f)
  28. (let ((*macros* '()))
  29.   (set! syncase:put-global-definition-hook
  30.     (lambda (symbol binding)
  31.       (let ((pair (assq symbol *macros*)))
  32.         (if pair
  33.         (set-cdr! pair binding)
  34.         (set! *macros* (cons (cons symbol binding) *macros*))))))
  35.   (set! syncase:get-global-definition-hook
  36.     (lambda (symbol)
  37.       (let ((pair (assq symbol *macros*)))
  38.         (and pair (cdr pair))))))
  39.  
  40.  
  41. ;;;! expand.pp requires list*
  42. (define (syncase:list* . args)
  43.   (if (null? args)
  44.       '()
  45.       (let ((r (reverse args)))
  46.     (append (reverse (cdr r))
  47.         (car r)            ; Last arg
  48.         '()))))            ; Make sure the last arg is copied
  49.  
  50. (define syntax-error syncase:error-hook)
  51. (define impl-error slib:error)
  52.  
  53. (define base:eval slib:eval)
  54. (define syncase:eval base:eval)
  55. (define macro:eval base:eval)
  56. (define syncase:expand #f)
  57. (define macro:expand #f)
  58. (define (syncase:expand-install-hook expand)
  59.   (set! syncase:eval (lambda (x) (base:eval (expand x))))
  60.   (set! macro:eval syncase:eval)
  61.   (set! syncase:expand expand)
  62.   (set! macro:expand syncase:expand))
  63. ;;; We Need This for bootstrapping purposes:
  64. (define (syncase:load <pathname>)
  65.   (slib:eval-load <pathname> syncase:eval))
  66. (define macro:load syncase:load)
  67.  
  68. (define syncase:sanity-check #f)
  69. ;;; LOADING THE SYSTEM ITSELF:
  70. (let ((here (lambda (file)
  71.           (in-vicinity (library-vicinity) file)))
  72.       (scmhere (lambda (file)
  73.          (in-vicinity (library-vicinity) file (scheme-file-suffix)))))
  74.   (for-each (lambda (file) (slib:load (here file)))
  75.         '("scaoutp"
  76.           "scaglob"
  77.           "scaexpp"))
  78.   (syncase:expand-install-hook expand-syntax)
  79.   (syncase:load (here "scamacr"))
  80.   (set! syncase:sanity-check
  81.     (lambda ()
  82.       (syncase:load (scmhere "sca-exp"))
  83.       (syncase:expand-install-hook expand-syntax)
  84.       (syncase:load (scmhere "sca-macr")))))
  85.  
  86. (provide 'syntax-case)
  87. (provide 'macro)
  88.