;;;===============================================================================
;;;
;;; Larceny compatibility file (tested on Larceny version 0.93) 
;;;
;;; Uncomment appropriate LOAD comand in macros-core.scm
;;;
;;; June 22, 2007
;;;
;;;===============================================================================

; Most of this was written by Will Clinger.

(require 'srfi-9)

(read-square-bracket-as-paren #t)

; Approximation to unique token:

(define (ex:unique-token)
  (let ((p (open-output-file "temp")))
    (write #f p)
    (close-output-port p))
  (let ((time (file-modification-time "temp")))
    (number->string 
     (+ (vector-ref time 5)
        (* (vector-ref time 4) 60)
        (* (vector-ref time 3) 3600)
        (* (vector-ref time 2) 86400)
        (* (vector-ref time 1) 2678400) ; assumes 31 d/m - just need unique number
        (* (- (vector-ref time 0) 2000) 32140800)))))   
       
; Native make-parameter takes two arguments, so change here:

(define larceny:make-parameter make-parameter)
(define (make-parameter val)
  (larceny:make-parameter "anonymous" val))

; #'<expression> syntax
; #`<expression> syntax
; #,<expression> syntax
; #,@<expression> syntax
;
; Hacked up by Will Clinger, starting from Lars Hansen's
; implementation of Common Lisp's #.<expression> syntax.

(let* ((sharp-reader (readtable-ref #\#))
       (sharp-class (car sharp-reader))
       (sharp-dispatch (cadr sharp-reader))
       (sharp-dispatch-list (caddr sharp-reader)))

  (define (read-interesting-character p)
    (let ((c (peek-char p)))
      (if (memv c '(#\' #\` #\,))
          (begin
            (read-char p)
            (if (eof-object? (peek-char p))
                (error (string-append "EOF found following #"
                                      (string sharpchar))))
            c)
          #f)))

  (define (read-datum p)
    (let* ((c (read-char p))
           (e ((cadr (readtable-ref c)) c p)))
      e))

  (define (bug sharpchar)
    (error (string-append "Bug in #' reader: " (string sharpchar))))

  (define (new-sharp-dispatch c p)
    (let ((sharpchar (read-interesting-character p)))
      (if sharpchar
          (case sharpchar
           ((#\' #\`)
            (list (case sharpchar
                   ((#\') 'syntax)
                   ((#\`) 'quasisyntax)
                   (else (bug sharpchar)))
                  (read-datum p)))
           ((#\,)
            (if (eqv? (peek-char p) #\@)
                (begin (read-char p)
                       (list 'unsyntax-splicing (read-datum p)))
                (list 'unsyntax (read-datum p))))
           (else (bug sharpchar)))
          (sharp-dispatch c p))))

  ; The default behavior for sharp-dispatch-list is to call on the
  ; installed non-list sharp-dispatcher, so rely on that.

  (readtable-set! #\# (list sharp-class
                            new-sharp-dispatch
                            sharp-dispatch-list))
  'sharp-syntax)