Infix syntax

[Daniel Skarda]

Hello,

  I suppose, that all Guile users on this list are used to special lisp syntax
and are happy with it as I am. Though sometimes it is somewhat awkward to 
convert
mathematical expressions to prefix syntax.

  I revived my module infix.scm, which enrich Guile syntax with expressions.
The module was part of cursed gettext patch. While ago I rewrote the module and
removed dependencies on poor gettext patch.

  To take an advantage of infix syntax, (use-module (ice-9 infix)) and call
(activate-infix). 

  For infix grammar activation I chose read-hash-extend and square brackets:

   #[1 + 2 * 3]

     => 7

Have a nice day,
0.

;--- ice-9/infix.scm  ------------------------------------------------
(define-module (ice-9 infix)
  :use-module (ice-9 optargs))

;    This module adds to Guile simple parser of infix (C-like)
; expressions. Parser is quite simple - you have to keep in mind that
; all operators are scheme symbols - you should write spaces around
; them to separate them from numbers and other symbols (variables,
; "function" names etc). 
;
;    '[', ']' and ',' act as separators - these are exceptions handled
; by infix parser.
;
;    Also note that parser handles C-like expressions, not statements!
; Semicolon ';' start comments

; Examples:
;
;  #[ 1 + 2 * 3 ]
;    -=> 7
;
;  #[ (1 + 2) * 3 ]
;    -=> 9
;
;  #[ cos (PI) ]
;    -=> -1
;
;  #[2 ^ 3 ^ 4]
;    -=> 2417851639229258349412352
;
;  #[(2 ^ 3) ^ 4 ]
;    -=> 4096
;
;  #[6 / 3 / 2]
;    -=> 1
;
;  #[6 / (3 / 2)]
;    -=> 4
;
;  #[sin(1) ^ 2 + cos(1) * cos(1)]
;    -=> 1
;
;  #[ string-length("foo") ]
;    -=> 3 
;
;  #[ modulo(5, 3) ]
;    -=> 2
;
;  (vector-ref a 12)
;    -=> 12
;
;  #[ a[12]^(a[12] - 10) ]
;
;  #[a[12] < 13 && ! (25 * 0 > 1)]
;    -=> #t
;

;--- utils ... --------------------------------------------------------

(define (remove-if-not pred? l)
  (do ((l  l     (cdr l))
       (r  '()   (if (pred? (car l)) (cons (car l) r) r)))
      ((null? l) (reverse! r))))

(define (sloppy-min . lst)
  (let ((nlst (remove-if-not number? lst)))
    (and (pair? nlst) (apply min nlst))))

;--- Simple tokenizer ... ---------------------------------------------

(define (make-read-tokenizer port)
  (define (get-token)
    (let ((ch   (read-char port)))
      (cond
       ((eof-object? ch) the-eof-object)
       ((char-whitespace? ch) (get-token))
       ((memq ch '(#\( #\) #\[ #\] #\,)) ch)
       ((eq? ch #\;) (%read-line) (get-token))
       (else
        (unread-char ch port)
        (let ((sym (read port)))
          (if (symbol? sym)
              (let ((str (symbol->string sym)))
                (cond
                 ((sloppy-min (string-index str #\,)
                              (string-index str #\[)
                              (string-index str #\]))
                  => (lambda (idx)
                       (let ((sub (substring str 0 idx)))
                         (unread-string (substring str idx) port)
                         (or (string->number sub) (string->symbol sub)))))
                 (else sym)))
            sym))))))
  get-token)


;---- utils ... -------------------------------------------------------

(define (char-rparen? x)
  (eq? x #\)))

(define (char-rbracket? x)
  (eq? x #\]))

(define-public (helper-nth o n)
  (cond
   ((vector? o) (vector-ref o n))
   ((pair? o)   (list-ref o n))
   ((string? o) (string-ref o n))
   (else
    (error "Do not know how to handle [] operator"))))

;---- definitions ... -------------------------------------------------

(define infix-ops (make-vector 11))
(define infix-func   (make-vector 11))
(define infix-right (make-vector 11))

(define* (add-infix-operator name priority #:key right func)
  (hashq-set! infix-ops name priority)
  (if right (hashq-set! infix-right name #t))
  (if func (hashq-set! infix-func name func)))

(define prefix-ops (make-vector 11))
(define prefix-func (make-vector 11))

(define* (add-prefix-operator name priority #:key func)
  (hashq-set! prefix-ops name priority)
  (if func (hashq-set! prefix-func name func)))

(define (get-infix-priority op)
  (hashq-ref infix-ops op))

(define (get-infix-func op)
  (hashq-ref infix-func op op))

(define (infix-right-assoc? op)
  (hashq-ref infix-right op))

(define (get-prefix-priority op)
  (hashq-ref prefix-ops op))

(define (get-prefix-func op)
  (hashq-ref prefix-func op op))

;--- stack/op utils ---------------------------------------------------

(define op-priority car)
(define op-func cadr)
(define op-nof cddr)

(define push cons)

(define (make-op func priority nof)
  (cons* priority func nof))

(define (stack-apply-op s op)
  (let ((nof (op-nof op)))
    (cons (cons (op-func op) (reverse! (list-head s nof)))
          (list-tail s nof))))

;---- read infix expr--------------------------------------------------

(define (read-infix-expr get-token end? allow-commas)
  (let loop ((stack  '())
             (ops    '())
             (token  (get-token))
             (unary? #t))

    (define (flush)
      (let flush-loop ((stack  stack)
                       (ops    ops))
        (if (null? ops)
            (car stack)
          (flush-loop (stack-apply-op stack (car ops)) (cdr ops)))))

    (define (continue func priority nof right? unary?)
      (let iloop ((stack        stack)
                  (ops          ops))
        (if (and (pair? ops)
                 (not (and right? (eq? func (op-func (car ops)))))
                 (<= priority (op-priority (car ops))))
            (iloop (stack-apply-op stack (car ops)) (cdr ops))
          (loop stack (push (make-op func priority nof) ops)
                (get-token) unary?))))

    (if unary?
                ; -- "unary" operators --
        (cond
         ((eq? token #\()
          (loop (push (read-infix-expr get-token char-rparen? #f) stack) ops 
(get-token) #f))
         ((eof-object? token) (error "Unexpected EOF"))
         ((end? token) (error (%% "Unexpected ~a" token)))
         (else
          (let ((priority (get-infix-priority token)))
            (if priority
                (continue (get-infix-func token) priority 1 #f #t)
              (loop (push token stack) ops (get-token) #f)))))
        
                ; --- "binary" operators
      (cond 
           ; fcall (x , y , z)
       ((and (eq? token #\() (symbol? (car stack)))
        (loop (push (cons (car stack) (read-infix-expr get-token char-rparen? 
#t)) (cdr stack))
              ops (get-token) #f))
           ; smthng [ index ]
       ((eq? token #\[)
        (loop (push (list helper-nth (car stack)
                          (read-infix-expr get-token char-rbracket? #f))
                    (cdr stack))
              ops (get-token) #f))
           ; smthng , smthng
       ((and allow-commas (eq? token #\,))
        (cons (flush) (loop '() '() (get-token) #t)))
           ; end-of-expr
       ((end? token)
        ((if allow-commas list identity) (flush)))
       ((eof-object? token) (error "Unexpected EOF"))
           ; smthng 'op' smthng
       (else
        (let ((priority (get-infix-priority token)))
          (if priority
              (continue (get-infix-func token) priority 2 (infix-right-assoc? 
token) #t)
            (error (%% "Unknown infix operator ~a" token)))))))))

;--- Utils ...---------------------------------------------------------

(define (infix-string->expr s)
  (read-infix-expr (make-read-tokenizer (open-input-string s)) eof-object? #f))

(define (read-hash-infix _ port)
  (read-infix-expr (make-read-tokenizer port) char-rbracket? #f))

(define (activate-infix)
  (read-hash-extend #\[ read-hash-infix))

;--- Init ... ---------------------------------------------------------

(add-infix-operator '||   5     #:func 'or)
(add-infix-operator '&&  10     #:func 'and)

(add-infix-operator '<   15)
(add-infix-operator '>   15)
(add-infix-operator '==  15     #:func 'eq?)
(add-infix-operator '<=  15)
(add-infix-operator '>=  15)


(add-infix-operator '+   20)
(add-infix-operator '-   20)

(add-infix-operator '*   25)
(add-infix-operator '/   25)
(add-infix-operator '%   25     #:func 'modulo)

(add-infix-operator '^    35    #:func 'expt    #:right #t)
(add-infix-operator '**   35    #:func 'expt    #:right #t)

(add-prefix-operator '! 40      #:func 'not)
(add-prefix-operator '- 40)

;--- Export ... -------------------------------------------------------

(export make-read-tokenizer

        add-infix-operator add-prefix-operator
        read-infix-expr
        infix-string->expr

        activate-infix)