Infix syntax

* Infix syntax
@ 2002-10-03 11:26 Daniel Skarda
  2002-10-05  8:55 ` Neil Jerram
  0 siblings, 1 reply; 31+ messages in thread
From: Daniel Skarda @ 2002-10-03 11:26 UTC (permalink / raw)

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)

_______________________________________________
Guile-user mailing list
Guile-user@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-user

^ permalink raw reply	[flat|nested] 31+ messages in thread