Compiler of SECDR scheme (GPL)

gistfile1.scm

;;
;; compiler.scm
;;

;;;; SECDR Compiler
;;
;;   Date written    11-Feb-1990 by Atsushi Moriwaki
;;   Date revised    20-Feb-1990 by Atsushi Moriwaki
;;   Date revised    06-Mar-1990 by Atsushi Moriwaki
;;   Date revised    31-Jul-1992 by Shoichi Hayashi
;;   Date revised    20-Nov-1992 by Shoichi Hayashi
;;   Date revised    13-Mar-1993 by Shoichi Hayashi
;;   Date revised    07-May-1993 by Shoichi Hayashi
;;   Date revised    11-May-1993 by Shoichi Hayashi
;;
;;========================================================================
;;
;;   Copyright(C) 1990,1991,1992,1993 Atsushi Moriwaki, Shoichi Hayashi.
;;
;;   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 of the License, 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 program; if not, write to the Free Software
;;   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;
;;   The author can be reached at s-haya@rst.fujixerox.co.jp or
;;   Shoichi Hayashi,
;;   SYSTEMS & COMMUNICATIONS LAB.  FUJI XEROX Co.,LTD.
;;   134 GODOCHO, HODOGAYA-KU, YOKOHAMA-SHI, KANAGAWA, 240, JAPAN
;;
;; RCS info: $Header: /usr/PDS/lang/Scheme/SECDR/RCS/compiler.scm,v 1.0 1993/07/06 08:26:09 s-haya Rel s-haya $
;;

(define (-*-compile-*- exp . mode)
;;
;;; Definition of operator numbers
;;
  (define %LD% '#0)
  (define %TLD% '#1)
  (define %GLD% '#2)
  (define %LDC% '#3)
  (define %LDF% '#4)
  (define %AP% '#5)
  (define %TAP% '#6)
  (define %PUSH% '#7)
  (define %RTN% '#8)
  (define %SEL% '#9)
  (define %TSEL% '#10)
  (define %ASSIG% '#11)
  (define %TASSIG% '#12)
  (define %GASSIG% '#13)
  (define %DEF% '#14)
  (define %PUSHCONS% '#15)
  (define %SAVE% '#16)
  (define %EXEC% '#17)
  (define %STOP% '#18)
;;
;; --- List of machine transitions ---
;;
;; S E (LD (i . j) . C) D R ==> S E C D r
;;  where r = (list-ref (list-ref E i) j)
;;
;; S E (TLD (i . j) . C) D R ==> S E C D r
;;  where r = (list-tail (list-ref E i) j)
;;
;; S E (GLD sym . C) D R ==> S E C D r
;;  where r = gloabl value of sym
;;
;; S E (LDC const . C) D R ==> S E C D const
;;
;; S E (LDF code . C) D R ==> S E C D (closure of code and E)
;;
;; (args . S) E (AP . C) D op ==>
;;  case: op is closure
;;    () (args . env) code (S E C . D) NIL
;;    where code is closure code of op and
;;    env is closure environment of op.
;;  case: op is primivite procedure
;;    First, execute primitive procedure op with arguments args
;;    and set registers to S E C D r, where r is the return
;;    value of primitine procedure op.
;;  case: op is continuation
;;    s e c d r
;;    where r is first element of args and
;;    s e c d are saved registers in op.
;;
;; (args . S) E (TAP . C) D op ==>
;;  case: op is closure
;;    () (args . env) code D NIL
;;    where code is closure code of op and
;;    env is closure environment of op.
;;  case: op is primivite procedure
;;    First, execute primitive procedure op with arguments args
;;    and set registers to S E C D r, where r is the return
;;    value of primitine procedure op.
;;  case: op is continuation
;;    s e c d r
;;    where x is the first element of args and
;;    s e c d r are saved registers in op.
;;
;; S E (PUSH . C) D R ==> (R . S) E C D R
;;
;; S E (RTN . C) (s e c . d) R ==> s e c d R
;;
;; S E (SEL ct cf . C) D test ==> S E cx (S E C . D) test
;;  where cx = (if test ct cf)
;;
;; S E (TSEL ct cf . C) D test ==> S E cx D test
;;  where cx = (if test ct cf)
;;
;; S E (ASSIG (i . j) . C) D R ==> S E' C D R
;;  where E' is made by
;;    (set-car! (list-tail (list-ref E i) j) R)
;;
;; S E (TASSIG (i . j) . C) D R ==> S E' C D R
;;  where E' is made by
;;    (if (zero? j)
;;      (set-car! (list-tail E i) R)
;;      (set-cdr! (list-tail (list-ref E i) (- j 1)) R))
;;
;; S E (GASSIG sym . C) D R ==> S E C D R
;;  where global value of sym = R
;;
;; S E (DEF sym . C) D R ==> S E C D sym
;;  where global value of sym = R
;;
;; (s . S) E (PUSHCONS . C) D R ==> ((R . s) . S) E C D R
;;
;; S E (SAVE C1 . C2) D R ==> S E C1 (S E C2 . D) R
;;
;; S E (EXEC . C) D code ==> NIL NIL code (S E C . D) NIL
;;
;; S E (STOP . C) D R ==> Stop SECDR execution
;;

;;
;;; comp assumes 5-syntaxes quote, lambda, if, define(top-level), set!
;;
  (define (comp exp vars cont tail)
;;
;;; Local procedures for comp
;;

;;  compile the body of lambda
    (define (comp-body e v c)
     (if (pair? e)
       (if (null? (cdr e))
         (comp (car e) v c #t)
         (comp (car e) v (comp-body (cdr e) v c) #f))
       (comp e v c #t)))

;;  compile arguments
    (define (comp-args e v c)
      (if (pair? e)
        (comp-args (cdr e) v (comp (car e) v (cons %PUSHCONS% c) #f))
        (comp e v (cons %PUSH% c) #f)))

;;  search a position of symbol in frame
    (define (frame-loc f s)
      (define (iter-list-loc i j l s)
        (if (pair? l)
          (if (eq? (car l) s)
              (cons (cons i j) #f)
              (iter-list-loc i (1+ j) (cdr l) s))
          (if (eq? l s) (cons (cons i j) #t) #f)))
      (define (iter-frame-loc i f s)
        (if (pair? f)
          (let ((loc (iter-list-loc i 0 (car f) s)))
            (if loc loc (iter-frame-loc (1+ i) (cdr f) s)))
          #f))
      (iter-frame-loc 0 f s))

;;
;;; Begining of main part of procedure 'comp'
;;
    (if (pair? exp)
      (cond
        ((eq? (car exp) 'quote)
          (cons %LDC% (cons (cadr exp) cont)))
        ((eq? (car exp) 'lambda)
          (cons %LDF%
                (cons
                  (comp-body
                    (cddr exp)
                    (cons (cadr exp) vars)
                    (cons %RTN% '()))
                  cont)))
        ((eq? (car exp) 'begin)
          (cons %LDF%
                (cons
                  (comp-body
                    (cdr exp)
                    (cons '() vars)
                    (cons %RTN% '()))
                  cont)))
        ((eq? (car exp) 'if)
          (let
            ((thenpt
               (comp (caddr exp) vars (cons %RTN% '()) #t))
             (elsept
               (comp (car (cdddr exp)) vars (cons %RTN% '()) #t)))
            (comp (cadr exp)
                  vars
                  (cons (if tail %TSEL% %SEL%)
                        (cons thenpt (cons elsept cont)))
                  #f)))
        ((eq? (car exp) 'define)
          (let ((loc (frame-loc vars (cadr exp))))
            (comp
              (caddr exp)
              vars
             (if loc
               (if (cdr loc)
                 (cons %TASSIG% (cons (car loc) cont))
                 (cons %ASSIG%  (cons (car loc) cont)))
               (cons %DEF% (cons (cadr exp) cont)))
             #f)))
        ((eq? (car exp) 'global-define)
          (comp
            (caddr exp)
            vars
            (cons %DEF% (cons (cadr exp) cont))
            #f))
        ((eq? (car exp) 'set!)
          (let ((loc (frame-loc vars (cadr exp))))
            (comp
              (caddr exp)
              vars
             (if loc
               (if (cdr loc)
                 (cons %TASSIG% (cons (car loc) cont))
                 (cons %ASSIG%  (cons (car loc) cont)))
               (cons %GASSIG% (cons (cadr exp) cont)))
             #f)))
        (#t (comp-args (cdr exp)
                       vars
                       (comp (car exp)
                             vars
                             (cons (if tail %TAP% %AP%) cont)
                             #f))))
      ;; else (pair? exp)
      (if (symbol? exp)
        (let ((loc (frame-loc vars exp)))
          (if loc
            (if (cdr loc)
              (cons %TLD% (cons (car loc) cont))
              (cons %LD% (cons (car loc) cont)))
            (cons %GLD% (cons exp cont))))
        (cons %LDC% (cons exp cont)))))
;;
;;; End of procedure 'comp'
;;

;;
;;; Macro expansion
;;
  (define (macro-expand exp)
    (define (tail-map proc lis)
      (if (pair? lis)
        (cons (proc (car lis)) (tail-map proc (cdr lis)))
        (proc lis)))
    (define (check-variables l)
      (let ((ch-var (lambda (s)
              (if (symbol? s)
                (if (or (get s '%special-form%)
                        (get s '%macro-special-form%))
                  (error "Unable to use specail-form form as varibale: " s)
                  #t)
              (error "Expect symbol: " s)))))
        (cond
          ((pair? l) (ch-var (car l)) (check-variables (cdr l)))
          ((null? l) #t)
          (#t (ch-var l)))))

    (if (pair? exp)
      (cond
;; lambda
        ((eq? (car exp) 'lambda)
          (let ((vars (cadr exp))
                (body (tail-map macro-expand (cddr exp))))
            (define (get-def-vars b)
              (if (pair? b)
                (if (pair? (car b))
		    (cond ((eq? (caar b) 'define)
			   (cons (cadar b) (get-def-vars (cdr b))))
			  ((eq? (caar b) 'if)
			   (append (get-def-vars (cdar b))
				   (get-def-vars (cdr b))))
			  ((and (pair? (caar b))(eq? (caaar b) 'begin))
			   (append (get-def-vars (cdaar b))
				   (get-def-vars (cdr b))))
			  (else (get-def-vars (cdr b))))
                    (get-def-vars (cdr b)))
                '()))
            (check-variables vars)
            (let ((def-vars (get-def-vars body)))
              (if (null? def-vars)
                 ;;
                 ;;; case of no internal defintion
                 ;;
                `(lambda ,vars ,@body)
                 ;;
                 ;;; case of internal definition
                 ;;
                 ;; (lambda (<var1> ...)
                 ;;   (define <def-var1> <def-body1>) ...
                 ;;   <body>)
                 ;; ==>
                 ;; (lambda (<var1> ...)
                 ;;   ((lambda (<def-var1> ...)
                 ;;      (define <def-var1> <def-body1>) ...
                 ;;      <body>)
                 ;;    '() ...))
                 ;;
                `(lambda ,vars
                   ((lambda ,def-vars ,@body)
                    ,@(map (lambda (a) ''()) def-vars)))))))
;; begin
        ((eq? (car exp) 'begin)
         `((begin
             ,@(tail-map macro-expand (cdr exp)))))
;; quote
        ((eq? (car exp) 'quote) exp)
;; define
        ((eq? (car exp) 'define)
          (let ((var
                  (if (pair? (cadr exp))
                    (caadr exp)
                    (cadr exp)))
                (body
                  (if (pair? (cadr exp))
                    `(lambda ,(cdadr exp) ,@(cddr exp))
                    (caddr exp))))
            (check-variables var)
            `(define ,var ,(macro-expand body))))
;; if
        ((eq? (car exp) 'if)
          `(if ,@(tail-map macro-expand
                   (if (null? (cdddr exp))
                     `(,@(cdr exp) #f)
                     (cdr exp)))))
;; set!
        ((eq? (car exp) 'set!)
          (check-variables (cadr exp))
          `(set! ,(cadr exp) ,(macro-expand (caddr exp))))
;; expansion of macro-special-form
        (#t
          (if (symbol? (car exp))
            (let ((macro-proc (get (car exp) '%macro-special-form%)))
              (if macro-proc
                (macro-expand (macro-proc exp))
                (cons (car exp) (tail-map macro-expand (cdr exp)))))
            (tail-map macro-expand exp))))
      (begin (if (symbol? exp) (check-variables exp)) exp)))
;;
;;; End of macro-expand
;;

  (put 'lambda '%special-form% #t)
  (put 'begin '%special-form% #t)
  (put 'quote '%special-form% #t)
  (put 'define '%special-form% #t)
  (put 'global-define '%special-form% #t)
  (put 'if '%special-form% #t)
  (put 'set! '%special-form% #t)

  (if (not (null? mode))
    (macro-expand exp)
    (comp (macro-expand exp) '() (cons %RTN% '()) #t)))
;;
;;; End of -*-compile-*-
;;

(define (macro-expand exp)
  (compile exp #t))