diff --git a/ffi.scm b/ffi.scm index fb18538..c5f373c 100644 --- a/ffi.scm +++ b/ffi.scm @@ -1,84 +1,85 @@ ;; FFI interface for TinySCHEME. ;; ;; Copyright (C) 2016 g10 Code GmbH ;; ;; This file is part of GnuPG. ;; ;; GnuPG is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 3 of the License, or ;; (at your option) any later version. ;; ;; GnuPG is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, see . ;; Foreign function wrapper. Expects F to return a list with the ;; first element being the `error_t' value returned by the foreign ;; function. The error is thrown, or the cdr of the result is ;; returned. (define (ffi-apply name f args) (let ((result (apply f args))) (cond ((string? result) (ffi-fail name args result)) ((not (= (car result) 0)) (ffi-fail name args (strerror (car result)))) ((and (= (car result) 0) (pair? (cdr result))) (cadr result)) ((= (car result) 0) '()) (else (throw (list "Result violates FFI calling convention: " result)))))) (define (ffi-fail name args message) (let ((args' (open-output-string))) (write (cons (string->symbol name) args) args') (throw (string-append (get-output-string args') ": " message)))) ;; Pseudo-definitions for foreign functions. Evaluates to no code, ;; but serves as documentation. (macro (ffi-define form)) ;; Runtime support. ;; Low-level mechanism to terminate the process. (ffi-define (_exit status)) ;; High-level mechanism to terminate the process is to throw an error ;; of the form (*interpreter-exit* status). This gives automatic ;; resource management a chance to clean up. (define *interpreter-exit* (gensym)) (define (throw . x) (cond ((more-handlers?) (apply (pop-handler) x)) ((and (= 2 (length x)) (equal? *interpreter-exit* (car x))) (*run-atexit-handlers*) (_exit (cadr x))) (else (apply error x)))) +(set! *error-hook* throw) ;; Terminate the process returning STATUS to the parent. (define (exit status) (throw *interpreter-exit* status)) ;; A list of functions run at interpreter shutdown. (define *atexit-handlers* (list)) ;; Execute all these functions. (define (*run-atexit-handlers*) (unless (null? *atexit-handlers*) (let ((proc (car *atexit-handlers*))) ;; Drop proc from the list so that it will not get ;; executed again even if it raises an exception. (set! *atexit-handlers* (cdr *atexit-handlers*)) (proc) (*run-atexit-handlers*)))) ;; Register a function to be run at interpreter shutdown. (define (atexit proc) (set! *atexit-handlers* (cons proc *atexit-handlers*)))