PATTERN EQUATIONS

A functional programming language with one first class data type, 
integers, and one second class data type, functions.  There are
no built-in functions; only an order is defined on the integers.

A function is defined for some range of arguments by an equation
consisting of a pattern, followed by < > or =, followed by an 
expression.  An expression is a numeral, a pattern variable, or 
a function name followed by expressions as actual parameters.

The entire syntax of the language is demonstrated, and the entire
semantics suggested, in this contorted version of the classic 
example, which of course needs the function 'sum' to be defined:

  fib 0 > 0
  fib 1 < 2
  fib n = sum fib sum n -1
              fib sum n -2

So a function can be (partially) defined in terms of an expression 
with equal value or a value that is the immediate successor or 
predecessor.  One same function cannot be defined with patterns of 
different length.  Arguments are evaluated lazily.

There is one layout rule: new equations start in the first column, 
and non-empty continuation lines start with whitespace.  Lexical
elements are always separated by whitespace or line breaks.

The evaluator 'pax' reads a file of equations, and then evaluates
single-line queries from standard input, until an empty line is
encountered.  A query is an expression without pattern variables.

This language is a universal machine equivalent (assuming the use
of unlimited bignums).  Language lawyers are refered to the 
implementation in R4RS/R5RS compliant Scheme for lexical details.


IMPLEMENTATION

(define (pax filename)

  (define *exit-point* #f)
  
  (define (disp . data)
    (or (null? data)
        (begin (display (car data))
               (apply disp (cdr data)))))
               
  (define (error . data)
    (apply disp (cons "Error: " data)) (newline)
    (*exit-point* #f))
    
  (define (split line)
    (define (word!)
      (if (or (null? line) (char-whitespace? (car line))) '()
          (let ((char (car line)))
            (set! line (cdr line))
            (cons char (word!)))))
    (cond ((null? line) '())
          ((char-whitespace? (car line)) (split (cdr line)))
          (else (cons (word!) (split line)))))
  
  (define (lex line)
    (map (lambda (chars)
           (let ((strng (list->string chars)))
             (if (member strng '("=" ">" "<"))
                 (car chars)
                 (if (and (or (memq (car chars) '(#\- #\+))
                              (char-numeric? (car chars)))
                          (let loop ((rest (cdr chars)))
                            (or (null? rest)
                                (and (char-numeric? (car rest))
                                     (loop (cdr rest))))))
                 (string->number strng)
                 (string->symbol strng)))))
         (split line)))
  
  (define (read-line port)
    (let ((char (peek-char port)))
      (if (eof-object? char) char
          (let loop ()
            (let ((char (read-char port)))
              (if (or (eof-object? char) (eq? char #\newline)) '()
                  (cons char (loop))))))))
  
  (define *functions* (list '(#\= dummy-entry-to-allow-add!)))
  
  (define (parse-expr tokens bound-args)
    (define (expr!)
      (if (null? tokens)
          (error "Unexpected end of expression")
          (let ((token (car tokens)))
            (cond 
              ((memq token '(#\> #\< #\=)) 
               (error "Unexpected token: " token))
              ((or (number? token) (memq token bound-args))
               (set! tokens (cdr tokens))
               token)
              (else 
               (let ((function (assq token *functions*)))
                 (set! tokens (cdr tokens))
                 (if function
                     (cons token
                           (let loop ((loops (cadr function)))
                             (if (zero? loops) '()
                                 (cons (expr!) (loop (- loops 1))))))
                     (error "Unknown function: " token))))))))
    (let ((expr (expr!)))
      (if (null? tokens) expr (error "Superfluous tokens"))))
  
  (define (add! lst el)
    (if (null? (cdr lst))
        (set-cdr! lst (list el))
        (add! (cdr lst) el)))
  
  (define (parse-definitions-pass-1 lexed-line)
    (define (split! lexed-line)
      (cond ((null? (cdr lexed-line))
             (error "Unexpected end of definition"))
            ((memq (cadr lexed-line) '(#\> #\< #\=))
             (let ((rest (cdr lexed-line)))
               (set-cdr! lexed-line '())
               rest))
            (else (split! (cdr lexed-line)))))
    (let ((token (car lexed-line)))
      (if (or (number? token) (memq token '(#\> #\< #\=)))
          (error "Unexpected token: " token)
          (let* ((expr-part (split! lexed-line))
                 (entry (list (cdr lexed-line)
                              (case (car expr-part)
                                ((#\>) 1) ((#\<) -1) ((#\=) 0))
                              (cdr expr-part)))
                 (function (assq token *functions*)))
            (if function
                (if (= (length (cdr lexed-line)) (cadr function))
                    (add! function entry)
                    (error "Arity varies for function " token))
                (add! *functions*
                      (list token (length (cdr lexed-line)) entry)))))))
  
  (define (parse-definitions-pass-2)
    (let loop ((functions *functions*))
      (or (null? functions)
          (let inner ((entries (cddar functions)))
            (if (null? entries)
                (loop (cdr functions))
                (begin
                  (set-car! (cddar entries)
                            (parse-expr (caddar entries) (caar entries)))
                  (inner (cdr entries))))))))
  
  (define (eval-expr expr offset-accu)
    (if (number? expr)
        (+ expr offset-accu)
        (let ((function (assq (car expr) *functions*)))
          (let loop ((entries (cddr function)))
            (if (null? entries)
                (error "Function " (car expr) " not defined for all arguments")
                (if (unifies? (caar entries) (cdr expr))
                    (eval-expr (bind-arguments (caddar entries)
                                               (map cons (caar entries) 
                                                         (cdr expr)))
                               (+ offset-accu (cadar entries)))
                    (loop (cdr entries))))))))
  
  (define (unifies? pattern actuals)
    (or (null? pattern)
        (and (or (symbol? (car pattern))
                 (begin (set-car! actuals (eval-expr (car actuals) 0))
                        (= (car pattern) (car actuals))))
             (unifies? (cdr pattern) (cdr actuals)))))
  
  (define (bind-arguments expr bindings)
    (cond ((number? expr) expr)
          ((symbol? expr) (cdr (assq expr bindings)))
          (else (cons (car expr) 
                      (map (lambda (subexpr)
                              (bind-arguments subexpr bindings))
                           (cdr expr))))))
 
  (if (and (char-ready?) 
           (eq? (peek-char) #\newline))
      (read-char)) ; fix SCM behaviour

  (let* ((file (open-input-file filename))
         (ok (call-with-current-continuation
               (lambda (cont)
                 (set! *exit-point* cont)
                 (let loop ((line (read-line file)))
                   (if (eof-object? line) #t
                       (let ((next-line (read-line file)))
                         (if (and (not (eof-object? next-line))
                                  (or (null? next-line)
                                      (char-whitespace? (car next-line))))
                             (loop (append line next-line))
                             (let ((lexed (lex line)))
                               (or (null? lexed)
                                   (parse-definitions-pass-1 lexed))
                               (loop next-line))))))
                 (parse-definitions-pass-2)))))
    (close-input-port file)
    (if ok
        (let loop ((line (read-line (current-input-port))))
          (or (null? line)
              (begin
                (call-with-current-continuation
                  (lambda (cont)
                    (set! *exit-point* cont)
                    (let ((lexed (lex line)))
                      (or (null? lexed)
                          (display (eval-expr (parse-expr lexed '()) 0))))
                    (newline)))
                (loop (read-line (current-input-port)))))))
    (string->symbol "")))

Dirk van Deun (dirk@igwe.vub.ac.be), June 13-16, 1998.