Re: GH replacement proposal (includes a bit of Unicode)

[prj@po.cwru.edu (Paul Jarc)]

[-- Attachment #1: Type: text/plain, Size: 1845 bytes --]

Marius Vollmer <marius.vollmer@uni-dortmund.de> wrote:
> Thanks, do you think it worth implementing (and thereby deprecting the
> old stuff)?

As long as the old stuff isn't removed gratuitously, I'd say go for
it.  But maybe profile some code both ways to see if the function call
overhead is significant.  The current macro type predicates just
examine the bits of the SCM value, without even following a pointer,
right?  OTOH, these functions could be implemented as macros too, if
the performance gain was significant, so that shouldn't necessarily
affect the decision of whether to use the new API.

>> I have some code that benefits from having the subr name in the
>> exception - in the case of 'system-error, it walks the stack to find
>> and report the call that failed, including arguments.
>
> Can you give a quick example?  (Does it walk the C stack and prints
> the failed system call?)

No, just the Scheme stack.  See exit-for-system-error in the attached
file.
guile> (exit-for-system-error "myprog" (lambda () (delete-file "/foo")))
myprog: unlink("/foo"): No such file or directory

(There's a hard-coded mapping of "delete-file" -> "unlink", etc.)

> Hmm, I don't think we should do that.  There is nothing to be gained
> in treating SCM_BOOL_T specifically here.

Well, maybe just a little bit special - scm_to_bool could map #f -> 0,
#t -> 1, everything else -> 2.  That could be useful for something
like format.

> Maybe we should't have scm_to_bool and scm_is_bool at all?
> scm_is_true (and maybe scm_is_false) should suffice.

Consistency with the functions for other types would dictate that
there should be only is_bool and to_bool, and not is_true or is_false.
OTOH, each of them could help code readability in different cases, so
I'd include them all.  None of them should be very hard to write or
maintain.


paul

[-- Attachment #2: errors.scm --]
[-- Type: text/plain, Size: 4749 bytes --]

(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))))

[-- Attachment #3: Type: text/plain, Size: 142 bytes --]

_______________________________________________
Guile-devel mailing list
Guile-devel@gnu.org
http://mail.gnu.org/mailman/listinfo/guile-devel