joy-in-the-morning/language/joy/compile-tree-il.scm

;;; compile-tree-il.scm -- compile Joy to tree-il.
;;; Copyright © 2016, 2020 Eric Bavier <bavier@member.fsf.org>
;;;
;;; Joy 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 3 of the License, or (at your
;;; option) any later version.
;;;
;;; Joy 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 Joy.  If not, see <http://www.gnu.org/licenses/>.

(define-module (language joy compile-tree-il)
  #:use-module (language tree-il)
  #:use-module (system base pmatch)
  #:use-module (srfi srfi-1)
  #:export (compile-tree-il compile-tree-il*))

;;; Guile 2.2 changed the external representation for a procedure call
;;; from 'apply' to 'call'.
(define call
  (if (or (> (string->number (major-version)) 2)
          (and (= (string->number (major-version)) 2)
               (>= (string->number (minor-version)) 2)))
      'call
      'apply))

(define (location x)
  (and (pair? x)
       (let ((props (source-properties x)))
	 (and (not (null? props))
              props))))

(define *eval* '(language joy eval))

(define (compile-factor fact)
  (cond
   ((list? fact) (map compile-factor fact))
   ((string? fact) (string->list fact))
   (else fact)))

(define (compile-term term)
  `(const ,(map compile-factor term)))

(define (compile-expr expr)
  (let ((sym (gensym "S-")))
    `(lambda ()
       (lambda-case ((() #f S #f () (,sym))
		     (,call (@ (srfi srfi-1) fold)
			    (@@ ,*eval* eval)
			    (lexical S ,sym)
			    ,(compile-term expr)))))))

(define (process-options! opts)
  #t)

(define (compile-tree-il expr env opts)
  "Compile Joy expression to Tree-IL."
  (call-with-values
      (lambda () (compile-tree-il* expr env opts))
    (lambda (rep env cenv)
      (values
       (parse-tree-il rep)
       env
       cenv))))

(define (compile-tree-il* expr env opts)
  "Compile Joy expression to Tree-IL external representation."
  (values
   (begin
     (process-options! opts)
     (compile-expr expr))
   env
   env))