Linux Cubed Series 3: Developer Tools/Linux Cubed Series 3 - Developer Tools.iso/devel/lang/lisp/guile-ii.src/guile-ii/guile-src/ctax/ctax.scm

Text File | 1995-08-15 | 21.0 KB | 767 lines

#!/bin/sh
type;exec guile -l $0 -e "(ctax-repl *stdin*)"
;;; -*-scheme-*- tells emacs this is a scheme file.

;;;;     Copyright (C) 1994, 1995 Free Software Foundation, Inc.
;;;;
;;;; 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, 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 software; see the file COPYING.  If not, write to
;;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;;;;



;; Easier to type:
;;
(define pp (lambda args (apply pretty-print args)))

;; Especially good for debugging -- wrap this
;; around a form.  E.g.:
;;      (+ x <some-exp>) => (+ x (pk 'buggy-exp-val <some-exp>))
;;
(define (pk tag val)
  (pp (list tag val))
  val)

;;; {Warnings and Errors.}
;;;

;; Crudely warn about semantic errors in the source program
;; (e.g. ``statements after return'').
;;
(define (warning v)
  (pp (list 'warning v)))


;;; {Entry Points}
;;;

;; repl
(define (ctax-repl port)
  (synthetic-repl ctax-prompt ctax-read ctax-eval pp port))


(define (ctax-repl-thunk)
  (ctax-prompt)
  (pp (ctax-eval (ctax-read)))
  (ctax-repl-thunk))

;; Prompter
;;
(define (ctax-prompt) (display "ctax> ") (force-output))

;; Parse one ctax command from a port.
;;
(define (ctax-read) (ctax-parse (lambda () (string (read-char)))))

;; Evaluate a parsed form.
;;
(define (ctax-eval tree)  (eval (ctax-transl-command tree)))


;; Parse and translate a string, pretty-print the answer
;;
(define (ctax-translation string)
  (let ((tree (ctax-tree string)))
    (ctax-transl-command tree)))




;; Return a parse tree for the argument string
;;
(define (ctax-tree string)
  (ctax-parse (lambda ()
        (let ((answer string))
          (set! string #f)
          answer))))

;; Translate a tree returned from ctax parse.  The tree
;; is either a stand-alone statement or a definition.
;;
(define (ctax-transl-command tree)
  (cond
   ((and (pair? tree)
     (eq? 'ctax:define (car tree)))
    (ctax-transl-definition tree))

   ((and (pair? tree)
     (eq? 'ctax:SCM (car tree)))
    (cons 'begin
      (map (lambda (v)
         (if (and (pair? (caddr tree))
              (eq? 'ctax:struct (car (caddr tree))))
             (set! v (struct-name v)))
         `(define ,v ,(ctax-transl-expression (caddr tree))))
           (cadr tree))))

   (#t
    (ctax-transl-top-level-statement tree))))


;;; {The Translator}
;;;

;; Return a Scheme form that is equivalent to a
;; top-level ctax statement.  We compile the statement
;; as if it were the body of a parameterless, anonymous function,
;; and then construct an application of that function.
;;
(define (ctax-transl-top-level-statement tree)
  `((lambda ()
      ,(ctax-transl-function-defining-statement tree))))

;; Defines translate to defines.
;;
(define (ctax-transl-definition tree)
  (let ((iens (cadr tree))
    (formals (caddr tree))
    (doc (cadddr tree))
    (interaction (car (cddddr tree)))
    (body (cadr (cddddr tree))))
    `(define ,(cons iens formals)
       ,(ctax-transl-function-defining-statement body))))

;;
(define (ctax-transl-definition-procedure tree)
  (let ((iens (cadr tree))
    (formals (caddr tree))
    (doc (cadddr tree))
    (interaction (car (cddddr tree)))
    (body (cadr (cddddr tree))))
    `(lambda ,formals
       ,(ctax-transl-function-defining-statement body))))


;; A statement that is the body of a function definition
;; is translated by this procedure.  The gist is that the statement
;; is translated as usual, but that we might have to provide
;; some bindings for free labels like `break' or `fi'.
;;
(define (ctax-transl-function-defining-statement tree)
  (ctax-transl-statement
   tree
   #f
   #f
   (lambda (translation free-attribs)
     (cond
      ((member free-attribs '(() (return))) translation)
      ((member free-attribs '((break) (fi)))
       `(let ((,(car free-attribs) (lambda (x) x)))
      ,translation))
      (t (error (list 'internal-error-bad-attributes free-attribs)))))))


;; Translate a statement
;;
;; The arguments are

;;     tree -- a ctax syntax tree to translate

;;     following -- the name of a label to which to pass the value
;;                  of this statement.  #f if the statment should just
;;                  return it's value.

;;                  For example, the two branches of a conditional are
;;                  (normally) translated with following set to 'fi,
;;                  and that label is given to the statements that
;;                  follow the conditional.

;;                  Some care is taken to not introduce labels
;;                  unecessarily.  For example, if a conditional is
;;                  being compiled with following set to 'break
;;                  (indicating an enclosing while loop), then it
;;                  won't introduce a 'fi label.  Instead, the two
;;                  branches will also have following set to 'break.
;;                  This optimization is a kind of goto compression.

;;     exits-ok? -- #f unless the statement is enclosed in a loop.
;;                  Only if this is not false can the statement be `break'
;;                  or `continue'

;;     return -- the return continuation. Takes two arguments.
;;
;;               The first argument is the Scheme form which is the
;;               translation.

;;               The second is a list of flags describing the translation.
;;               In this implementation, the flags are either '() or a
;;               one element list.

;;               The flags can be:

;;                   '(return)  -- the statement is a return statement.

;;                   '(fi) -- the statement passes its value to the
;;                            label `fi'.  Presumably the statement
;;                            was a conditional.

;;                   '(break) -- the statement passes its label to the
;;                               label `break'.  The statement was
;;                               some form of loop (while, for or do).
;;


(define (ctax-transl-statement tree following exits-ok? return)

  (let ((statement-type (ctax-tree-type tree)))
    (case statement-type

      ;; Compound statements.
      ;;
      ;; In the simplest case, a ctax block turns into just a Scheme
      ;; block:
      ;;
      ;;   { a; b; c; }    =>   (begin [a] [b] [c])
      ;;
      ;; That case is handled by translating a to [a], and then
      ;; making (conceptually):
      ;;
      ;;        (begin [a] (begin [{b; c;}]))
      ;;
      ;; To actually build such a scheme form, we use ctax-make-begin!
      ;; which flattens nested begin forms.
      ;;
      ;; In a more complicated case, the first statment might be
      ;; a loop or conditional.  In that case, the rest of the
      ;; statements have to be labeled:
      ;;
      ;;      { if (a) b; else return c;  d; }
      ;;    =>
      ;;      (let ((fi (lambda (return) [d])))
      ;;         (if (ctax-test [a])
      ;;            (fi [b])
      ;;            c))
      ;;
      ;; Note that this translation isn't hygenic: it mixes some
      ;; compiler generated identifiers ("fi" and "return") in with
      ;; the identifiers of the source program.  We get away with that
      ;; by making the labels illegal ctax identifiers.  Slightly more
      ;; sophisticated translations could be hygenic but there is no
      ;; need so long as the compiler can allocate a few variable
      ;; names to itself.
      ;;


      ((ctax:begin)

       (let* ((formals (cadr tree))
          (body (cddr tree))
          (first-stmt (car body))
          (rest-stmts (cdr body)))

     (if (null? rest-stmts)

         ;; If a compound statement only contains one element,
         ;; just translate that element.
         ;;
         (ctax-transl-statement
          (car body)
          following
          exits-ok?
          (lambda (only-tree only-labels)
        (return
         ;; Even though the block has only one statement, it
         ;; may have some local variables.
         ;;
         (if (null? formals)
             only-tree
             (ctax-enclose-with-formals formals only-tree))
         only-labels)))


         ;; Truly compound statemts
         ;;
         ;; Start by translating the first statement...
         ;;
         (ctax-transl-statement
          first-stmt

          ;; We are in the middle of a block, so the first statement
          ;; is followed directly by other statements.  Therefore,
          ;; it should just return its value normally:
          ;;
          #f

          ;; It is only ok for the first statement to be a break
          ;; or continue if it was ok for this whole block to have
          ;; been a break or continue:
          ;;
          exits-ok?

          (lambda (first-tree first-attribs)
        ;; A big dispatch on the attributes of the first
        ;; statement:
        ;;
        (cond
         ;; If the first statement was simple enough, then there
         ;; are no free labels to resolve
         ;;
         ((null? first-attribs)
          ;; Just put the statement in a scheme block with the
          ;; rest of the statements.  First, contruct a ctax block
          ;; containing only the rest of this block, and compile
          ;; that:
          ;;
          (ctax-transl-statement
           (cons 'ctax:begin (cons '() rest-stmts))

           ;; The subblock containing all statements after the
           ;; first is followed by whatever follows the block
           ;; we're working on.
           ;;
           following

           ;; Again, this is inherited:
           ;;
           exits-ok?

           (lambda (rest-tree rest-attribs)
             ;; This function has the compiled first
             ;; statement, and the compiled rest of the block.
             ;;
             (let ((block-denot
                (ctax-make-begin! (list first-tree rest-tree))))
               (return
            (if (null? formals)
                block-denot
                (ctax-enclose-with-formals formals block-denot))
            ;; The attributes of the tail of the block
            ;; become the attributes of the whole block:
            ;;
            rest-attribs)))))


         ;; If the first statement was a return statement,
         ;; then ignore the remaining statements and consider
         ;; this whole block a return statement.
         ;;
         ((equal? '(return) first-attribs)
          (warning 'statements-after-return)
          (return first-tree '(return)))

         ;; If the first statement was a conditional or loop,
         ;; provide the appropriate label for the rest of the block:
         ;;
         ((member first-attribs '((fi) (break)))
          (ctax-transl-statement
           ;; Compile the rest of the block.
           ;;
           (cons 'ctax:begin (cons '() rest-stmts))

           ;; The rest of the block inherits the whole
           ;; block's follow.
           ;;
           following

           ;; Inherit whether we are in a loop:
           ;;
           exits-ok?

           (lambda (rest-tree rest-attribs)
             ;; Label the rest of the block `fi' or `break'
             ;; so that the first statement can terminate using
             ;; branches to that label.
             ;;
             (let ((block-denot `(let ((,(car first-attribs)
                        (lambda (return) ,rest-tree)))
                       ,first-tree)))
               (return
            (if (null? formals)
                block-denot
                (ctax-enclose-with-formals formals
                               block-denot))

            rest-attribs)))))

         (t (list 'goof
              first-attribs
              first-tree))))))))

      ;; Return statements simply denote their expression's denotation.
      ;; This is different from an expression statement.  An expression
      ;; statement denotes its expression's denotation but wrapped in a
      ;; call to the label implied by `follow'.
      ;;
      ((ctax:return)
       (return (ctax-transl-expression (cadr tree)) '(return)))


      ((ctax:if)
       (let* ((pred (cadr tree))
          (consequent (caddr tree))
          (anticons (cadddr tree))

          (tail-label  (or following 'fi))

          ;; Translate the predicate trivially...
          ;;
          (pred-denot `(ctax:test ,(ctax-transl-expression pred))))

     (ctax-transl-statement
      consequent
      tail-label
      exits-ok?
      (lambda (cons-denot cons-labels)
        (ctax-transl-statement
         anticons
         tail-label
         exits-ok?
         (lambda (anticons-denot anticons-labels)
           (return
        `(if ,pred-denot
             ,cons-denot
             ,anticons-denot)
        (if following
            #f
            '(fi)))))))))

      ((ctax:while ctax:do)
       (let* ((pred (cadr tree))
          (body (caddr tree))
          (pred-denot `(ctax:test ,(ctax-transl-expression pred)))
          (tail-label (or following 'break)))

     (ctax-transl-statement
      body
      'continue
      #t
      (lambda (body-denot body-labels)
        (return

         (let ((w/continue
            `(letrec ((continue
                   (lambda (return)
                 (if ,pred-denot
                     ,body-denot
                     (break return)))))
               ;; Does one execution of the body always
               ;; precede the first evaluation of the predicate?
               ;;
               ,(if (eq? statement-type 'ctax:do)
                body-denot
                '(continue #f)))))

           ;; If there is a `following' label, then that
           ;; label is where calls to `break' should go.
           ;;
           (if following
           `(let ((break ,following))
              ,w/continue)
           w/continue))


         ;; If there is no following label, then
         ;; the caller has to provide an appropriate
         ;; binding for `break'.
         ;;
         (if following
         #f
         '(break)))))))


      ;; For loops are simply rewritten in the way you'd expect.
      ((ctax:for)
       (let* ((init (cadr tree))
          (pred (caddr tree))
          (increment (cadddr tree))
          (body (car (cddddr tree)))
          (new-body `(ctax:begin
              ()
              ,body
              ,increment))
          (new-loop `(ctax:while ,pred
                     ,new-body))
          (easier-form `(ctax:begin
                 ()
                 ,init
                 ,new-loop)))

     (ctax-transl-statement easier-form following exits-ok? return)))

      ((ctax:break) (return '(break #f) '(break)))

      ((ctax:continue) (return '(continue #f) '(continue)))

      ;; Expressions:
      (else
       (let ((exp-denot (ctax-transl-expression tree)))
     (return
      (if following
          (list following exp-denot)
          exp-denot)
      '()))))))


;; Translate an expression.  This is trivial because flow of control
;; is not an issue.  For simplicity, we presume a ctax run-time with
;; function names that match the symbols used as syntactic identifiers.
;;

(define (struct-name symbol)
  (symbol-append '< 'struct '- symbol '>))
(define (struct-predicate-name symbol)
  (symbol-append '< 'struct '- symbol '? '>))

(define (ctax-transl-expression tree)
  (case (ctax-tree-type tree)
    ;; Expressions:
    ((ctax:comma)
     (ctax-make-begin! (map ctax-transl-expression (cdr tree))))


    ((ctax:constant) tree)

    ((ctax:variable) tree)

    ((ctax:make-struct)
     (let ((sname (struct-name (cadr tree)))
       (inits (cddr tree)))
       `(ctax:make-struct ,sname
              ,@(map ctax-transl-expression inits))))

    ((ctax:struct)
     (let ((sname (cadr tree))
       (fields (caddr tree))
       (super (cadddr tree)))
       `(ctax:struct ',(struct-name sname) ',fields ,(and super (struct-name super)))))

    ((ctax:struct-type)  (struct-name (cadr tree)))

    ((ctax:->)  (list 'ctax:->
              (caddr tree)
              (ctax-transl-expression (cadr tree))))

    ((ctax:scheme-kw) (symbol->keyword (cadr tree)))

    ((ctax:neg ctax:log-neg ctax:pos ctax:bit-neg)
     (cons (car tree)
       (map ctax-transl-expression (cdr tree))))

    ((ctax:scheme-val)
     `(quote ,(with-input-from-string (cadr tree) read)))

    ((ctax:assign)
     (let* ((dest (cadr tree))
        (val (caddr tree))
        (dest-denot (ctax-transl-expression dest))
        (val-denot (ctax-transl-expression val)))
       (ctax-make-assignment dest-denot val-denot)))

    ((ctax:times ctax:div ctax:mod ctax:plus ctax:minus ctax:lshift
         ctax:rshift ctax:eq ctax:ne ctax:le ctax:ge
         ctax:lt ctax:gt ctax:bit-and ctax:bit-xor ctax:bit-or
         ctax:log-and ctax:log-or ctax:if-exp ctax:aref)
     (cons (car tree)
       (map ctax-transl-expression (cdr tree))))

    ((ctax:apply)
     (map ctax-transl-expression (cons (cadr tree) (caddr tree))))

    ((ctax:lambda)
     `(lambda ,(cadr tree)
    ,(ctax-transl-function-defining-statement (car (cddddr tree)))))

    (else (error (list 'internal-error tree)))))



;; Return a symbol describing a parse tree.
;;
(define (ctax-tree-type tree)
  (cond
   ((pair? tree) (car tree))
   ((memq tree '(ctax:break ctax:continue)) tree)
   ((symbol? tree) 'ctax:variable)
   (t 'ctax:constant)))


;; When building up scheme forms like (begin...), collapse
;; nested begin forms destructively.
;;
(define (ctax-make-begin! expressions)

  (define (is-begin form)
    (and (pair? form) (eq? (car form) 'begin)))

  (define (build-list! dest exps)
    (cond
     ((null? exps)
      (set-cdr! dest '()))
     ((is-begin (car exps))
      (set-cdr! dest (cdar exps))
      (build-list! (last-pair dest) (cdr exps)))
     (t
      (set-cdr! dest (cons (car exps) '()))
      (build-list! (cdr dest) (cdr exps)))))

  (let ((answer (cons 'begin '#f)))
    (build-list! answer expressions)
    answer))


;; Assignment translates trivially
;;
(define (ctax-make-assignment dest val)
  (cond
   ((symbol? dest)
    `(set! ,dest ,val))

   ((eq? (car dest) 'ctax:aref)
    `(vector-set! ,(cadr dest)
          ,(caddr dest)
          ,val))

   ((eq? (car dest) 'ctax:->)
    `(ctax:set->! ,(cadr dest)
          ,(caddr dest)
          ,val))
   (else
    (error (list 'illegal-assignment dest val)))))



(define (ctax-enclose-with-formals formals scheme-form)
  (define (formal->let-binding formal)
    (let* ((var-names (cadr formal))
       (first-var (car var-names))
       (init-expression (caddr formal)))
      (cons (list first-var
          (ctax-transl-expression init-expression))
        (map (lambda (var-name)
           (list var-name first-var))
         (cdr var-names)))))

  (define (formals-list->let-bindings list)
    (if (null? list)
    '()
    (append (formal->let-binding (car list))
        (formals-list->let-bindings (cdr list)))))

  `(let* ,(formals-list->let-bindings formals)
     ,scheme-form))


(define (ctax-enclose-with-formals formals scheme-form)
  (define (formal->sets formal)
    (if (eq? (car formal) 'ctax:define)
    `((set! ,(cadr formal)
        ,(ctax-transl-definition-procedure formal)))
    (let ((var-names (cadr formal))
          (init-expression (caddr formal)))
      (let loop ((answer '())
             (val init-expression)
             (vars var-names))
        (if (null? vars)
        (reverse answer)
        (loop (cons `(set! ,(car vars) ,val) answer)
              (car vars)
              (cdr vars)))))))

  (define (formals-list->sets list)
    (if (null? list)
    '()
    (append! (formal->sets (car list))
         (formals-list->sets (cdr list)))))

  (define (formal-decls f)
    (if (eq? (car f) 'ctax:define)
    (cons (list (cadr f) 0) '())
    (map (lambda (v) (list v 0)) (cadr f))))

  `(let ,(apply append! (map formal-decls formals))
     (begin ,@(formals-list->sets formals))
     ,scheme-form))



(define (ctax:test val)
  (and val (not (eq? 0 val))))

(defmacro ctax:eq (a b) `(eq? ,a ,b))
(defmacro ctax:ne (a b) `(not (eq? ,a ,b)))
(defmacro ctax:le (a b) `(<= ,a ,b))
(defmacro ctax:ge (a b) `(>= ,a ,b))
(defmacro ctax:lt (a b) `(< ,a ,b))
(defmacro ctax:gt (a b) `(> ,a ,b))

(defmacro ctax:minus (a b) `(- ,a ,b))
(defmacro ctax:plus (a b) `(+ ,a ,b))
(defmacro ctax:times (a b) `(* ,a ,b))
(defmacro ctax:div (a b) `(/ ,a ,b))
(defmacro ctax:mod (a b) `(mod ,a ,b))

(defmacro ctax:neg (a) `(- ,a))
(defmacro ctax:pos (a) a)

(define (ctax:log-neg a) (if (or (not a) (eq? 0 a)) 1 0))

(defmacro ctax:lshift (a b) `(ash ,a ,b))
(defmacro ctax:rshift (a b) `(ash ,a (- ,b)))
(defmacro ctax:bit-neg (a) `(lognot ,a))
(defmacro ctax:bit-and (a b) `(logand ,a ,b))
(defmacro ctax:bit-xor (a b) `(logxor ,a ,b))
(defmacro ctax:bit-or (a b) `(logor ,a ,b))

(defmacro ctax:log-and subforms
  `(and ,@subforms))
(defmacro ctax:log-or subforms
  `(or ,@subforms))
(defmacro ctax:if-exp subforms `(if ,@subforms))
(defmacro (false) #f)

(define argv *argv*)

(define (ctax:struct name fields super)
  (make-struct-type name fields super))

(define ctax:array vector)
(define (ctax:bit-array . elts) (list->uniform-vector #t elts))
(define (ctax:bit-array . elts) (list->uniform-vector #t elts))
(define (ctax:bit-array . elts) (list->uniform-vector #t elts))
(define (ctax:bit-array . elts) (list->uniform-vector #t elts))
(define (ctax:bit-array . elts) (list->uniform-vector #t elts))
(define (ctax:bit-array . elts) (list->uniform-vector #t elts))


(define (ctax:make-struct type . inits)
  (apply make-struct type inits))

(defmacro ctax:-> (field struct)
  (list (struct-accessor field) struct))
(defmacro ctax:set->! (field struct val)
  (list (struct-modifier field) struct val))

(defmacro ctax:->! (field struct val)
  (list (struct-accessor field) struct val))

(define (ctax:bit-array . args)
  (list->uniform-vector #t (map ctax:test args)))
(define (ctax:uint-array . args)
  (list->uniform-vector 1 args))
(define (ctax:int-array . args)
  (list->uniform-vector -1 args))
(define (ctax:float-array . args)
  (list->uniform-vector 1.0 args))
(define (ctax:double-array . args)
  (list->uniform-vector 1/3 args))
(define (ctax:complex-array . args)
  (list->uniform-vector +i args))
(define ctax:list list)
(provide 'ctax)




(load "../gls/lstruct.scm")