path: root/csc/ir1.csc

(define-library (csc ir1)
  (export
    %call
    %constant
    %define-syntax
    %if
    %lambda
    %letrec
    %lexical-ref
    %lexical-set
    %library-define
    %library-ref
    %sequence
    call-arguments
    call-procedure
    call?
    constant-expression
    constant?
    define-syntax-name
    define-syntax-transformer
    define-syntax?
    if-alternate
    if-consequent
    if-test
    if?
    ir1=?
    lambda-arguments
    lambda-body
    lambda-rest
    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-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 list)
            all)
          (only (csc loop) loop return)
          (only (csc match)
            define-match-record-type))
  (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-match-record-type <constant>
      (make-constant expression)
      constant?
      %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-match-record-type <lexical-ref>
      (make-lexical-ref name gensym)
      lexical-ref?
      %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-match-record-type <library-ref>
      (make-library-ref name library)
      library-ref?
      %library-ref
      (name library-ref-name)
      (library library-ref-library))


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


    ; <library-define> name expression
    ; Defines a new variable in the current library.
    (define-match-record-type <library-define>
      (make-library-define ref expression)
      library-define?
      %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-match-record-type <define-syntax>
      (make-define-syntax name transformer)
      define-syntax?
      %define-syntax
      (name define-syntax-name)
      (transformer define-syntax-transformer))


    ; <if> test consequent alternate
    ; A conditional.
    (define-match-record-type <if>
      (make-if test consequent alternate)
      if?
      %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-match-record-type <call>
      (make-call procedure arguments)
      call?
      %call
      (procedure call-procedure)
      (arguments call-arguments))


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


    ; <lambda> body
    ; A closure. Arguments is a list of lexical-refs.
    ; Rest is a lexical ref or #f if the lambda doesn't take a rest parameter.
    (define-match-record-type <lambda>
      (make-lambda arguments rest body)
      lambda?
      %lambda
      (arguments lambda-arguments)
      (rest lambda-rest)
      (body lambda-body))


    ; <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-match-record-type <letrec>
      (make-letrec in-order? names gensyms values expression)
      letrec?
      %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
            (ir1=? (library-define-ref x) (library-define-ref y))
            (ir1=? (library-define-expression x) (library-define-expression 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))
          (let ((x-args (lambda-arguments x))
                (x-rest (lambda-rest x))
                (y-args (lambda-arguments y))
                (y-rest (lambda-rest y)))
            (and (= (length x-args) (length y-args))
                 (all ir1=? x-args y-args)
                 (or (and (not x-rest) (not y-rest))
                     (ir1=? x-rest y-rest))
                 (ir1=? (lambda-body x) (lambda-body y)))))
        ((and (letrec? x) (letrec? y))
          (let ((x-names (letrec-names x))
                (x-values (letrec-values x))
                (y-names (letrec-names y))
                (y-values (letrec-values y)))
            (and
              (boolean=? (letrec-in-order? x) (letrec-in-order? y))
              (= (length x-names) (length y-names))
              (all symbol=? x-names y-names)
              (= (length x-values) (length y-values))
              (all ir1=? x-values y-values)
              (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))))))