;		       Copyright (C) 1992 by Marc Feeley -- all rights reserved

;; "_nonstandard.scm"

(##include "header.scm")

;------------------------------------------------------------------------------

; Non-standard procedures

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(##define-macro (define-macro . rest)
  `(##eval-global '(##define-macro ,@rest)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (exit)
  (##quit))

(define (error msg . args)
  (##call-with-current-continuation (lambda (cont) (##sequentially (lambda ()
    (##identify-error #f msg args '())
    (##debug-repl cont))))))

(define (eval expr)
  (##eval-global expr))

(define (compile filename . options)
  (touch-vars (filename)
    (check-string filename (compile filename . options)
      (let ((cf c#cf))
        (if (##procedure? c#cf)
          (##apply cf (##cons filename (##cons 'M68000 options)))
          (##runtime-error
            "Compiler is not loaded"
            'compile
            (##cons filename options)))))))
  
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define-macro (trace . procs)

  (define (tr l)
    (if (##pair? l)
      (let ((var (##car l)))
        (##cons (##list '##TRACE
                        (##list 'QUOTE var)
                        var
                        (##list 'LAMBDA '(##VAL) (##list 'SET! var '##VAL)))
                (tr (##cdr l))))
      '()))

  (if (##pair? procs)
    (##cons 'BEGIN (tr procs))
    `(##trace-list)))

(define-macro (untrace . procs)

  (define (untr l)
    (if (##pair? l)
      (let ((var (##car l)))
        (##cons (##list '##UNTRACE (##list 'QUOTE var)) (untr (##cdr l))))
      '()))

  (if (##pair? procs)
    (##cons 'BEGIN (untr procs))
    `(##untrace-all)))

(define ##traced '())

(define (##trace name proc setter)

  (define (add-quotes l)
    (if (##pair? l)
      (let ((x (##car l)))
        (##cons (if (##self-eval? x) x (##list 'QUOTE x))
                (add-quotes (##cdr l))))
      '()))

  (define (traced-proc proc)
    (lambda args
      (let* ((i (##dynamic-ref '##TRACE-INDENT 0))
             (w (if (##fixnum.< 40 i) 0 (##fixnum.- 40 i)))
             (out (##repl-out))
             (call (##cons name (add-quotes args))))

        (define (indent i)
          (let loop ((j 0))
            (if (##fixnum.< j i)
              (begin
                (##write-string (if (##fixnum.= (##fixnum.remainder j 3) 0) "|" " ") out)
                (loop (##fixnum.+ j 1))))))

        (indent i)
        (##write-string "Entry " out)
        (##write-string (##object->string call (##fixnum.+ w 33) (if-touches #t #f)) out)
        (##newline out)
        (let ((result
                (##dynamic-bind
                  (##list (##cons '##TRACE-INDENT (##fixnum.+ i 1)))
                  (lambda () (##apply proc args)))))
          (indent i)
          (##write-string "==> " out)
          (##write-string (##object->string result (##fixnum.+ w 35) (if-touches #t #f)) out)
          (##newline out)
          result))))

  (if (##procedure? proc)
    (let ((x (##assq name ##traced)))
      (if x
        (setter (traced-proc (##cadr x)))
        (begin
          (set! ##traced (##cons (##cons name (##cons proc setter)) ##traced))
          (setter (traced-proc proc))))))
  name)

(define (##trace-list)
  (let loop ((l1 ##traced) (l2 '()))
    (if (##pair? l1)
      (let ((x (##car l1)))
        (loop (##cdr l1) (##cons (##car x) l2)))
      l2)))

(define (##untrace name)
  (let loop ((l1 ##traced) (l2 '()))
    (if (##pair? l1)
      (let ((x (##car l1)))
        (if (##eq? (##car x) name)
          (begin
            ((##cddr x) (##cadr x))
            (set! ##traced (##append (##reverse l2) (##cdr l1)))
            name)
          (loop (##cdr l1) (##cons x l2))))
      name)))

(define (##untrace-all)
  (let loop ((l ##traced))
    (if (##pair? l)
      (let ((x (##car l)))
        (##untrace (##car x))
        (loop (##cdr l)))
      ##unprint-object)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (set-gc-report report?)
  (set! ##gc-report report?)
  ##unprint-object)

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (open-input-string s)
  (touch-vars (s)
    (check-string s (open-input-string s)
      (##open-input-string s))))

(define (open-output-string)
  (##open-output-string))

(define (get-output-string p)
  (touch-vars (p)
    (check-output-port p (get-output-string p)
      (check-open-port p (get-output-string p)
        (##get-output-string p)))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (pretty-print obj (p) (w))

  (define default-width 79)

  (define (pretty-print* obj port width)
    (##pretty-print obj port width)
    ##unprint-object)

  (if (##unassigned? p)
    (let ((port (##current-output-port)))
      (check-open-port port (pretty-print obj)
        (pretty-print* obj port default-width)))
    (touch-vars (p)
      (if (##unassigned? w)
        (check-output-port p (pretty-print obj p)
          (check-open-port p (pretty-print obj p)
            (pretty-print* obj p default-width)))
        (touch-vars (w)
          (check-output-port p (pretty-print obj p w)
            (check-open-port p (pretty-print obj p w)
              (check-exact-int-non-neg w (pretty-print obj p w)
                (pretty-print* obj p w)))))))))

(define (pp obj (p) (w))

  (define default-width 79)

  (define (pp* obj port width)
    (if (##procedure? obj)
      (##pretty-print (##decompile obj) port width)
      (##pretty-print obj port width))
    ##unprint-object)

  (if (##unassigned? p)
    (let ((port (##current-output-port)))
      (check-open-port port (pp obj)
        (pp* obj port default-width)))
    (touch-vars (p)
      (if (##unassigned? w)
        (check-output-port p (pp obj p)
          (check-open-port p (pp obj p)
            (pp* obj p default-width)))
        (touch-vars (w)
          (check-output-port p (pp obj p w)
            (check-open-port p (pp obj p w)
              (check-exact-int-non-neg w (pp obj p w)
                (pp* obj p w)))))))))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define (runtime)
  (let ((buf (##make-vector 2 0)))
    (##cpu-times buf)
    (##/ (##vector-ref buf 0) 1000.0)))

; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

(define gensym
  (let ((count 0))
    (lambda ((prefix))
      (let ((p (cond ((##unassigned? prefix)
                      "g")
                     ((##symbol? prefix)
                      (symbol-string prefix))
                     ((##string? prefix)
                      prefix)
                     (else
                      "g"))))
        (set! count (##+ count 1))
        (symbol-make (##string-append p (##number->string count 10)))))))

(define (get sym prop)
  (touch-vars (sym prop)
    (check-symbol sym (get sym prop)
      (let ((x (##assq prop (symbol-plist sym))))
        (if x
          (##cdr x)
          #f)))))

(define (put sym prop val)
  (touch-vars (sym prop)
    (check-symbol sym (put sym prop val)
      (let ((plist (symbol-plist sym)))
        (let ((x (##assq prop plist)))
          (if x
            (##set-cdr! x val)
            (symbol-plist-set! sym (##cons (##cons prop val) plist)))
          ##unprint-object)))))

;------------------------------------------------------------------------------