; From (SRFI-1 . module-bigloo)
(define
  (fold kons knil lis1 . lists)
  (if (pair? lists)
      (let lp
           ((lists (cons lis1 lists)) (ans knil))
           (receive
             (cars+ans cdrs)
             (%cars+cdrs+ lists ans)
             (if (null? cars+ans)
                 ans
                 (lp cdrs (apply kons cars+ans)))))
      (let lp
           ((lis lis1) (ans knil))
           (if (null-list? lis)
               ans
               (lp (cdr lis) (kons (car lis) ans))))))


(define
  (alist-map-assocs fn alist)
  (map (lambda (a) (fn (car a) (cdr a))) alist))


(define null-list? null?)


(define
  (filter pred? list)
  (let cata
       ((l list) (ans (quote ())))
       (if (null? l)
           (reverse ans)
           (let ((check (car l)))
                (if (pred? check)
                    (cata (cdr l) (cons check ans))
                    (cata (cdr l) ans))))))


(define
  (remove pred? list)
  (filter (lambda (e) (not (pred? e))) list))


; From (Prelude . module-bigloo)
(require (quote srfi-0))


(require (quote srfi-9))


(require (quote inspect-cont))


(require (quote foreign-ctools))


(require (quote foreign-stdlib))


(require (quote unix))


(require (quote socket))


(require (quote time))


(define
  (batch/last-chance-handler puts)
  (lambda
    e
    (define
      (display-line s)
      (puts (with-output-to-string (lambda () (write s)))))
    (display-line
      (quasiquote
        (lastchance error handler (unquote e))))
    (let* ((error-text
             (call-with-output-string
               (lambda (p) (decode-error e p))))
           (stacktrace (current-continuation-structure))
           (inspector
             (make-continuation-inspector stacktrace))
           (summarize-frame
             (lambda
               (count inspector . prefix)
               (let* ((frame (inspector (quote get)))
                      (code (frame (quote code)))
                      (class (code (quote class)))
                      (expr (code (quote expression)))
                      (proc (code (quote procedure))))
                     (display-line
                       (quasiquote
                         (frame (unquote-splicing prefix)
                                (unquote class)
                                (unquote-splicing
                                  (case class
                                        ((system-procedure) (quote ()))
                                        ((interpreted-primitive)
                                         (procedure-name proc))
                                        ((interpreted-expression) expr)
                                        ((compiled-procedure)
                                         (procedure-name proc))
                                        (else (quote ()))))))))))
           (backtrace
             (lambda
               (count inspector)
               (let loop
                    ((c (inspector (quote clone))))
                    (let ((f (c (quote get))))
                         (if (f (quote same?) (inspector (quote get)))
                             (summarize-frame 0 c "=> ")
                             (summarize-frame 0 c "   ")))
                    (if (c (quote down)) (loop c))))))
          (display-line
            (quasiquote (decoded error (unquote error-text))))
          (backtrace 0 inspector)
          (exit 0))))


(define
  (install-lastchance puts)
  (error-handler (batch/last-chance-handler puts)))


; From (Logging . module-bigloo)
(define (make-semaphore n) #t)


(define semaphore-mutex (make-semaphore 0))


(define (semaphore-wait mutex) #t)


(define (semaphore-post sem) #t)


(define
  log-a-log-rt
  (make-record-type
    "log-a-log"
    (quote (semaphore name pred grab release))))


(define
  make-log-a-log
  (record-constructor
    log-a-log-rt
    (quote (name pred semaphore grab release))))


(define
  prim-log-a-log?
  (record-predicate log-a-log-rt))


(define
  log-a-log-semaphore
  (record-accessor log-a-log-rt (quote semaphore)))


(define
  log-a-log-name
  (record-accessor log-a-log-rt (quote name)))


(define
  log-a-log-pred
  (record-accessor log-a-log-rt (quote pred)))


(define
  log-a-log-grab
  (record-accessor log-a-log-rt (quote grab)))


(define
  log-a-log-release
  (record-accessor log-a-log-rt (quote release)))


(define
  (make-log-a-port name pred? sem port)
  (make-log-a-log
    name
    pred?
    sem
    (lambda () port)
    (lambda () #t)))


(define
  (make-log-a-buffer
    name
    pred?
    sem
    current
    entries)
  (make-log-a-log
    name
    pred?
    sem
    (lambda
      ()
      (let ((port (open-output-string)))
           (vector-set! entries current port)
           port))
    (lambda
      ()
      (let ((port (vector-ref entries current)))
           (if (output-port? port)
               (vector-set!
                 entries
                 current
                 (get-output-string port)))
           (set! current
                 (modulo (+ 1 current) (vector-length entries)))))))


(define
  (log-grab log)
  (semaphore-wait (log-a-log-semaphore log))
  ((log-a-log-grab log)))


(define
  (log-release log)
  ((log-a-log-release log))
  (semaphore-post (log-a-log-semaphore log)))


(define logs (quote ()))


(define
  (log-find-named-k log-name k-success k-fail)
  (let find
       ((l logs) (checked (quote ())))
       (if (null? l)
           (k-fail log-name)
           (let ((log (car l)) (unchecked (cdr l)))
                (if (equal? log-name (log-a-log-name log))
                    (k-success (reverse checked) log unchecked)
                    (find unchecked (cons log checked)))))))


(define
  (log-add! log)
  (set! logs (cons log logs))
  log)


(define
  (log-remove-named-k! log-name k-success k-fail)
  (log-find-named-k
    log-name
    (lambda
      (checked log unchecked)
      (set! logs (append checked unchecked))
      (k-success log))
    k-fail))


(define
  (log-remove-named! log-name)
  (log-remove-named-k!
    log-name
    (lambda (log*) logs)
    (lambda (log*) logs)))


(define
  (log-remove! log)
  (log-remove-named! (log-a-log-name log)))


(define
  (log-file! name pred? filename)
  (log-add!
    (make-log-a-port
      name
      pred?
      (make-semaphore 1)
      (open-output-file filename))))


(define
  (log-port! name pred? port)
  (log-add!
    (make-log-a-port
      name
      pred?
      (make-semaphore 1)
      port)))


(define
  (log-buffer! name pred? size)
  (log-add!
    (make-log-a-buffer
      name
      pred?
      (make-semaphore 1)
      0
      (make-vector size))))


(define (log-all . x) #t)


(define (log-none . x) #f)


(define
  (log-has-any? . s)
  (cond ((null? s) log-none)
        ((null? (cdr s))
         (let ((match (car s)))
              (lambda
                (c)
                (or (and (pair? c) (member match c))
                    (equal? match c)))))
        (else (lambda
                (criteria)
                (if (pair? criteria)
                    (let check
                         ((vals s))
                         (cond ((null? vals) #f)
                               ((begin (member (car vals) criteria)) #t)
                               (else (check (cdr vals)))))
                    (and (member criteria s)))))))


(define
  (log-has? . s)
  (cond ((null? s) log-all)
        ((null? (cdr s))
         (let ((match (car s)))
              (lambda
                (c)
                (or (and (pair? c) (member match c))
                    (equal? match c)))))
        (else (lambda
                (criteria)
                (and (pair? criteria)
                     (let check
                          ((vals s))
                          (cond ((null? vals) #t)
                                ((member (car vals) criteria)
                                 (check (cdr vals)))
                                (else #f))))))))


(define
  (log-fractal? number-order . v)
  (cond ((null? v) log-all)
        ((null? (cdr v))
         (let ((match (car v)))
              (if (number? match)
                  (lambda
                    (c)
                    (cond ((pair? c)
                           (let ((level (find number? c)))
                                (and level (number-order level match))))
                          ((number? c) (number-order c match))
                          (else #f)))
                  (lambda
                    (c)
                    (if (pair? c)
                        (find (lambda (e) (equal? e match)) c)
                        (equal? c match))))))
        (else (lambda
                (criteria)
                (and (pair? criteria)
                     (let check
                          ((v v) (c criteria))
                          (cond ((null? v) #t)
                                ((null? criteria) #f)
                                (else (let ((target (car v)))
                                           (if (number? target)
                                               (check (cdr v)
                                                      (find-tail
                                                        (lambda
                                                          (e)
                                                          (and (number? e)
                                                               (>= number-order
                                                                   target)))
                                                        c))
                                               (check (cdr v)
                                                      (find-tail
                                                        (lambda
                                                          (e)
                                                          (equal? target e))
                                                        c))))))))))))


(define
  (log-and . log-preds)
  (lambda
    (c)
    (let check
         ((preds log-preds))
         (cond ((null? preds) #t)
               (((car preds) c) (check (cdr preds)))
               (else #f)))))


(define
  (log-or . log-preds)
  (lambda
    (c)
    (let check
         ((preds log-preds))
         (cond ((null? preds) #f)
               (((car preds) c) #t)
               (else (check (cdr preds)))))))


(define
  (log-not pred?)
  (lambda (c) (not (pred? c))))


(define
  log-default
  (log-buffer! (quote DEFAULT) log-all 1000))


(define
  (log-relevant? log criteria)
  ((log-a-log-pred log) criteria))


(define
  (relevant-logs s)
  (fold (lambda
          (log use)
          (if (log-relevant? log s) (cons log use) use))
        (quote ())
        logs))


(define
  (logit facility s)
  (for-each
    (lambda
      (log)
      (let ((port (log-grab log)))
           (write (quasiquote ((unquote facility) (unquote s)))
                  port)
           (newline port)
           (log-release log)))
    (relevant-logs facility)))


(define
  (ppit facility s)
  (for-each
    (lambda
      (log)
      (let ((port (log-grab log)))
           (pretty-print
             (quasiquote ((unquote facility) (unquote s)))
             port)
           (log-release log)))
    (relevant-logs facility)))


(logit (quote LOGGER)
       (quasiquote (loaded logging utils)))


; From (FLog . module-bigloo)
(define
  (ftimestamp)
  (call-with-values
    current-utc-time
    (lambda
      (secs fracs)
      (let ((fracs* (number->string fracs)))
           (call-with-output-string
             (lambda
               (p)
               (display secs p)
               (display #\. p)
               (display
                 (make-string (- 6 (string-length fracs*)) #\0)
                 p)
               (display fracs* p)))))))


(define *flog-use-current-output-port* #f)


(define *flog-use-current-error-port* #f)


(define
  (make-flog file-name)
  (lambda
    (s)
    (let ((entry (call-with-output-string
                   (lambda
                     (p)
                     (display
                       (quasiquote
                         ((unquote (ftimestamp)) (unquote-splicing s)))
                       p)
                     (newline p))))
          (f ((foreign-procedure
                "fopen"
                (quote (string string))
                (quote void*))
              file-name
              "a")))
         ((foreign-procedure
            "fputs"
            (quote (string void*))
            (quote int))
          entry
          f)
         ((foreign-procedure
            "fclose"
            (quote (void*))
            (quote void))
          f)
         (if *flog-use-current-output-port*
             (display entry (current-output-port)))
         (if *flog-use-current-error-port*
             (display entry (current-error-port))))))


(define flog (make-flog "fcgi.log"))


(define
  (make-log-a-flog name pred? sem file)
  (let ((port #f) (flogger (make-flog file)))
       (make-log-a-log
         name
         pred?
         sem
         (lambda
           ()
           (if (not port)
               (begin (set! port (open-output-string)) port))
           port)
         (lambda
           ()
           (if port
               (let* ((s (get-output-string port))
                      (sexp (call-with-input-string s read)))
                     (flogger sexp)
                     (set! port #f)))))))


(define
  (log-a-flog! name pred? file)
  (log-add!
    (make-log-a-flog
      name
      pred?
      (make-semaphore 1)
      file)))