;;;;
;;;; runtime.stk	-- Stuff necessary for bootstaping the system
;;;;
;;;; Copyright © 2001-2010 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 15-Mar-2001 22:49 (eg)
;;;; Last file update: 28-Oct-2010 15:18 (eg)
;;;;


(define (map* fn . l) 		; A map which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (cons (apply fn      (map car l))
			  (apply map* fn (map cdr l))))
   (else            (apply fn l))))

(define (for-each* fn . l) 	; A for-each which accepts dotted lists (arg lists
  (cond 			; must be "isomorph"
   ((null? (car l)) '())
   ((pair? (car l)) (apply fn (map car l)) (apply for-each* fn (map cdr l)))
   (else            (apply fn l))))


(define (filter-map func . args)
  (filter (lambda (x) x)
	  (apply map func args)))
#| example
  (filter-map (lambda (x) (and (number? x) (+ x 1)))
	    '(1 2 foo "bar" 7))

|#

(define (append-map proc . args)
  (apply append (apply map proc args)))

(define (append-map! proc . args)
  (apply append! (apply map proc args)))


(define (symbol-append . args)
  (let loop ((args args)
	     (res  ""))
    (if (null? args)
	(string->symbol res)
	(loop (cdr args)
	      (string-append res (format "~a" (car args)))))))

;; ----------------------------------------------------------------------
;; 	parameters
;; ----------------------------------------------------------------------
#|
<doc EXT stklos-debug-level
 * (stklos-debug-level)
 *
 * |stklos-debug-level| is a parameter objet. It permits to know the current
 * debugging level. The default value of this parameter is 0 (meaning "no debug").
 * Note that the debugging level can also be set by the |--debug| option of the
 * |stklos(1)| command.
doc>
|#
(define stklos-debug-level
  (make-parameter 0))

;; ----------------------------------------------------------------------
;;	*%system-state-plist* ...
;; ----------------------------------------------------------------------
(define *%system-state-plist*  (list :name "STklos"))

;; ----------------------------------------------------------------------
;;	management of globals ...
;; ----------------------------------------------------------------------
;; This should be in compiler module but it a nightmare with bootstrap.
(define compiler-known-globals
  (make-parameter '()))

(define (register-new-global! symbol)
  (let ((lst (compiler-known-globals)))
    (unless (memq symbol lst)
      (compiler-known-globals (cons symbol lst)))))



;;; ----------------------------------------------------------------------
;;;
;;; 				E x p a n d e r s
;;;
;;; ----------------------------------------------------------------------
(define *expander-list*     '())	; the macros
(define *expander-list-src* '())	; their source code
(define *expander-published* '())	; names of the macro to "publish"

(define (expander? x)
  (assq x *expander-list*))


(define (application-expander x e)
  (map* (lambda (y) (e y e)) x))


(define (initial-expander x e)
 (cond
   ((not (pair? x))   	      x)
   ((not (symbol? (car x)))  (application-expander x e))
   (else  (let ((functor (car x)))
	    (cond
	       ((expander? functor) ((cdr (assq functor *expander-list*)) x e))
	       (else (application-expander x e)))))))


(define (install-expander! id proc code)
  ;; Add the new macro to the expander list
  (let ((old (assq id *expander-list*)))
    (if old
      (set-cdr! old proc)
      (set! *expander-list* (cons (cons id proc) *expander-list*))))
  ;; Global macro: Keep the macro code to eventually save it in byte-code header
  (let ((old (assq id *expander-list-src*)))
    (if old
      (set-cdr! old code)
      (set! *expander-list-src* (cons (cons id code) *expander-list-src*)))))


(define (push-expander! id proc)
  ;; Used by internal macro. Macro is pushed on the list to shadow the global one
  (set! *expander-list* (cons (cons id proc) *expander-list*)))


(define (delete-expander! id)
  (let loop ((lst *expander-list*)
	     (prv #f))
    (cond
      ((null? lst)
         (void))
      ((eq? (caar lst) id)
         (if prv
	   (set-cdr! prv (cdr lst))
	   (set! *expander-list* (cdr lst))))
      (else
         (loop (cdr lst) lst)))))

;;;
;;; Published macro management
;;;
(define (expander-published-reset!)
  (set! *expander-list-src* '())
  (set! *expander-published* '()))

(define (expander-published-sources)
  (let ((warning (in-module |STKLOS-COMPILER| compiler-warning)))
    (let Loop ((lst *expander-published*)
	       (res '()))
      (if (null? lst)
	  (reverse! res)
	  (let ((mac (assoc (car lst) *expander-list-src*)))
	    (if mac
		(Loop (cdr lst) (cons mac res))
		(begin
		  (warning (void) 'export-syntax
			   "cannot find source of syntax named ~S" (car lst))
		  (Loop (cdr lst) res))))))))

(define (expander-published-add! name)
  (unless (memq name *expander-published*)
    (set! *expander-published* (cons name *expander-published*))))

;;;
;;; Runtime support for R5RS macro
;;;
(define (syntax-expand expr) expr)

(define (macro-expand x)
  (initial-expander (syntax-expand x) initial-expander))

(define (macro-expand* exp)
  (let ((new (macro-expand exp)))
    (if (equal? new exp)
        new
        (macro-expand* new))))

;; ======================================================================
(define %macro-expand*
  (let ((expand (lambda (x)
		  ;; as macro-expand without syntax expand (used by full-syntax)
		  (initial-expander x (lambda (x e) x)))))
    (lambda (exp)
      (let ((new (expand exp)))
	(if (equal? new exp)
	    new
	    (%macro-expand* new))))))