path: root/csc/ir1.csc

(define-library (csc ir1)
  (export
    call-arguments
    call-procedure
    call?
    constant-expression
    constant?
    define-syntax-name
    define-syntax-transformer
    define-syntax?
    if-alternate
    if-consequent
    if-test
    if?
    import?
    ir1=?
    lambda-body
    lambda-case-alternate
    lambda-case-arguments
    lambda-case-body
    lambda-case-gensyms
    lambda-case-rest
    lambda-case?
    lambda?
    letrec-expression
    letrec-gensyms
    letrec-in-order?
    letrec-names
    letrec-values
    letrec?
    lexical-ref-gensym
    lexical-ref-name
    lexical-ref?
    lexical-set-expression
    lexical-set-ref
    lexical-set?
    library-define-expression
    library-define-ref
    library-define?
    library-ref-library
    library-ref-name
    library-ref?
    make-call
    make-constant
    make-define-syntax
    make-if
    make-lambda
    make-lambda-case
    make-letrec
    make-lexical-ref
    make-lexical-set
    make-library-define
    make-library-ref
    make-sequence
    sequence-head
    sequence-tail
    sequence?)
  (import (scheme base)
          (only (csc loop) loop return))
  (begin
    ; This library defines the intermediate representation IR1. An expression
    ; in IR1 has one of the following forms (plagiarized from Guile's
    ; Tree-IL).


    ; <constant> expression
    ; Constant is used to include literal constants in scheme code.
    (define-record-type <constant>
      (make-constant expression)
      constant?
      (expression constant-expression))


    ; <lexical-ref> name gensym
    ; A reference to a lexically-bound variable. The name is the original name
    ; of the variable in the source program. gensym is a unique identifier for
    ; this variable.
    (define-record-type <lexical-ref>
      (make-lexical-ref name gensym)
      lexical-ref?
      (name lexical-ref-name)
      (gensym lexical-ref-gensym))


    ; <library-ref> name
    ; A free reference to a variable in a library. If the library is 'main,
    ; then it is a top-level global variable.
    (define-record-type <library-ref>
      (make-library-ref name library)
      library-ref?
      (name library-ref-name)
      (library library-ref-library))


    ; <lexical-set> name gensym expression
    ; Sets a lexically-bound variable.
    (define-record-type <lexical-set>
      (make-lexical-set ref expression)
      lexical-set?
      (ref lexical-set-ref)
      (expression lexical-set-expression))


    ; <library-define> name expression
    ; Defines a new variable in the current library.
    (define-record-type <library-define>
      (make-library-define ref expression)
      library-define?
      (ref library-define-ref)
      (expression library-define-expression))


    ; <define-syntax> name transformer
    ; Defines a new macro in the current environment. name is the name of the
    ; macro. transformer is a macro transformer.
    (define-record-type <define-syntax>
      (make-define-syntax name transformer)
      define-syntax?
      (name define-syntax-name)
      (transformer define-syntax-transformer))


    ; <if> test consequent alternate
    ; A conditional.
    (define-record-type <if>
      (make-if test consequent alternate)
      if?
      (test if-test)
      (consequent if-consequent)
      (alternate if-alternate))


    ; <call> procedure arguments
    ; A procedure call. The procedure and arguments are evaluated in an
    ; unspecified order, and the resulting procedure is passed the
    ; resulting arguments.
    (define-record-type <call>
      (make-call procedure arguments)
      call?
      (procedure call-procedure)
      (arguments call-arguments))


    ; <sequence> head tail
    ; Evaluate head, ignoring any result. Then tail is evaluated.
    (define-record-type <sequence>
      (make-sequence head tail)
      sequence?
      (head sequence-head)
      (tail sequence-tail))


    ; <lambda> body
    ; A closure. body is an expression of type <lambda-case>.
    (define-record-type <lambda>
      (make-lambda body)
      lambda?
      (body lambda-body))


    ; <lambda-case> arguments rest gensyms body alternate
    ; One clause of a case-lambda. A lambda expression in Scheme is treated as
    ; a case-lambda with one clause.
    ;
    ; arguments is a list of the procedures arguments, as symbols. rest is the
    ; name of the rest argument, or #f. gensyms is a list of gensyms
    ; corresponding to all arguments: first all of the normal arguments, then
    ; the rest argument if any.
    ;
    ; body is the name of the clause (??). If the procedure is called with an
    ; appropriate number of arguments, body is evaluated in tail position.
    ; Otherwise if there is an alternate, it should be a <lambda-case>
    ; expression, representing the next clause to try. If alternate is nil, an
    ; error is signaled.
    (define-record-type <lambda-case>
      (make-lambda-case arguments rest gensyms body alternate)
      lambda-case?
      (arguments lambda-case-arguments)
      (rest lambda-case-rest)
      (gensyms lambda-case-gensyms)
      (body lambda-case-body)
      (alternate lambda-case-alternate))


    ; <letrec> in-order? names gensyms values expression
    ; Lexical binding, like Scheme's letrec, or letrec* if in-order? is true.
    ; names are the original binding names, gensyms are gensyms corresponding
    ; to the names, and values are IR1 expressions for the values. expression
    ; is a single IR1 expression.
    (define-record-type <letrec>
      (make-letrec in-order? names gensyms values expression)
      letrec?
      (in-order? letrec-in-order?)
      (names letrec-names)
      (gensyms letrec-gensyms)
      (values letrec-values)
      (expression letrec-expression))


    (define (ir1=?-sametype x y)
      (cond
        ((and (constant? x) (constant? y))
          (equal? (constant-expression x) (constant-expression y)))
        ((and (lexical-ref? x) (lexical-ref? y))
          (symbol=? (lexical-ref-name x) (lexical-ref-name y)))
        ((and (library-ref? x) (library-ref? y))
          (symbol=? (library-ref-name x) (library-ref-name y))
          (equal? (library-ref-library x) (library-ref-library y)))
        ((and (lexical-set? x) (lexical-set? y))
          (and
            (ir1=? (lexical-set-ref x) (lexical-set-ref y))
            (ir1=? (lexical-set-expression x) (lexical-set-expression y))))
        ((and (library-define? x) (library-define? y))
          (and
            (symbol=? (library-define-name x) (library-define-name y))
            (ir1=? (library-define-expression x) (library-define-expression y))
            (equal? (library-define-library x) (library-define-library y))))
        ((and (if? x) (if? y))
          (and
            (ir1=? (if-test x) (if-test y))
            (ir1=? (if-consequent x) (if-consequent y))
            (ir1=? (if-alternate x) (if-alternate y))))
        ((and (call? x) (call? y))
          (and
            (ir1=? (call-procedure x) (call-procedure y))
            (= (length (call-arguments x)) (length (call-arguments y)))
            (loop for x-arg in (call-arguments x)
                  for y-arg in (call-arguments y)
                  unless (ir1=? x-arg y-arg)
                    return #f
                  finally (return #t))))
        ((and (sequence? x) (sequence? y))
          (and
            (ir1=? (sequence-head x) (sequence-head y))
            (ir1=? (sequence-tail x) (sequence-tail y))))
        ((and (lambda? x) (lambda? y))
          (ir1=? (lambda-body x) (lambda-body y)))
        ((and (lambda-case? x) (lambda-case? y))
          (and
            (equal? (lambda-case-arguments x) (lambda-case-arguments y))
            (eq? (lambda-case-rest x) (lambda-case-rest y))
            (ir1=? (lambda-case-body x) (lambda-case-body y))
            (or (and (null? (lambda-case-alternate x))
                     (null? (lambda-case-alternate y)))
                (ir1=? (lambda-case-alternate x) (lambda-case-alternate y)))))
        ((and (letrec? x) (letrec? y))
          (and
            (boolean=? (letrec-in-order? x) (letrec-in-order? y))
            (map symbol=? (letrec-names x) (letrec-names y))
            (= (length (letrec-values x)) (length (letrec-values y)))
            (loop for x-val in (letrec-values x)
                  for y-val in (letrec-values y)
                  unless (ir1=? x-val y-val) return #f
                  finally (return #t))
            (ir1=? (letrec-expression x) (letrec-expression y))))
        (else #f)))


    (define (ir1=? x y)
      (cond
        ((ir1=?-sametype x y) #t)
        ((and (ir1=?-sametype x x) (ir1=?-sametype y y))
          #f)
        (else (error "One or more arguments has a type unknown to ir1=?" x y))))))