;; From reference implementation

;; Return true if lyst has an even # of parameters, and the (alternating)
;; first parameters are "op".  Used to determine if a longer lyst is infix.
;; If passed empty list, returns true (so recursion works correctly).
(define (even-and-op-prefix? op lyst)
   ((null? lyst) #t)
   ((not (pair? lyst)) #f)
   ((not (eq? op (car lyst))) #f) ; fail - operators not the same
   ((not (pair? (cdr lyst)))  #f) ; Wrong # of parameters or improper
   (else (even-and-op-prefix? op (cddr lyst))))) ; recurse.

;; Return true if the lyst is in simple infix format
;; (and thus should be reordered at read time).
(define (simple-infix-list? lyst)
   (pair? lyst)           ; Must have list;  '() doesn't count.
   (pair? (cdr lyst))     ; Must have a second argument.
   (pair? (cddr lyst))    ; Must have a third argument (we check it
                    ; this way for performance)
   (symbol? (cadr lyst))  ; 2nd parameter must be a symbol.
   (even-and-op-prefix? (cadr lyst) (cdr lyst)))) ; true if rest is simple

;; Return alternating parameters in a list (1st, 3rd, 5th, etc.)
(define (alternating-parameters lyst)
  (if (or (null? lyst) (null? (cdr lyst)))
      (cons (car lyst) (alternating-parameters (cddr lyst)))))

;; Not a simple infix list - transform it.  Written as a separate procedure
;; so that future experiments or SRFIs can easily replace just this piece.
(define (transform-mixed-infix lyst)
  (cons 'nfx lyst))

;; Given curly-infix lyst, map it to its final internal format.
(define (process-curly lyst)
   ((not (pair? lyst)) lyst) ; E.G., map {} to ().
   ((null? (cdr lyst)) ; Map {a} to a.
    (car lyst))
   ((and (pair? (cdr lyst)) (null? (cddr lyst))) ; Map {a b} to (a b).
   ((simple-infix-list? lyst) ; Map {a OP b [OP c...]} to (OP a b [c...])
    (cons (cadr lyst) (alternating-parameters lyst)))
   (else  (transform-mixed-infix lyst))))

;; set macro characters
 #\{ (lambda (p c) (process-curly (read-delimited-list #\} p))))
 #\} (lambda (p c) (error '|}-reader| "unexpected #\\}")))

;; test
(print '{a + b})
(print '{a * {b + c}})

;; output
(+ a b)
(* a (+ b c))


No comments:

Post a Comment