home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / XSCHEME2.ZIP / qquote.s < prev    next >
Text File  |  1990-01-02  |  3KB  |  95 lines
  1. ;;; QQUOTE.S  01-14-89 11:34 AM by John Armstrong
  2.  
  3. ;; Expands QUASIQUOTE/UNQUOTE/UNQUOTE according to Rev^3 Report specs.
  4. ;;
  5. ;; This file can be included as is in XSCHEME.INI, or can be incorporated
  6. ;; into MACROS.S, with expander functions anywhere and macros after
  7. ;; after definition of COMPILER-SYNTAX
  8.  
  9. ;;; EXPANDER-FUNCTIONS: compilable under the core XSCHEME, can be evaluated
  10. ;;; independently of MACRO system
  11.  
  12. (define APPEND-ME-SYM (gensym)) ;; must be a gensym to avoid capture in
  13.                 ;; certain (pathological) situations
  14.  
  15. (define QQ-EXPANDER
  16.   (lambda (l)
  17.       (letrec
  18.        (
  19.         (qq-lev 0) ; always >= 0
  20.         (QQ-CAR-CDR
  21.          (lambda (exp)
  22.              (let ((qq-car (qq (car exp)))
  23.                (qq-cdr (qq (cdr exp))))
  24.               (if (and (pair? qq-car)
  25.                    (eq? (car qq-car) append-me-sym))
  26.                   (list 'append (cdr qq-car) qq-cdr)
  27.                   (list 'cons qq-car qq-cdr)))))
  28.         (QQ
  29.          (lambda (exp)
  30.              (cond ((symbol? exp)
  31.                 (list 'quote exp))
  32.                ((vector? exp)
  33.                 (list 'list->vector (qq (vector->list exp))))
  34.                ((atom? exp) ; nil, number or boolean
  35.                 exp)
  36.                ((eq? (car exp) 'quasiquote)
  37.                 (set! qq-lev (1+ qq-lev))
  38.                 (let ((qq-val
  39.                    (if (= qq-lev 1) ; min val after inc
  40.                        ; --> outermost level
  41.                        (qq (cadr exp))
  42.                        (qq-car-cdr exp))))
  43.                  (set! qq-lev (-1+ qq-lev))
  44.                  qq-val))
  45.                ((or (eq? (car exp) 'unquote)
  46.                 (eq? (car exp) 'unquote-splicing))
  47.                 (set! qq-lev (-1+ qq-lev))
  48.                 (let ((qq-val
  49.                    (if (= qq-lev 0) ; min val
  50.                        ; --> outermost level
  51.                        (if (eq? (car exp) 'unquote-splicing)
  52.                        (cons append-me-sym
  53.                          (%expand-macros (cadr exp)))
  54.                        (%expand-macros (cadr exp)))
  55.                        (qq-car-cdr exp))))
  56.                  (set! qq-lev (1+ qq-lev))
  57.                  qq-val))
  58.                (else
  59.                 (qq-car-cdr exp)))))
  60.         )
  61.        (let ((expansion (qq l)))
  62.         (if check-qq-expansion-flag
  63.             (check-qq-expansion expansion)) ; error on failure
  64.         expansion))))
  65.  
  66. (define CHECK-QQ-EXPANSION
  67.   (lambda (exp)
  68.       (cond ((vector? exp)
  69.          (check-qq-expansion (vector->list exp)))
  70.         ((atom? exp)
  71.          #f)
  72.         (else
  73.          (if (eq? (car exp) append-me-sym)
  74.              (error "UNQUOTE-SPLICING in unspliceable position"
  75.                 (list 'unquote-splicing (cdr exp)))
  76.              (or (check-qq-expansion (car exp))
  77.              (check-qq-expansion (cdr exp))))))))
  78.  
  79. (define CHECK-QQ-EXPANSION-FLAG #t) ; do checking
  80.  
  81. (define UNQ-EXPANDER
  82.   (lambda (l) (error "UNQUOTE outside QUASIQUOTE" l)))
  83.  
  84. (define UNQ-SPL-EXPANDER
  85.   (lambda (l) (error "UNQUOTE SPLICING outside QUASIQUOTE" l)))
  86.  
  87. ;;; MACROS: must be evaluated with MACRO system in place
  88.  
  89. (compiler-syntax QUASIQUOTE qq-expander)
  90. (compiler-syntax UNQUOTE unq-expander)
  91. (compiler-syntax UNQUOTE-SPLICING unq-spl-expander)
  92.  
  93. ;;; END
  94.  
  95.