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 contrived version of the classic
example, which of course needs the function 'sum' to be defined:

  fib 0 < 2
  fib 1 > 0
  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 lengths.  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 syntax 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 (and (memq (car chars) '(#\- #\+))
                                   (pair? (cdr 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")
          (list ; handle (pointer) needed for graph reduction
            (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 (cons function 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)
    (if (number? (car expr))
        (car expr)
        (let ((function (caaar expr)))
          (let loop ((entries (cddr function)))
            (if (null? entries)
                (error "Function " (cdaar expr) " not completely defined")
                (if (unifies? (caar entries) (cdar expr) '())
                    (begin 
                      (set-car! expr 
                        (+ (eval-expr (bind-arguments (caddar entries)
                                                      (map cons (caar entries)
                                                                (cdar expr))))
                           (cadar entries)))
                      (car expr))
                    (loop (cdr entries))))))))

  (define (unifies? pattern actuals control-accu)
    (or (null? pattern)
        (and (if (symbol? (car pattern))
                 (let ((seen (assq (car pattern) control-accu)))
                   (or (not seen)
                       (= (eval-expr (car actuals)) 
                          (eval-expr (cdr seen)))))
                 (= (car pattern) (eval-expr (car actuals))))
             (unifies? (cdr pattern) (cdr actuals) 
                       (cons (cons (car pattern) (car actuals)) 
                             control-accu)))))

  (define (bind-arguments expr bindings)
    (cond ((number? (car expr)) expr)
          ((symbol? (car expr)) (cdr (assq (car expr) bindings)))
          (else (list (cons (caar expr)
                            (map (lambda (subexpr)
                                   (bind-arguments subexpr bindings))
                                 (cdar 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 '())))))
                    (newline)))
                (loop (read-line (current-input-port)))))))
    (string->symbol "")))

Dirk van Deun (dirk at igwe.vub.ac.be), June, August, October 1998.