;;; This is an abstraction elimination tool for the Unlambda
;;; programming language.

;;; Added some optimizations
;;; Copyright (C) 2001 by Ørjan Johansen <oerjan@nvg.ntnu.no>

;;; Version 1.92.1 of 1999/10/30
;;; $Id: unlambdaify.scm,v 1.5 1999/11/03 21:01:13 madore Exp $

;;; Copyright (C) 1999 by David A. Madore <david.madore@ens.fr>

;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version
;;; 2 of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty
;;; of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See
;;; the GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

;; Bail out with an error.
(define (error str)
  (display str)
  (newline)
  (quit 1)
  )

(define quit 666)

;; Parse the input file and return the representation of it.
(define (parse input-port)
  (define (gobble-comment)
    (if (not (let ((ch (read-char input-port)))
               (or (eof-object? ch)
                   (eqv? ch #\newline))))
        (gobble-comment)))
  (define (require-char)
    (let ((ch (read-char input-port)))
      (if (eof-object? ch)
          (error "Unexpected end of file")
          ch)))
  (define (parse-number prev)
    (let* ((ch (require-char))
           (n
            (+ (* 10 prev)
              (case ch
                ((#\0) 0) ((#\1) 1) ((#\2) 2) ((#\3) 3) ((#\4) 4)
                ((#\5) 5) ((#\6) 6) ((#\7) 7) ((#\8) 8) ((#\9) 9)))))
      (case (peek-char input-port)
        ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
         (parse-number n))
        (else n))))
  (define (parse-variable)
    (case (peek-char input-port)
      ((#\-)
       (require-char)
       (let ((var (parse-variable)))
         (if (caddr var) (error "Duplicate '-' prefix"))
         ` (, (car var) , (cadr var) #t)))
      ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
       (let* ((n (parse-number 0))
              (var (parse-variable)))
         (if (cadr var) (error "Duplicate number prefix"))
         ` (, (car var) , n , (caddr var))))
      (else ` (, (require-char) #f #f))))
  (case (require-char)
    ((#\`) (let* ((op (parse input-port)) 
                  (arg (parse input-port)))
             `(,op . ,arg)))
;   ((#\space #\ht #\cr #\newline) (parse input-port))
    ((#\space #\newline) (parse input-port)) ; #\ht and #\cr are not standard, shit!
    ((#\#) (gobble-comment) (parse input-port))
    ((#\k #\K) '(k)) ; (lambda (x) (lambda (y) x))
    ((#\s #\S) '(s)) ; (lambda (x) (lambda (y) (lambda (z) ((x z) (y z)))))
    ((#\i #\I) '(i)) ; identity (same as ``skk)
    ((#\v #\V) '(v)) ; return v
    ((#\c #\C) '(c)) ; call/cc
    ((#\d #\D) '(d)) ; delay (special form, force at next call)
    ((#\e #\E) '(e)) ; exit immediately
;; The p function has been replaced by the more general . function
;   ((#\p #\P) '(pr #\*)) ; print an asterisk (same as .*)
    ((#\r #\R) '(pr #\newline)) ; print newline
    ((#\.) `(pr ,(require-char))) ; print given char
    ((#\@) '(rd)) ; read next input char
    ((#\?) `(rc ,(require-char))) ; compare character under reading head
    ((#\|) '(pc)) ; call arg with dot function for current char
    ((#\^) (let* ((var (require-char))
                  (body (parse input-port)))
                  `(lambda ,var ,body)))
    ((#\$) (parse-variable))
    (else (error "Character not understood"))))

;; Unparse (display) an object.
(define (unparse exp)
  (cond
   ((pair? (car exp))
    (write-char #\`) (unparse (car exp)) (unparse (cdr exp)))
   (else (case (car exp)
           ((k) (write-char #\k))
           ((k1) (write-char #\`) (write-char #\k) (unparse (cadr exp)))
           ((s) (write-char #\s))
           ((s1) (write-char #\`) (write-char #\s) (unparse (cadr exp)))
           ((s2) (write-char #\`) (write-char #\`) (write-char #\s)
            (unparse (cadr exp)) (unparse (caddr exp)))
           ((i) (write-char #\i))
           ((v) (write-char #\v))
           ((c) (write-char #\c))
           ((c1) (display "<continuation>"))
           ((d) (write-char #\d))
           ((d1) (write-char #\`) (write-char #\d) (unparse (cadr exp)))
           ((e) (write-char #\e))
           ((pr) (if (eqv? (cadr exp) #\newline) (write-char #\r)
                     (begin (write-char #\.) (write-char (cadr exp)))))
           ((rd) (write-char #\@))
           ((rc) (begin (write-char #\?) (write-char (cadr exp))))
           ((pc) (write-char #\|))
           ((lambda) (write-char #\^) (write-char (cadr exp))
            (unparse (caddr exp)))
           (else
            (if (char? (car exp))
                (begin (write-char #\$) (write-char (car exp)))
                (error "Internal error: unexpected type to unparse!")))))))

;;; Notes on the optimization strategy.
;
;; The most important facts about an expression is:
; - Whether it is _inert_, i.e. its evaluation has no effect; and if so:
; - Whether, when it is applied to another inert expression, the result is
;   still inert, and how many times this can be repeated.  This is
;   connected to the number of arguments a function takes - normally,
;   applying a function has no effect until it has got all its
;   arguments.
;
; It should be safe to declare an expression not inert, even if it is;
; this would merely risk missing some possible optimizations.
;
;; How to assist the optimizer:
;
; For variables, the optimizer can of course not know the number of
; arguments of the functions it would be instantiated with.
; Therefore, the number of arguments may be given explicitly as a
; prefix: $3f if you can guarantee that $f will be a function with at
; least 3 arguments, say.  The optimizer will then be free to assume
; that ``$3f X Y is inert if X and Y are.
;
; Note that $1f is a special case:  It is then assumed that $f cannot
; be d.  This allows the optimizer to simplify `d$f to $f, as below.
;
; Note that prefixes do not appear in the output, and that a ^v will
; match all $..v variables ending with the character v.  The prefixes
; are thus connected with the use of a variable and not its identity.
;
; ;; Inline coding (this section is vaporware so far):
; ;
; ; You may also put '-' as a prefix to a variable $v, which should then
; ; be free (not bound by any corresponding outer ^v.)
; ; The optimizer will then try to put $-v in a position where it is sure
; ; to be evaluated immediately (i.e. not hidden by any d.)  This allows
; ; $v to be replaced by an inline function, so that the definition of the
; ; function is only evaluated once.
;
;; The most important equations used by the optimizer:
;
; X = `d X when X is inert and not d.
; v = `d`k v.
;
; ``s`d`k X `d`k Y = `d`k `X Y;
; ``s`d`k X i = `d X
;
;; Additional data representation:
;
; The following structure is used and returned by the optimizing functions:
; (expout depth applicator)
; - expout is the optimized expression; subexpressions are given as
;   structures.
; - depth is the amount of inertia, or number of arguments;  0 is not
;   inert, 1 is inert (and not d), 2 means that the expression takes 2 arguments
;   to have any effect, etc.  The special case #f means an expression
;   that is inert but may be d.
; - applicator is a function to combine expout with another expression,
;   if expout is used as operator.

(define (remove-variable var ostruct)
  (cond
    ((pair? (caar ostruct))
     (optpair
       (optpair (optimize '(s))
         (remove-variable var (caar ostruct)))
       (remove-variable var (cdar ostruct))))
    ((eqv? (caar ostruct) var)
     (optimize '(i)))
    (else (optpair (optimize '(k)) ostruct))))

(define (inert? op) (not (eqv? 0 (cadr op))))

; The below applicator function is used to combine two optimizations
; when nothing special is known about the operator one.
(define (default-applicator op ar)
  `(( , op . , ar)
    , (if (and (cadr op) (inert? op) (inert? ar))
        (- (cadr op) 1)
        0)
    , default-applicator))

; The most complicated case.
(define (s1-applicator op ar2)
  (call-with-current-continuation (lambda (return)
    (let ((noopt
            (lambda () (return (default-applicator op ar2))))
          (has-oper?
            (lambda (oper ostruct)
              (and (pair? (caar ostruct)) (equal? (caaar ostruct) oper))))
          (ar1 (cdar op)))
      (if (and (inert? ar1) (inert? ar2))
        (let ((a1 (if (has-oper? '(d) ar1) (cdar ar1) ar1))
              (a2 (if (has-oper? '(d) ar2) (cdar ar2) ar2)))
          (let ((x1
                (if (has-oper? '(k) a1) (cdar a1)
                  (if (equal? (car a1) '(v)) a1
                    (noopt)))))
            (if (equal? (car a2) '(i))
              (optpair (optimize '(d)) x1)
              (let ((x2
                    (if (has-oper? '(k) a2) (cdar a2)
                      (if (equal? (car a2) '(v)) a2
                        (noopt)))))
                (optpair (optimize '(d))
                  (optpair (optimize '(k))
                    (optpair x1 x2)))))))
        (noopt))))))

; Combines the optimizations of two expressions into the optimization
; of their application.
(define (optpair op ar) ((caddr op) op ar))

(define (optimize exp) ; -> (expout depth applicator)
  (if (pair? (car exp))
    (let ((op (optimize (car exp)))
          (ar (optimize (cdr exp))))
      (optpair op ar))
    (case (car exp)
      ((s) ` ((s) 3
        , (lambda (op ar1)
            ` ((, op . , ar1) , (if (inert? ar1) 2 0) , s1-applicator))))

      ((k) ` ((k) 3
        , (lambda (op ar1)
            (if (equal? (car ar1) '(v)) ar1
              ` ((, op . , ar1) , (or (cadr ar1) 1)
                 , (lambda (op ar2)
                     (if (inert? ar2) ar1
                       (default-applicator op ar2))))))))
      ((i) ` ((i) 2 , (lambda (op ar) ar)))
      ((v) ` ((v) -1 ; essentially infinity
        , (lambda (op ar)
            (if (inert? ar) op
              (default-applicator op ar)))))
      ((d) ` ((d) #f
        , (lambda (op ar)
            (if (and (cadr ar) (inert? ar))
              ar
              ` (( , op . , ar) 1
                 , (lambda (op ar2)
                     (if (inert? ar2) (optpair ar ar2)
                       (default-applicator op ar2))))))))

      ((c e rd pr rc pc)
        `(, exp 1 ,default-applicator))
      ((lambda)
        (remove-variable (cadr exp) (optimize (caddr exp))))
      (else
        (if (char? (car exp)) ` (, exp , (cadr exp) ,default-applicator)
          (error "Internal error: unexpected type to optimize!"))))))

; Turn an optimization structure back into the basic form
(define (unstruct ostruct)
  (if (pair? (caar ostruct))
    (cons (unstruct (caar ostruct)) (unstruct (cdar ostruct)))
    (car ostruct)))

;; ``Main'' function
(define (main . junk)
  (call-with-current-continuation (lambda (return)
    (set! quit return)
    (unparse (unstruct (optimize (parse (current-input-port)))))
    (newline))))

(define (loop) (main) (loop))