(use-modules ((srfi srfi-1)  :select (find)))
(use-modules ((srfi srfi-13) :select
              (string-append/shared substring/shared string-join)))
(use-modules ((ice-9 format) :select (format)))

(define call/cc call-with-current-continuation)

(define (exception-argument key value)
  value)

(define (die message)
  (display (string-append/shared message "\n") (current-error-port))
  (flush-all-ports)
  (exit 100))

(define primitive-apply
  (call/cc
   (lambda (return)
     (define (raise-error)
       (apply execlp '()))
     (define (lazy-handler . exception)
       (let* ((stack (make-stack #t lazy-handler))
              (frame (and (stack? stack) (stack-ref stack 0)))
              (proc (and (frame? frame) (frame-procedure frame))))
         (return proc)))
     (lazy-catch #t raise-error lazy-handler))))

(define-macro (defined-values&forms . flags)
  (if (null? flags)
    ''()
    (let ((flag (car flags))
          (rest `(defined-values&forms . ,(cdr flags))))
      (if (defined? flag)
        `(cons (cons ,flag ',flag) ,rest)
        rest))))

(define synonyms
  '((open-fdes open)))

(define subst
  '((open-fdes      . open)
    (delete-file    . unlink)
    (primitive-exit . exit)
    (primitive-fork . fork)))

(define (printer:fdes-flags flags)
  (let ((output-string ""))
    (define (output-append string)
      (set! output-string (string-append/shared output-string "|" string)))
    (define (output val-sym)
      (let* ((flag (car val-sym))
             (intersection (logand flags flag)))
        (and (= intersection flag)
             (begin
               (set! flags (- flags flag))
               (output-append (symbol->string (cdr val-sym)))
               #t))))
    (find     output (defined-values&forms O_RDWR O_WRONLY O_RDONLY))
    (for-each output (defined-values&forms
                       O_CREAT O_EXCL O_APPEND O_TRUNC O_NONBLOCK
                       O_NDELAY O_NOCTTY O_SYNC))
    (if (not (zero? flags))
      (output-append (format #f "0x~x" flags)))
    (substring/shared output-string 1)))

(define arg-printers `(((open . 1) . ,printer:fdes-flags)))

(define (find-args frame proc-name/string proc-syns)
  (let* ((proc? (frame-procedure? frame))
         (frame-args      (and proc? (frame-arguments frame)))
         (frame-proc      (and proc? (frame-procedure frame)))
         (frame-proc-name (and proc? (procedure-name frame-proc)))
         (prev (frame-previous frame)))
    (cond
     ((and proc? (memq frame-proc-name proc-syns))
      frame-args)
     ((and proc?
           (eq? frame-proc primitive-apply)
           (procedure? (car frame-args))
           (memq (procedure-name (car frame-args)) proc-syns))
      (cadr frame-args))
     (else
      (and prev (find-args prev proc-name/string proc-syns))))))

(define (print-args proc proc-args)
  (if proc-args
    (let loop ((i (1- (length proc-args)))
               (l '()))
      (if (< i 0)
        l
        (loop (1- i)
              (cons
               (let* ((key (cons proc i))
                      (printer (assoc-ref arg-printers key))
                      (printer (or printer object->string)))
                 (printer (list-ref proc-args i)))
               l))))
    '("unknown arguments")))

(define (exit-for-system-error program-name thunk)
  (define (lazy-handler . exception)
    (let* ((proc-name/string (cadr exception))
           (proc-name (string->symbol proc-name/string))
           (proc-syns (or (find (lambda (syn) (memq proc-name syn))
                                synonyms)
                          (list proc-name)))
           (stack (make-stack #t lazy-handler))
           (frame (and (stack? stack) (stack-ref stack 0)))
           (proc-args (and (frame? frame)
                           (find-args frame proc-name/string proc-syns)))
           (proc-name (or (assq-ref subst proc-name) proc-name))
           (errno (system-error-errno exception))
           (status (if (memq errno (list ENOMEM ETXTBSY EIO ENFILE))
                     111 100)))
      (display (string-append/shared
                program-name ": " (symbol->string proc-name) "("
                (string-join (print-args proc-name proc-args) ", ")
                "): " (strerror errno) "\n")
               (current-error-port))
      (flush-all-ports)
      (exit status)))
  (lazy-catch 'system-error thunk lazy-handler))

(define (system-error-case thunk error-values)
  (call/cc
   (lambda (return)
     (define (lazy-handler . exception)
       (let* ((errno (system-error-errno exception))
              (entry (assq errno error-values)))
         (if entry
           (return (cdr entry))
           (apply throw exception))))
     (lazy-catch 'system-error thunk lazy-handler))))