[bpt/guile.git] / module / language / r5rs / translate.scm

;;; translate.scm --- Scheme to Guile IL translator

;; Copyright (C) 2001 Free Software Foundation, Inc.

;; This file is part of Guile VM.

;; Guile VM 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.
;; 
;; Guile VM 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 Guile VM; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

(define-module (language r5rs translate)
  :export (translate))

(define (translate x) (trans x))

(define (trans x) (if (pair? x) (trans-pair x) x))

(define *primitive-procedure-list*
  '(void car cdr cons + - * / < >))

(define (trans-pair x)
  (let ((name (car x)) (args (cdr x)))
    (let ((il (case name
		((quote) (cons '@quote args))
		((define set! if and or begin)
		 (cons (symbol-append '@ name) (map trans args)))
		((let let* letrec)
		 (cons* (symbol-append '@ name)
			(map (lambda (b)
			       (cons (car b) (map trans (cdr b))))
			     (car args))
			(map trans (cdr args))))
		((lambda)
		 (cons* '@lambda (trans-formals (car args))
			(map trans (cdr args))))
		(else
		 (if (memq name *primitive-procedure-list*)
		     ;; FIXME: Temporary hack for direct optimization
		     (cons (symbol-append '@ name) (map trans args))
		     (cons (trans name) (map trans args))))))
	  (props (source-properties x)))
      (if (not (null? props))
	  (set-source-properties! il props))
      il)))

(define (trans-formals formals)
  (cond ((symbol? formals) `(:rest ,formals))
	((or (null? formals) (null? (cdr (last-pair formals)))) formals)
	(else
	 (let* ((list (list-copy formals))
		(last (last-pair list)))
	   (set-cdr! last `(:rest ,(cdr last)))
	   list))))

;;; translate.scm ends here
Commit	Line	Data
296ad2b4 KN	1	;;; translate.scm --- Scheme to Guile IL translator
	2
	3	;; Copyright (C) 2001 Free Software Foundation, Inc.
	4
	5	;; This file is part of Guile VM.
	6
	7	;; Guile VM is free software; you can redistribute it and/or modify
	8	;; it under the terms of the GNU General Public License as published by
	9	;; the Free Software Foundation; either version 2, or (at your option)
	10	;; any later version.
	11	;;
	12	;; Guile VM is distributed in the hope that it will be useful,
	13	;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	14	;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	15	;; GNU General Public License for more details.
	16	;;
	17	;; You should have received a copy of the GNU General Public License
	18	;; along with Guile VM; see the file COPYING. If not, write to
	19	;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
	20	;; Boston, MA 02111-1307, USA.
	21
	22	(define-module (language r5rs translate)
	23	:export (translate))
	24
	25	(define (translate x) (trans x))
	26
	27	(define (trans x) (if (pair? x) (trans-pair x) x))
	28
9d3903db KN	29	(define primitive-procedure-list
	30	'(void car cdr cons + - * / < >))
	31
296ad2b4 KN	32	(define (trans-pair x)
	33	(let ((name (car x)) (args (cdr x)))
	34	(let ((il (case name
	35	((quote) (cons '@quote args))
	36	((define set! if and or begin)
	37	(cons (symbol-append '@ name) (map trans args)))
	38	((let let* letrec)
	39	(cons* (symbol-append '@ name)
	40	(map (lambda (b)
	41	(cons (car b) (map trans (cdr b))))
	42	(car args))
	43	(map trans (cdr args))))
	44	((lambda)
	45	(cons* '@lambda (trans-formals (car args))
	46	(map trans (cdr args))))
9d3903db KN	47	(else
	48	(if (memq name primitive-procedure-list)
	49	;; FIXME: Temporary hack for direct optimization
	50	(cons (symbol-append '@ name) (map trans args))
	51	(cons (trans name) (map trans args))))))
296ad2b4 KN	52	(props (source-properties x)))
	53	(if (not (null? props))
	54	(set-source-properties! il props))
	55	il)))
	56
	57	(define (trans-formals formals)
	58	(cond ((symbol? formals) `(:rest ,formals))
	59	((or (null? formals) (null? (cdr (last-pair formals)))) formals)
	60	(else
	61	(let* ((list (list-copy formals))
	62	(last (last-pair list)))
	63	(set-cdr! last `(:rest ,(cdr last)))
	64	list))))
	65
	66	;;; translate.scm ends here