#lang scheme/base

(require scheme/runtime-path)
(provide
 (all-defined-out))

(define (msleep ms)
  (sync (alarm-evt
         (+ (current-inexact-milliseconds)
            ms))))



;; Lighten up verbose syntax-rules
(define-syntax define-sr
  (syntax-rules ()
    ((_ (name (args ...)) template)
     (define-syntax name
       (syntax-rules ()
         ((_ args ...) template))))
    ((_ (name . args) template)
     (define-syntax name
       (syntax-rules ()
         ((_ . args) template))))))

;; Convert anything to a port.
(define (port string/port)
  (cond
   ((string? string/port)
    (open-input-string
     (string-append string/port "\n")))
   ((port? string/port)
    string/port)
   (else
    (error 'invalid-type string/port))))


(define-sr (require/provide item ...)
  (begin
    (require item ...)
    (provide (all-from-out item ...))))


(define (make-counter init)
  (let ((state (- init 1)))
    (lambda ()
      (set! state (+ 1 state))
      state)))

(define (id . vals) (apply values vals))
(define (true . args) #t)
(define (false . args) #f)

(define-syntax-rule (fail/false expr ...)
  (with-handlers ((void false)) expr ...))


(define-syntax-rule (inc! val) (begin (set! val (add1 val)) val))

(define (resolve-module m)
  ((current-module-name-resolver) m #f #f #f))


;; Trace return value
(define-syntax-rule (*** fn arg ...)
  (let ((rv (fn arg ...)))
    (printf "*** ~s\n" rv)
    rv))


;; Label symbol generator.
(define next-label
  (let ((next (make-counter 0)))
    (lambda () (string->symbol
                (format "_L~a" (next))))))

;; From PLT list
(define (definition-source id)
  (let ([binding (identifier-binding id)])
    (and (list? binding)
         (resolved-module-path-name
          (module-path-index-resolve (car binding))))))

;; Push to a parameter stack.
(define (ppush! param val [error (lambda () (error 'push-pstack-undefined))])
  (let ((stack (param)))
    (unless stack (error))
    (param (cons val stack))))

;; Inlined quote.
(define-syntax-rule (quote* . a) (quote a))
(define-syntax-rule (quasiquote* . a) (quasiquote a))


(define-runtime-path home-dir "..")
(define (home) (simplify-path home-dir))