; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.


; The DEFINE-INTERFACE and DEFINE-STRUCTURE macros.

(define-syntax def
  (syntax-rules ()
    ((def (?name . ?args) ?body ...)
     (really-def () ?name (lambda ?args ?body ...)))
    ((def ?name ...)
     (really-def () ?name ...))))

(define-syntax really-def
  (syntax-rules ()
    ((really-def (?name ...) ?exp)
     (define-multiple (?name ...)
       (begin (verify-later! (lambda () ?name))
	      ...
	      ?exp)))
    ((really-def (?name ...) ?name1 ?etc ...)
     (really-def (?name ... ?name1) ?etc ...))))

(define-syntax define-multiple
  (syntax-rules ()
    ((define-multiple (?name) ?exp)
     (define ?name (note-name! ?exp '?name)))
    ((define-multiple (?name ...) ?exp)
     (begin (define ?name #f)
	    ...
	    (let ((frob (lambda things
			  (begin (set! ?name
				       (note-name! (car things) '?name))
				 (set! things (cdr things)))
			  ...)))
	      (call-with-values (lambda () ?exp) frob))))))


; Interfaces

; <definition> ::= (define-interface <name> <int>)
; <int> ::= <name> | (export <item> ...) | (compound-interface <int> ...)

(define-syntax define-interface
  (syntax-rules ()
    ((define-interface ?name ?int)
     (def ?name ?int))))

(define-syntax compound-interface
  (syntax-rules ()
    ((compound-interface ?int ...)
     (make-compound-interface #f ?int ...))))

; <item> ::= <name> | (<name> <type>) | ((<name> ...) <type>) 
;          | (<name> <phase>) (<name> <phase> <type>)
;          | ((<name> ...) <phase>) ((<name> ...) <phase> <type>)
; <phase> ::= (meta <int>) | run | expand

(define-syntax export
  (lambda (e r c)
    (let ((%quote (r 'quote))
	  (%list (r 'list))
	  (%meta (r 'meta))
	  (%run (r 'run))
	  (%expand (r 'expand)))
      
      (define (maybe-parse-phase spec)
	(cond
	 ((c spec %run) 0)
	 ((c spec %expand) 1)
	 ((and (pair? spec)
	       (c (car spec) %meta))
	  (cadr spec))
	 (else #f)))

      (let loop ((items (cdr e))
		 (ops '()))
	(if (null? items)
	    `(,(r 'make-simple-interface)
	      #f
	      (,%list ,@(reverse ops)))
	    (let ((item (car items)))
	      (cond
	       ((not (pair? item))
		(loop (cdr items)
		      (cons `(,%quote ,item) ops)))
	       ((maybe-parse-phase (cadr item))
		=> (lambda (phase)
		     (loop (cdr items)
			   (cons `(,%list (,%quote ,(car item))
					  ,phase
					  ,@(cddr item))
				 ops))))
	       (else
		(loop (cdr items)
			   (cons `(,%list (,%quote ,(car item))
					  ,(cadr item))
				 ops)))))))))
  (make-simple-interface list quote value))

		    
; Structures

(define-syntax define-structure
  (syntax-rules ()
    ((define-structure ?name ?int ?clause1 ?clause ...)
     (def ?name (structure ?int ?clause1 ?clause ...)))
    ;; For compatibility.  Use DEF instead.
    ((define-structure ?name ?exp)
     (def ?name ?exp))))

(define-syntax define-structures
  (syntax-rules ()
    ((define-structures ((?name ?int) ...)
       ?clause ...)
     (def ?name ... (structures (?int ...) ?clause ...)))))

(define-syntax structure
  (syntax-rules ()
    ((structure ?int ?clause ...)
     (structures (?int) ?clause ...))))

(define-syntax structures
  (syntax-rules ()
    ((structures (?int ...) ?clause ...)
     (let ((p (a-package #f ?clause ...)))
       (values (make-structure p (lambda () ?int))
	       ...)))))

(define-syntax modify
  (syntax-rules ()
    ((modify ?struct ?command ...)
     (make-modified-structure ?struct '(?command ...)))))

; Two handy shorthands for MODIFY.

(define-syntax subset
  (syntax-rules ()
    ((subset struct (name ...))
     (modify struct (expose name ...)))))

(define-syntax with-prefix
  (syntax-rules ()
    ((with-prefix struct the-prefix)
     (modify struct (prefix the-prefix)))))

(define-syntax for
  (syntax-rules (meta expand run)
    ((for ?struct (meta ?level))
     (cons ?level (lambda () (list ?struct))))
    ((for ?struct run)
     (for ?struct (meta 0)))
    ((for ?struct expand)
     (for ?struct (meta 1)))))

; Packages

(define-syntax a-package
  (let ()

    (define (add-to-phase alist phase opens)
      (let recur ((alist alist))
	(cond
	 ((null? alist)
	  (list (cons phase opens)))
	 ((= phase (caar alist))
	  (cons (cons phase
		      (append (cdar alist) opens))
		(cdr alist)))
	 (else
	  (cons (car alist)
		(recur (cdr alist)))))))

    (define (parse-package-clauses form clauses rename compare)
      (let ((%open (rename 'open))
	    (%for-syntax (rename 'for-syntax))
	    (%no-default-opens (rename 'no-default-opens))
	    (%for (rename 'for))
	    (%lambda (rename 'lambda))
	    (%list (rename 'list)))
	

	(define (parse-for-syntax form alist clause rename compare)
      
	  (let recur ((phase 1)
		      (clauses (cdr clause))
		      (alist alist))
	    (if (null? clauses)
		alist
		(let* ((clause (car clauses))
		       (keyword (car clause)))
		  (cond
		   ((compare keyword %for-syntax)
		    (recur phase
			   (cdr clauses)
			   (recur (+ 1 phase)
				  (cdr clause)
				  alist)))
		   ((compare keyword %open)
		    (recur phase
			   (cdr clauses)
			   (add-to-phase alist phase (cdr clause))))
		   (else
		    (display "Ignoring invalid for-syntax clause")
		    (newline)
		    (write clause)
		    (newline)))))))

	;; Of the open specs, phased specs of the form (for ... ...) 
	;; expand into expressions that evaluate to a pair (phase
	;; . thunk), which is OK as an argument to `make-a-package',
	;; wherease regular unphased specs evaluate to structures
	;; directly - need to convert those into thunks.

	;; (for ... ...) open spec?
	(define (phased? spec)
	  (and (pair? spec)
	       (compare %for (car spec))))

	;; don't create too many thunks (probably overkill)
	(define (parse-open clause rename compare)

	  ;; don't know whether the first spec is regular
	  (define (add-regular specs opens)
	    (let loop ((specs specs)
		       (new-opens '()))

	      (define (finish-opens)
		(if (null? new-opens)
		    opens
		    (cons `(,%lambda () (,%list ,@(reverse new-opens))) opens)))

	      (cond
	       ((null? specs) (finish-opens))
	       ((phased? (car specs))
		(add-phased specs (finish-opens)))
	       (else
		(loop (cdr specs) (cons (car specs) new-opens))))))

	  ;; first spec is definitely phased, so opens never finishes empty
	  (define (add-phased specs opens)
	    (cond
	     ((null? specs) (reverse opens))
	     ((phased? (car specs))
	      (add-phased (cdr specs) (cons (car specs) opens)))
	     (else
	      (add-regular specs opens))))

	  (add-regular (cdr clause) '()))

	(let loop ((clauses clauses)
		   (opens '())
		   (for-syntax-alist '())
		   (no-default-opens? #f)
		   (others '()))
	  (cond ((null? clauses)
		 (values opens for-syntax-alist no-default-opens? (reverse others)))
		((not (list? (car clauses)))
		 (display "Ignoring invalid define-structures clause")
		 (newline)
		 (write (car clauses)) (newline)
		 (loop (cdr clauses)
		       opens
		       for-syntax-alist no-default-opens?
		       others))
		(else
		 (let ((keyword (caar clauses)))
		   (cond ((compare keyword %open)
			  (loop (cdr clauses)
				(append opens (parse-open (car clauses) rename compare))
				for-syntax-alist no-default-opens?
				others))
			 ((compare keyword %for-syntax)
			  (loop (cdr clauses)
				opens
				(parse-for-syntax form for-syntax-alist (car clauses) rename compare)
				#f
				others))
			 ((compare keyword %no-default-opens)
			  (loop (cdr clauses)
				opens
				'()
				#t
				others))
			 (else
			  (loop (cdr clauses)
				opens
				for-syntax-alist no-default-opens?
				(cons (car clauses) others))))))))))

    (lambda (form rename compare)
      (let ((names (cadr form))
	    (clauses (cddr form)))
	(call-with-values (lambda ()
			    (parse-package-clauses form clauses rename compare))
	  (lambda (opens for-syntax-alist no-default-opens? others)
	    (let ((%make (rename 'make-a-package))
		  (%lambda (rename 'lambda))
		  (%cons (rename 'cons))
		  (%list (rename 'list))
		  (%quote (rename 'quote))
		  (%a-package (rename 'a-package))
		  (%file-name (rename '%file-name%)))
	      `(,%make (,%list ,@opens)
		       (,(string->symbol ".make-syntactic-tower.")
			,(if no-default-opens?
			     #f
			     `(,%quote ,for-syntax-alist))
			(,%quote ,names))		; for discloser
		       ,(string->symbol ".reader.")
		       (,%file-name)
		       (,%quote ,others)
		       (,%quote ,names))))))))
  (cons lambda list make-a-package quote make-syntactic-tower %file-name%))


; This takes a procedure that accepts three arguments:
; - an optional filename
; - a port
; - a mode
; The mode is one of:
; 'datum
; 'script
; 'all
; Where 'script is like 'all, except it skips the first line
; If mode is 'datum, a single datum is returned, otherwise a list of
; datums is returned.

(define-syntax define-reader
  (lambda (e r c)
    `(,(r 'define) ,(string->symbol ".reader.") ,(cadr e)))
  (define))

; (DEFINE-SYNTACTIC-TOWER-MAKER <proc>)
;   <proc> should be an expression that evaluates to a procedure of
;   two arguments.  The first argument describes the for-syntax
;   clauses in the DEFINE-STRUCTURE form: It is either #f (meaning
;   that a `no-default-opens' clause was present), or an alist mapping
;   phases to lists of structure name. The second argument is some
;   identifying information (no semantic content).
;
;   The procedure should return a "syntactic tower", which is a a
;   vector #(<compile-syntax-node-proc> <make-lookup-package> <alist>).
;   The <alist> maps phase levels to thunks yielding lists of
;   structures.  To evaluate the right-hand side of a DEFINE-SYNTAX
;   (LET-SYNTAX, etc.) form, <compile-syntax-node-proc> is called on
;   the name of a syntax binding, the expanded right-hand side (a
;   node) and a suitable compile-time environment.  The compile-time
;   environment refers to the structures from the <alist> at the
;   appropriate phase (1 for macro expansion, 2 for its macros etc.).

;   The <compile-syntax-node-proc> turns two values: a template with the
;   compiled code (or #f during linking), and a thunk running the
;   compiled code.

;   The <make-lookup-package> procedure is procedure that accepts a
;   package and returns a procedure
;   lookup : package phase -> phase
;   This lookup procedure represents a compile-time environment that
;   maps a phase-0 package to its instantiation at the specified
;   phase.  <make-lookup-package> will be called once for the
;   compilation of a package and get passed that package.
;
;   <compile-syntax-node-proc> and <make-lookup-package>> are
;   different for the building of the initial.image (where there's no
;   way to run bytecode) and an actual running system.
;
; Got that?

(define-syntax define-syntactic-tower-maker
  (lambda (e r c)
    `(,(r 'begin)
      (,(r 'define) ,(string->symbol ".make-syntactic-tower.") ,(cadr e))
      ;; backwards compatibility for PreScheme compiler
      (,(r 'define) ,(string->symbol ".make-reflective-tower.") ,(string->symbol ".make-syntactic-tower."))))
  (define))

;; This now exports everything that could be needed in a new config
;; package.
(define-syntax export-syntactic-tower-maker
  (lambda (e r c)
    `(,(r 'export) ,@(map string->symbol '(".make-syntactic-tower."
					   ".make-reflective-tower."
					   ".reader."))))
  (export))

;; backwards compatibility
(define-syntax export-reflective-tower-maker
  (lambda (e r c)
    `(,(r 'export-syntactic-tower-maker)))
  (export-syntactic-tower-maker))

; Modules  = package combinators...

(define-syntax define-module
  (syntax-rules ()
    ((define-module (?name . ?args) ?body ...)
     (def ?name (lambda ?args ?body ...)))))
