guile-prescheme/prescheme/bcomp/schemify.scm

;;; Ported from Scheme 48 1.9.  See file COPYING for notices and license.
;;;
;;; Port Author: Andrew Whatson
;;;
;;; Original Authors: Richard Kelsey, Jonathan Rees, Martin Gasbichler, Mike Sperber
;;;
;;;   scheme48-1.9.2/scheme/bcomp/schemify.scm
;;;
;;; schemify
;;;
;;; This is only used for producing error and warning messages.
;;;
;;; Flush nodes and generated names in favor of something a little more
;;; readable.  Eventually, (schemify node env) ought to produce an
;;; s-expression that has the same semantics as node, when node is fully
;;; expanded.

(define-module (prescheme bcomp schemify)
  #:use-module (prescheme scheme48)
  #:use-module (prescheme bcomp cenv)
  #:use-module (prescheme bcomp binding)
  #:use-module (prescheme bcomp mtype)
  #:use-module (prescheme bcomp name)
  #:use-module (prescheme bcomp node)
  #:use-module (prescheme bcomp package)
  #:use-module (prescheme bcomp transform)
  #:export (schemify))

(define (schemify node . maybe-env)
  (if (node? node)
      (schemify-node node
                     (if (null? maybe-env)
                         #f
                         (car maybe-env)))
      (schemify-sexp node)))


(define schemifiers
  (make-operator-table (lambda (node env)
                         (let ((form (node-form node)))
                           (if (list? form)
                               (let ((op (car form)))
                                 (cons (cond ((operator? op)
                                              (operator-name op))
                                             ((node? op)
                                              (schemify-node op env))
                                             (else
                                              (schemify-sexp op)))
                                       (schemify-nodes (cdr form) env)))
                               form)))))

;; We cache the no-env version because that's the one used to generate the
;; sources in the debugging info (which takes up a lot of space).

(define (schemify-node node env)
  (or (and (not env)
           (node-ref node 'schemify))
      (let ((form ((operator-table-ref schemifiers (node-operator-id node))
                     node
                     env)))
        (if (not env)
            (node-set! node 'schemify form))
        form)))

(define (schemify-nodes nodes env)
  (map (lambda (node)
         (schemify-node node env))
       nodes))

(define (define-schemifier name type proc)
  (operator-define! schemifiers name type proc))

(define-schemifier 'name 'leaf
  (lambda (node env)
    (if env
        (name->qualified (node-form node)
                         env)
        (let ((form (node-form node)))
          (if (or #f (node? form))
              (schemify-node form env)
              (desyntaxify form))))))

;; Convert an alias (generated name) to S-expression form ("qualified name").

(define (name->qualified name env)
  (cond ((not (generated? name))
         name)
        ((let ((d0 (lookup env name))
               (d1 (lookup env (generated-name name))))
           (and d0 d1 (same-denotation? d0 d1)))
         (generated-name name))   ;;+++
        (else
         (make-qualified (qualify-parent (generated-parent-name name)
                                         env)
                         (generated-name name)
                         (generated-uid name)))))

;; As an optimization, we elide intermediate steps in the lookup path
;; when possible.  E.g.
;;     #(>> #(>> #(>> define-record-type define-accessors)
;;              define-accessor)
;;         record-ref)
;; is replaced with
;;     #(>> define-record-type record-ref)

(define (qualify-parent name env)
  (let recur ((name name) (env env))
    (if (generated? name)
        (let ((parent (generated-parent-name name)))
          (if (and (environment-stable? env)
                   (let ((b1 (generic-lookup env name))
                         (b2 (generic-lookup env parent)))
                     (and b1
                          b2
                          (or (same-denotation? b1 b2)
                              (and (binding? b1)
                                   (binding? b2)
                                   (let ((s1 (binding-static b1))
                                         (s2 (binding-static b2)))
                                     (and (transform? s1)
                                          (transform? s2)
                                          (eq? (transform-env s1)
                                               (transform-env s2)))))))))
              (recur parent env)        ;;+++
              (make-qualified (recur parent (generated-env name))
                              (generated-name name)
                              (generated-uid name))))
        name)))

(define-schemifier 'quote syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      `(quote ,(cadr form)))))

(define-schemifier 'call 'internal
  (lambda (node env)
    (map (lambda (node)
           (schemify-node node env))
         (node-form node))))

;; We ignore the list of free variables in flat lambdas.

(define (schemify-lambda node env)
  (let ((form (node-form node)))
    `(lambda ,(schemify-formals (cadr form) env)
       ,(schemify-node (last form) env))))

(define-schemifier 'lambda syntax-type schemify-lambda)
(define-schemifier 'flat-lambda syntax-type schemify-lambda)

(define (schemify-formals formals env)
  (cond ((node? formals)
         (schemify-node formals env))
        ((pair? formals)
         (cons (schemify-node (car formals) env)
               (schemify-formals (cdr formals) env)))
        (else
         (schemify-sexp formals))))  ;; anything besides '() ?

;; let-syntax, letrec-syntax...

(define-schemifier 'letrec syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      (schemify-letrec 'letrec (cadr form) (caddr form) env))))

(define-schemifier 'letrec* syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      (schemify-letrec 'letrec* (cadr form) (caddr form) env))))

(define-schemifier 'pure-letrec syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      (schemify-letrec 'letrec (cadr form) (cadddr form) env))))

(define (schemify-letrec op specs body env)
  `(,op ,(map (lambda (spec)
                   (schemify-nodes spec env))
                 specs)
     ,(schemify-node body env)))

(define-schemifier 'loophole syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      (list 'loophole
            (type->sexp (cadr form) #t)
            (schemify-node (caddr form) env)))))

(define-schemifier 'lap syntax-type
  (lambda (node env)
    (let ((form (node-form node)))
      `(lap
        ,(cadr form)
        ,(schemify-nodes (caddr form) env)
        . ,(cdddr form)))))

;;----------------

(define (schemify-sexp thing)
  (cond ((name? thing)
         (desyntaxify thing))
        ((pair? thing)
         (let ((x (schemify-sexp (car thing)))
               (y (schemify-sexp (cdr thing))))
           (if (and (eq? x (car thing))
                    (eq? y (cdr thing)))
               thing                    ;;+++
               (cons x y))))
        ((vector? thing)
         (let ((new (make-vector (vector-length thing) #f)))
           (let loop ((i 0) (same? #t))
             (if (>= i (vector-length thing))
                 (if same? thing new)   ;+++
                 (let ((x (schemify-sexp (vector-ref thing i))))
                   (vector-set! new i x)
                   (loop (+ i 1)
                         (and same? (eq? x (vector-ref thing i)))))))))
        (else thing)))