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

; Syntax objects

; The record definitions here are all "by hand" because
; `define-record-type' is defined using macros, which require the code
; here.

;(define-record-type :syntax-object
;  (make-syntax-object expr context lazy-count)
;  syntax?
;  (expr syntax-object-expr)
;  (context syntax-object-context)
;  ;; says how long the prefix of the context is that hasn't been
;  ;; propagated to the sub-exprs yet
;  (lazy-count syntax-object-lazy-count))
(define :syntax-object (make-record-type 'syntax-object '(expr context lazy-count)))
(define (make-syntax-object expr context lazy-count)
  (record :syntax-object expr context lazy-count))
(define (syntax? x)
  (and (record? x) (eq? (record-ref x 0) :syntax-object)))
(define (syntax-object-expr so)
  (checked-record-ref so :syntax-object 1))
(define (syntax-object-context so)
  (checked-record-ref so :syntax-object 2))
(define (syntax-object-lazy-count so)
  (checked-record-ref so :syntax-object 3))


(define (make-syntax thing stx)
  (make-syntax-object thing
		      (syntax-object-context stx)
		      0))

; Terminology:
; - a symbol is a Scheme symbol
; - a name is an identifier or a symbol
; - an identifier is a syntax object for which `syntax-e' returns a
;   symbol
; - a label is a sym or a symbol

(define (syntax-e stx)
  (let ((expr (syntax-object-expr stx))
	(ctx (syntax-object-context stx))
	(lazy-count (syntax-object-lazy-count stx)))
    (cond
     ((null? expr) expr)
     ((pair? expr)
      (let ((propagate (list-take lazy-count ctx)))
	(list-like-map (lambda (stx)
			 (add-context stx propagate))
		       expr)))
     ((vector? expr)
      (let ((propagate (list-take lazy-count ctx)))
	(list->vector (map (lambda (stx)
			     (add-context stx propagate))
			   (vector->list expr)))))
     (else expr))))

(define-record-discloser :syntax-object
  (lambda (r)
    (list 'syntax
	  (syntax-object-expr r)
	  (syntax-object-context r)
	  (syntax-object-lazy-count r))))

; Note we don't cancel marks on application, because the adjustment of
; the lazy count would be tricky.  `marks-of' does that job.
(define (add-context thing ctx)
  (cond
   ((not (syntax? thing))
    (make-syntax-object thing ctx (length ctx)))
   ((null? ctx) thing)
   (else
    (let ((e (syntax-object-expr thing))
	  (sctx (syntax-object-context thing)))
      (if (atomic? e)		; +++
	  (make-syntax-object e
			      (join-contexts ctx sctx)
			      0)
	  (make-syntax-object e
			      (append ctx sctx)
			      (+ (length ctx)
				 (syntax-object-lazy-count thing))))))))

(define (atomic? thing)
  (not (or (pair? thing)
	   (vector? thing))))

; this cancels out marks:
; ctx1 may not be simplified, ctx2 is
(define (join-contexts ctx1 ctx2)
  (if (null? ctx1)
      ctx2
      (let ((c (car ctx1)))
	(cond
	 ((null? (cdr ctx1))
	  (cond
	   ((null? ctx2) ctx1)
	   ((and (mark? c)
		 (eq? c (car ctx2)))
	    (cdr ctx2))
	   (else (cons c ctx2))))
	 ((and (mark? c)
	       (eq? c (cadr ctx1)))
	  (join-contexts (cddr ctx1) ctx2))
	 (else
	  (cons c
		(join-contexts (cdr ctx1) ctx2)))))))

;(define-record-type :mark
;  (really-make-mark token identifier phase transform-env)
;  mark?
;  ;; pair whose car will be #f at first, uid to be filled in
;  (token mark-token)
;  ;; identifier that the macro was bound to whose application created this mark
;  (identifier mark-identifier)
;  ;; phase the expander was in when the identifier was looked up
;  (phase mark-phase)
;  ;; transform environment of the macro
;  (transform-env mark-transform-env))
(define :mark (make-record-type 'mark '(token identifier phase transform-env)))
(define (really-make-mark token identifier phase transform-env)
  (record :mark token identifier phase transform-env))
(define (mark? x)
  (and (record? x) (eq? (record-ref x 0) :mark)))
(define (mark-token m)
  (checked-record-ref m :mark 1))
(define (mark-identifier m)
  (checked-record-ref m :mark 2))
(define (mark-phase m)
  (checked-record-ref m :mark 3))
(define (mark-transform-env m)
  (checked-record-ref m :mark 4))

(define (make-mark identifier phase transform-env)
  (really-make-mark (cons #f #f) identifier phase transform-env))

; #### temporary
(define (make-mark-with-uid identifier phase transform-env uid)
  (really-make-mark (cons uid #f) identifier phase transform-env))

(define *generated-uid* (list 0))

(define (mark-uid mark)
  (let ((token (mark-token mark)))
    (or (car token)
	(call-atomically
	 (lambda ()
	   (let ((uid (provisional-car *generated-uid*)))
	     (provisional-set-car! *generated-uid* (+ uid 1))
	     (set-car! token uid)
	     uid))))))

(define-record-discloser :mark
  (lambda (r)
    (list 'mark
	  (mark-uid r)
	  (mark-identifier r)
	  (mark-phase r)
	  (mark-transform-env r))))

;; Phase shift <<_>>p from Flatt 2002
;(define-record-type :phase-shift
;  (make-phase-shift delta)
;  phase-shift?
;  (delta phase-shift-delta))
(define :phase-shift (make-record-type 'phase-shift '(delta)))
(define (make-phase-shift delta)
  (record :phase-shift delta))
(define (phase-shift? x)
  (and (record? x) (eq? (record-ref x 0) :phase-shift)))
(define (phase-shift-delta ps)
  (checked-record-ref ps :phase-shift 1))

(define-record-discloser :phase-shift
  (lambda (r)
    (list 'phase-shift
	  (phase-shift-delta r))))

;; Only context element to syntax objects that are operators, set in stone
;(define-record-type :operator-context
;  (make-operator-context op)
;  operator-context?
;  (op operator-context-ref))
(define :operator-context (make-record-type 'operator-context '(op)))
(define (make-operator-context op)
  (record :operator-context op))
(define (operator-context? x)
  (and (record? x) (eq? (record-ref x 0) :operator-context)))
(define (operator-context-ref oc)
  (checked-record-ref oc :operator-context 1))

(define-record-discloser :operator-context
  (lambda (r)
    (list 'operator
	  (operator-context-ref r))))

(define (make-operator-syntax name)
  (let ((op (get-operator name)))
    (make-syntax-object name (list (make-operator-context op)) 0)))

(define (operator-syntax stx)
  (and (identifier? stx)
       (let ((ctx (syntax-object-context stx)))
	 (and (pair? ctx)
	      (operator-context? (car ctx))
	      (operator-context-ref (car ctx))))))

; ctx = (list ctxe)
; ctxe ::= rename | mark | definition-context | phase-shift | operator-context

;(define-record-type :rename
;  (really-make-rename from-name from-marks to-name to-phase)
;  rename?
;  ; #### the "name" terminology here should be revised
;  (from-name rename-from-name)        ;name (see below); identifier to be renamed
;  (from-marks rename-from-marks)    ;list of marks; marks of id. to be renamed
;  (to-name rename-to-name)            ;sym (see below); what matching idents. are
;				    ; renamed to
;  (to-phase rename-to-phase))       ;integer; the phase in which TO-NAME is
;                                    ; bound
(define :rename (make-record-type 'rename '(from-name from-marks to-name to-phase)))
(define (really-make-rename from-name from-marks to-name to-phase)
  (record :rename from-name from-marks to-name to-phase))
(define (rename? x)
  (and (record? x) (eq? (record-ref x 0) :rename)))
(define (rename-from-name r)
  (checked-record-ref r :rename 1))
(define (rename-from-marks r)
  (checked-record-ref r :rename 2))
(define (rename-to-name r)
  (checked-record-ref r :rename 3))
(define (rename-to-phase r)
  (checked-record-ref r :rename 4))

(define (make-rename id sym phase definition-context)
  ;; #### DEFINITION-CONTEXT is unused and should be removed
  (really-make-rename (syntax-object-expr id)
		      (syntax-object-marks id)
		      sym
		      phase))

(define-record-discloser :rename
  (lambda (r)
    (list 'rename
	  (rename-from-name r)
	  (rename-from-marks r)
	  (rename-to-name r)
	  (rename-to-phase r))))

; A definition context can also be #f
;(define-record-type :definition-context
;  (really-make-definition-context uid renames resolved-table)
;  definition-context?
;  (uid definition-context-uid)                ;for debugging
;  (renames definition-context-renames
;	   set-definition-context-renames!)
;  ;; RESOLVED-TABLE is either #F or a table, which records all
;  ;; identifiers that have been resolved or defined within this
;  ;; definition context.
;  (resolved-table definition-context-resolved-table
;		  set-definition-context-resolved-table!))
(define :definition-context
  (make-record-type 'definition-context '(uid renames resolved-table)))
(define (really-make-definition-context uid renames resolved-table)
  (record :definition-context uid renames resolved-table))
(define (definition-context? x)
  (and (record? x) (eq? (record-ref x 0) :definition-context)))
(define (definition-context-uid dc)
  (checked-record-ref dc :definition-context 1))
(define (definition-context-renames dc)
  (checked-record-ref dc :definition-context 2))
(define (set-definition-context-renames! dc new)
  (checked-record-set! dc :definition-context 2 new))
(define (definition-context-resolved-table dc)
  (checked-record-ref dc :definition-context 3))
(define (set-definition-context-resolved-table! dc new)
  (checked-record-set! dc :definition-context 3 new))

(define-record-discloser :definition-context
  ;; It would be nice to disclose the list of renames here, but that
  ;; would cause WRITE to diverge.
  (lambda (r)
    (list 'definition-context
	  (definition-context-uid r))))

;(define-record-type :package-context
;  (make-package-context package phase)
;  package-context?
;  (package package-context-package)
;  (phase package-context-phase))
(define :package-context (make-record-type 'package-context '(package phase)))
(define (make-package-context package phase)
  (record :package-context package phase))
(define (package-context? x)
  (and (record? x) (eq? (record-ref x 0) :package-context)))
(define (package-context-package pc)
  (checked-record-ref pc :package-context 1))
(define (package-context-phase pc)
  (checked-record-ref pc :package-context 2))

(define-record-discloser :package-context
  (lambda (r)
    (list 'package-context
	  (package-context-package r)
	  (package-context-phase r))))

(define (in-package-context package phase e)
  (make-syntax-object e
		      (list (make-package-context package phase))
		      0))

; for use in syntaxify
(define (package-reference-syntax package phase)
  (make-syntax-object '<danger>
		      (list (make-package-context package phase))
		      0))

; #### top-mark: later

(define (syntax-object-marks stx)
  (marks-of (syntax-object-context stx)))

(define (marks-of ctx)
  (if (null? ctx)
      '()
      (let ((ctxe (car ctx)))
	(if (mark? ctxe)
	    (adjoin-mark ctxe (marks-of (cdr ctx)))
	    (marks-of (cdr ctx))))))

(define (marks=? mrks1 mrks2)
  (cond
   ((null? mrks1) (null? mrks2))
   ((null? mrks2) #f)
   ((eq? (car mrks1) (car mrks2))
    (marks=? (cdr mrks1) (cdr mrks2)))
   (else #f)))

(define (adjoin-mark mark marks)
  (cond
   ((null? marks) (list mark))
   ((eq? mark (car marks)) (cdr marks))
   (else (cons mark marks))))

(define (add-mark stx mrk)
  (add-context stx (list mrk)))

(define (add-rename stx id sym phase)
  (add-context stx (list (make-rename id sym phase #f))))

(define (add-definition-context stx dctx)
  (if dctx
      (add-context stx (list dctx))
      stx))

(define (add-phase-shift stx delta)
  (if (zero? delta)
      stx
      (add-context stx (list (make-phase-shift delta)))))

; Manipulating syntax objects

(define (strip thing)
  (cond
   ((syntax? thing)
    ;; #### top-mark is missing, see Dybvig 2007
    (strip (syntax-object-expr thing)))
   ((pair? thing)
    (let ((a (strip (car thing)))
	  (d (strip (cdr thing))))
      (if (and (eq? a (car thing)) ; preserve sharing
	       (eq? d (cdr thing)))
	  thing
	  (cons a d))))
   ((vector? thing)
    (let* ((els (vector->list thing))
	   (stripped (map strip els)))
      (if (equal? els stripped) ; #### for-all eq?
	  thing
	  (list->vector stripped))))
   (else thing)))

(define (syntax->datum stx)
  (strip stx))
 
(define (identifier thing)
  (and (syntax? thing)
       (let ((e (syntax-object-expr thing)))
	 (if (symbol? e)
	     e
	     #f))))

(define (identifier? thing)
  (and (identifier thing) #t))

(define (generate-temporary thing)
  (let* ((thing
          (if (syntax? thing)
              (syntax-object-expr thing)
              thing))
         (name
          (cond
           ((symbol? thing)
            thing)
           ((string? thing)
            (string->symbol thing))
           (else 'temp))))
    ;; #### should do something to make them visibly distinct: get a uid for the mark
    ;; We don't use a sym because syms are intended purely as the target of renames
    (make-syntax-object name (list (make-mark #f #f #f)) 0)))

(define (generate-temporaries lis)
  (map generate-temporary
       (if (syntax? lis)
	   (syntax-object-expr lis)
	   lis)))

(define (self-quoting? thing)
  (or (boolean? thing)
      (number? thing)
      (char? thing)
      (string? thing))) ; #### (byte-vector? thing)


(define (syntaxify package datum)
  (datum->syntax (package-reference-syntax package 0)
		 datum))

(define (datum->syntax stx datum)
  (let ((ctx (if stx (syntax-object-context stx) '())))
    (let recur ((datum datum))
      (cond
       ((syntax? datum) datum)
       ((or (null? datum)
	    (symbol? datum)
	    (self-quoting? datum))
	(make-syntax-object datum ctx 0))
       ((vector? datum)
	(make-syntax-object (list->vector (map recur (vector->list datum))) ctx 0))
       ((pair? datum)
	(make-syntax-object (list-like-map recur datum) ctx 0))
       (else
	(assertion-violation 'datum->syntax
			     "invalid datum" datum))))))

(define (bound-identifier=? id1 id2)
  ;; (assert (identifier? id1))
  ;; (assert (identifier? id2))
  (and (eq? (syntax-object-expr id1) (syntax-object-expr id2))
       (equal? (marks-of (syntax-object-context id1))
	       (marks-of (syntax-object-context id2)))))

; A syntax pair is a pair containing a syntax object as its first
; element, and either the empty list, a syntax pair, or a syntax
; object as its second element.

; optimization: sharing of e and the return value
(define (syntax->list stx)
  (let loop ((e (syntax-e stx))
	     (els '()))
    (cond
     ((null? e)
      (reverse els))
     ((pair? e)
      (loop (cdr e)
	    (cons (car e) els)))
     ((syntax? e)
      (loop (syntax-e e) els))
     (else
      #f))))

(define (stx-null? thing)
  (or (null? thing)
      (and (syntax? thing) 
	   (null? (syntax-e thing)))))

(define (stx-pair? thing)
  (or (pair? thing)
      (and (syntax? thing)
	   (pair? (syntax-e thing)))))
	  
(define (stx-list? thing)
  (or (list? thing)
      (if (syntax? thing) 
	  (or (list? (syntax-e thing))
	      (let loop ((l (syntax-e thing)))
		(if (pair? l)
		    (loop (cdr l))
		    (stx-list? l))))
	  (and (pair? thing)
	       (stx-list? (cdr thing))))))

(define (stx-car thing)
  (if (pair? thing)
      (car thing)
      (car (syntax-e thing))))

(define (stx-cdr thing)
  (if (pair? thing)
      (cdr thing)
      (cdr (syntax-e thing))))

; particularly common
(define (stx-cadr x) (stx-car (stx-cdr x)))

(define (stx->list e)
  (if (syntax? e)
      (syntax->list e)
      (let ((flat-end
	     (let loop ((l e))
	       (cond
		((null? l) #f)
		((pair? l)
		 (loop (cdr l)))
		((syntax? l) 
		 (syntax->list l))
		(else #f)))))
	(if flat-end
	    ;; flatten
	    (let loop ((l e))
	      (cond ((null? l) '())
		    ((pair? l) 
		     (cons (car l) (loop (cdr l))))
		    ((syntax? l) flat-end)
		    (else #f)))
	    e))))

(define (stx-this-long? l n)
  (cond ((stx-null? l)
	 (= n 0))
	((stx-pair? l)
	 (list-this-long? (stx-cdr l) (- n 1)))
	(else
	 #f)))

(define (stx-at-least-this-long? l n)
  (cond ((stx-null? l)
	 (<= n 0))
	((stx-pair? l)
	 (list-at-least-this-long? (stx-cdr l) (- n 1)))
	(else
	 #f)))

(define (stx-vector thing)
  (cond
   ((vector? thing) thing)
   ((and (syntax? thing)
	 (let ((e (syntax-e thing)))
	   (and (vector? e)
		e))))
   (else #f)))

(define (stx-2list? x)
  (and (stx-pair? x)
       (stx-pair? (stx-cdr x))
       (stx-null? (stx-cdr (stx-cdr x)))))

; --------------------
; Utilities

; works on dotted pairs
(define (list-like-map proc lis)
  (cond
   ((null? lis) '())
   ((pair? lis)
    (cons (proc (car lis))
	  (list-like-map proc (cdr lis))))
   (else (proc lis))))

(define (list-take n lis)
  (if (zero? n)
      '()
      (cons (car lis) (list-take (- n 1) (cdr lis)))))

(define (list-this-long? l n)
  (cond ((null? l)
	 (= n 0))
	((pair? l)
	 (list-this-long? (cdr l) (- n 1)))
	(else
	 #f)))

(define (list-at-least-this-long? l n)
  (cond ((null? l)
	 (<= n 0))
	((pair? l)
	 (list-at-least-this-long? (cdr l) (- n 1)))
	(else
	 #f)))
