xpe.ann

($specialize-fundef $check-function $pe-exp $eval-exp)
(
($specialize-fundef
  (ann-prog)
  (conf)
  =
  (ifd (null? conf)
       (static (car (car ann-prog)))
       (rcall $check-function
              ((car ann-prog)
               (car (cdr (cdr ann-prog)))
               (car (cdr ann-prog)))
              ((car conf) (cdr conf)))))

($check-function
  (rf s-prog d-prog)
  (fname svv)
  =
  (ifs (null? rf)
       (static '())
       (call $check-function$/1
             ((car rf) d-prog s-prog rf)
             (fname svv))))

($check-function$/1
  ($1 d-prog s-prog rf)
  (fname svv)
  =
  (ifd (eq? fname (static $1))
       (call $gen-res-fundef
             ((assq $1 d-prog) s-prog d-prog)
             (svv))
       (call $check-function
             ((cdr rf) s-prog d-prog)
             (fname svv))))

($gen-res-fundef
  (fundef s-prog d-prog)
  (svv)
  =
  (call $gen-res-fundef$/1
        ((car (cdr (cdr fundef)))
         (car (cdr fundef))
         fundef
         s-prog
         d-prog)
        (svv)))

($gen-res-fundef$/1
  ($1 $2 fundef s-prog d-prog)
  (svv)
  =
  (cons (static $1)
        (cons (rcall $pe-exp
                     ((car (cdr (cdr (cdr (cdr fundef)))))
                      $2
                      $1
                      s-prog
                      d-prog)
                     ((call $contract-svv ($2) (svv)) (static $1)))
              (static '()))))

($contract-svv
  (svn)
  (svv)
  =
  (ifs (null? svn)
       (static '())
       (cons (car svv)
             (call $contract-svv ((cdr svn)) ((cdr svv))))))

($pe-exp
  (exp svn dvn s-prog d-prog)
  (svv dvv)
  =
  (ifs (symbol? exp)
       (call $lookup-value (exp dvn) (dvv))
       (ifs (equal? (car exp) 'static)
            (cons (static 'quote)
                  (cons (call $eval-exp
                              ((car (cdr exp)) svn s-prog)
                              (svv))
                        (static '())))
            (ifs (equal? (car exp) 'ifs)
                 (ifd (call $eval-exp
                            ((car (cdr exp)) svn s-prog)
                            (svv))
                      (call $pe-exp
                            ((car (cdr (cdr exp))) svn dvn s-prog d-prog)
                            (svv dvv))
                      (call $pe-exp
                            ((car (cdr (cdr (cdr exp))))
                             svn
                             dvn
                             s-prog
                             d-prog)
                            (svv dvv)))
                 (ifs (equal? (car exp) 'ifd)
                      (cons (static 'if)
                            (cons (call $pe-exp
                                        ((car (cdr exp)) svn dvn s-prog d-prog)
                                        (svv dvv))
                                  (cons (call $pe-exp
                                              ((car (cdr (cdr exp)))
                                               svn
                                               dvn
                                               s-prog
                                               d-prog)
                                              (svv dvv))
                                        (cons (call $pe-exp
                                                    ((car (cdr (cdr (cdr exp))))
                                                     svn
                                                     dvn
                                                     s-prog
                                                     d-prog)
                                                    (svv dvv))
                                              (static '())))))
                      (ifs (equal? (car exp) 'call)
                           (call $pe-call
                                 ((assq (car (cdr exp)) d-prog) s-prog d-prog)
                                 ((call $eval-exp*
                                        ((car (cdr (cdr exp))) svn s-prog)
                                        (svv))
                                  (call $pe-exp*
                                        ((car (cdr (cdr (cdr exp))))
                                         svn
                                         dvn
                                         s-prog
                                         d-prog)
                                        (svv dvv))))
                           (ifs (equal? (car exp) 'rcall)
                                (cons (static 'call)
                                      (cons (cons (static (car (cdr exp)))
                                                  (call $eval-exp*
                                                        ((car (cdr (cdr exp)))
                                                         svn
                                                         s-prog)
                                                        (svv)))
                                            (call $pe-exp*
                                                  ((car (cdr (cdr (cdr exp))))
                                                   svn
                                                   dvn
                                                   s-prog
                                                   d-prog)
                                                  (svv dvv))))
                                (ifs (equal? (car exp) 'xcall)
                                     (cons (static 'xcall)
                                           (cons (static (car (cdr exp)))
                                                 (call $pe-exp*
                                                       ((cdr (cdr exp))
                                                        svn
                                                        dvn
                                                        s-prog
                                                        d-prog)
                                                       (svv dvv))))
                                     (cons (static (car exp))
                                           (call $pe-exp*
                                                 ((cdr exp)
                                                  svn
                                                  dvn
                                                  s-prog
                                                  d-prog)
                                                 (svv dvv)))))))))))

($pe-exp*
  (exp* svn dvn s-prog d-prog)
  (svv dvv)
  =
  (ifs (null? exp*)
       (static '())
       (cons (call $pe-exp
                   ((car exp*) svn dvn s-prog d-prog)
                   (svv dvv))
             (call $pe-exp*
                   ((cdr exp*) svn dvn s-prog d-prog)
                   (svv dvv)))))

($pe-call
  (fundef s-prog d-prog)
  (svv dvv)
  =
  (rcall $pe-exp
         ((car (cdr (cdr (cdr (cdr fundef)))))
          (car (cdr fundef))
          (car (cdr (cdr fundef)))
          s-prog
          d-prog)
         (svv dvv)))

($eval-exp
  (exp svn prog)
  (svv)
  =
  (ifs (symbol? exp)
       (call $lookup-value (exp svn) (svv))
       (ifs (equal? (car exp) 'quote)
            (static (car (cdr exp)))
            (ifs (equal? (car exp) 'if)
                 (ifd (call $eval-exp ((car (cdr exp)) svn prog) (svv))
                      (call $eval-exp
                            ((car (cdr (cdr exp))) svn prog)
                            (svv))
                      (call $eval-exp
                            ((car (cdr (cdr (cdr exp)))) svn prog)
                            (svv)))
                 (ifs (equal? (car exp) 'call)
                      (call $eval-call
                            (prog (assq (car (cdr exp)) prog))
                            ((call $eval-exp*
                                   ((cdr (cdr exp)) svn prog)
                                   (svv))))
                      (ifs (equal? (car exp) 'xcall)
                           (xapply
                             (static (car (cdr exp)))
                             (call $eval-exp*
                                   ((cdr (cdr exp)) svn prog)
                                   (svv)))
                           (ifs (equal? (car exp) 'error)
                                (error (static
                                         '"Error function encountered during partial evaluation")
                                       (cons (static 'error)
                                             (call $eval-exp*
                                                   ((cdr exp) svn prog)
                                                   (svv))))
                                (ifs (equal? (car exp) 'car)
                                     (car (call $eval-exp
                                                ((car (cdr exp)) svn prog)
                                                (svv)))
                                     (ifs (equal? (car exp) 'cdr)
                                          (cdr (call $eval-exp
                                                     ((car (cdr exp)) svn prog)
                                                     (svv)))
                                          (ifs (equal? (car exp) 'cons)
                                               (cons (call $eval-exp
                                                           ((car (cdr exp))
                                                            svn
                                                            prog)
                                                           (svv))
                                                     (call $eval-exp
                                                           ((car (cdr (cdr exp)))
                                                            svn
                                                            prog)
                                                           (svv)))
                                               (ifs (equal? (car exp) 'null?)
                                                    (null? (call $eval-exp
                                                                 ((car (cdr exp))
                                                                  svn
                                                                  prog)
                                                                 (svv)))
                                                    (ifs (equal?
                                                           (car exp)
                                                           'pair?)
                                                         (pair? (call $eval-exp
                                                                      ((car (cdr exp))
                                                                       svn
                                                                       prog)
                                                                      (svv)))
                                                         (ifs (equal?
                                                                (car exp)
                                                                'equal?)
                                                              (equal?
                                                                (call $eval-exp
                                                                      ((car (cdr exp))
                                                                       svn
                                                                       prog)
                                                                      (svv))
                                                                (call $eval-exp
                                                                      ((car (cdr (cdr exp)))
                                                                       svn
                                                                       prog)
                                                                      (svv)))
                                                              (ifs (equal?
                                                                     (car exp)
                                                                     'eq?)
                                                                   (eq? (call $eval-exp
                                                                              ((car (cdr exp))
                                                                               svn
                                                                               prog)
                                                                              (svv))
                                                                        (call $eval-exp
                                                                              ((car (cdr (cdr exp)))
                                                                               svn
                                                                               prog)
                                                                              (svv)))
                                                                   (ifs (equal?
                                                                          (car exp)
                                                                          'eqv?)
                                                                        (eqv? (call $eval-exp
                                                                                    ((car (cdr exp))
                                                                                     svn
                                                                                     prog)
                                                                                    (svv))
                                                                              (call $eval-exp
                                                                                    ((car (cdr (cdr exp)))
                                                                                     svn
                                                                                     prog)
                                                                                    (svv)))
                                                                        (ifs (equal?
                                                                               (car exp)
                                                                               'not)
                                                                             (not (call $eval-exp
                                                                                        ((car (cdr exp))
                                                                                         svn
                                                                                         prog)
                                                                                        (svv)))
                                                                             (xapply
                                                                               (static
                                                                                 (car exp))
                                                                               (call $eval-exp*
                                                                                     ((cdr exp)
                                                                                      svn
                                                                                      prog)
                                                                                     (svv)))))))))))))))))))

($eval-exp*
  (exp* svn prog)
  (svv)
  =
  (ifs (null? exp*)
       (static '())
       (cons (call $eval-exp ((car exp*) svn prog) (svv))
             (call $eval-exp* ((cdr exp*) svn prog) (svv)))))

($eval-call
  (prog fundef)
  (svv)
  =
  (rcall $eval-exp
         ((car (cdr (cdr (cdr fundef))))
          (car (cdr fundef))
          prog)
         (svv)))

($lookup-value
  (vname vn)
  (vv)
  =
  (ifs (eq? (car vn) vname)
       (car vv)
       (call $lookup-value (vname (cdr vn)) ((cdr vv)))))

)(

)