From bf83d1126df437e4ea601d2e46b9a1d5ff9fac48 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 26 May 2017 15:44:10 -0600 Subject: [PATCH] add some unsafe operations as an alternative to FFI access Accessing unsafe functionality through the FFI seemed like a good way to avoid writing C code, but it made things more complicated instead of easier, and it interacts badly with a more agressive shift away from C (such as porting to Chez Scheme). So, add functions to the primitive `#%unsafe` module, instead. --- pkgs/base/info.rkt | 2 +- .../scribblings/foreign/custodian.scrbl | 12 + .../scribblings/reference/bytes.scrbl | 4 +- racket/collects/ffi/file.rkt | 151 +----------- racket/collects/ffi/unsafe.rkt | 51 ++-- racket/collects/ffi/unsafe/custodian.rkt | 44 +--- racket/collects/ffi/unsafe/try-atomic.rkt | 34 +-- racket/collects/openssl/mzssl.rkt | 8 +- racket/collects/racket/place.rkt | 2 +- .../racket/place/private/th-place.rkt | 5 +- racket/collects/racket/unsafe/ops.rkt | 10 +- racket/src/racket/include/schthread.h | 4 +- racket/src/racket/src/cstartup.inc | 16 +- racket/src/racket/src/fun.c | 18 ++ racket/src/racket/src/schemef.h | 2 +- racket/src/racket/src/schminc.h | 2 +- racket/src/racket/src/schvers.h | 4 +- racket/src/racket/src/thread.c | 229 +++++++++++++++++- 18 files changed, 337 insertions(+), 261 deletions(-) diff --git a/pkgs/base/info.rkt b/pkgs/base/info.rkt index 202d55f35f..72cb9b3997 100644 --- a/pkgs/base/info.rkt +++ b/pkgs/base/info.rkt @@ -12,7 +12,7 @@ (define collection 'multi) -(define version "6.9.0.4") +(define version "6.9.0.5") (define deps `("racket-lib" ["racket" #:version ,version])) diff --git a/pkgs/racket-doc/scribblings/foreign/custodian.scrbl b/pkgs/racket-doc/scribblings/foreign/custodian.scrbl index 9305af75c7..f59c560424 100644 --- a/pkgs/racket-doc/scribblings/foreign/custodian.scrbl +++ b/pkgs/racket-doc/scribblings/foreign/custodian.scrbl @@ -64,3 +64,15 @@ about to be collected by the garbage collector, whichever happens first. The @racket[callback] is only applied to @racket[v] once. @history[#:added "6.1.1.6"]} + + +@defproc[(make-custodian-at-root) custodian?]{ + +Creates a custodian that is a child of the root custodian, bypassing +the @racket[current-custodian] setting. + +Creating a child of the root custodian is useful for registering a +shutdown function that will be triggered only when the current place +terminates. + +@history[#:added "6.9.0.5"]} diff --git a/pkgs/racket-doc/scribblings/reference/bytes.scrbl b/pkgs/racket-doc/scribblings/reference/bytes.scrbl index f6535464a1..3986a17a62 100644 --- a/pkgs/racket-doc/scribblings/reference/bytes.scrbl +++ b/pkgs/racket-doc/scribblings/reference/bytes.scrbl @@ -362,7 +362,7 @@ For communication among @tech{places}, the new byte string is allocated in the [err-char (or/c #f char?) #f] [start exact-nonnegative-integer? 0] [end exact-nonnegative-integer? (bytes-length bstr)]) - char?]{ + (or/c char? #f)]{ Returns the @racket[skip]th character in the UTF-8 decoding of @racket[bstr]'s substring from @racket[start] to @racket[end], but without actually generating the other decoded characters. If the substring is @@ -386,7 +386,7 @@ For communication among @tech{places}, the new byte string is allocated in the [err-char (or/c #f char?) #f] [start exact-nonnegative-integer? 0] [end exact-nonnegative-integer? (bytes-length bstr)]) - exact-nonnegative-integer?]{ + (or/c exact-nonnegative-integer? #f)]{ Returns the offset in bytes into @racket[bstr] at which the @racket[skip]th character's encoding starts in the UTF-8 decoding of @racket[bstr]'s substring from @racket[start] to @racket[end] (but without actually diff --git a/racket/collects/ffi/file.rkt b/racket/collects/ffi/file.rkt index e11db6900a..c06bcf1903 100644 --- a/racket/collects/ffi/file.rkt +++ b/racket/collects/ffi/file.rkt @@ -1,146 +1,9 @@ #lang racket/base -(require ffi/unsafe) +(require (only-in '#%paramz + security-guard-check-file + security-guard-check-file-link + security-guard-check-network)) + (provide security-guard-check-file - _file/guard - _file/r - _file/rw) - -(define SCHEME_GUARD_FILE_READ #x1) -(define SCHEME_GUARD_FILE_WRITE #x2) -(define SCHEME_GUARD_FILE_EXECUTE #x4) -(define SCHEME_GUARD_FILE_DELETE #x8) -(define SCHEME_GUARD_FILE_EXISTS #x10) - -(define scheme_security_check_file - (get-ffi-obj "scheme_security_check_file" (ffi-lib #f) - (_fun _symbol _path _int -> _void))) - -(define (convert-modes who guards) - (unless (list? guards) - (raise-argument-error who "(listof symbol?)" guards)) - (let ([read? 0] - [write? 0] - [execute? 0] - [delete? 0] - [exists? 0]) - (for-each (lambda (guard) - (case guard - ((read) (set! read? SCHEME_GUARD_FILE_READ)) - ((write) (set! write? SCHEME_GUARD_FILE_WRITE)) - ((execute) (set! execute? SCHEME_GUARD_FILE_EXECUTE)) - ((delete) (set! delete? SCHEME_GUARD_FILE_DELETE)) - ((exists) (set! exists? SCHEME_GUARD_FILE_EXISTS)) - (else (raise-arguments-error who "bad permission symbol" "symbol" guard)))) - guards) - (when (and (positive? exists?) - (positive? (+ read? write? execute? delete?))) - (raise-arguments-error who "permission 'exists must occur alone" - "permissions" guards)) - (+ read? write? execute? delete? exists?))) - -(define (security-guard-check-file who path modes) - (unless (symbol? who) - (raise-argument-error 'security-guard-check-file "symbol?" 0 who path modes)) - (unless (or (path? path) (path-string? path)) - (raise-argument-error 'security-guard-check-file "path-string?" 1 who path modes)) - (let ([cp (cleanse-path (path->complete-path path))] - [mode (convert-modes 'security-guard-check-file modes)]) - (scheme_security_check_file who cp mode))) - -(define (_file/guard modes [who '_file/guard]) - (let ([mode (convert-modes '_file/guard modes)]) - (unless (symbol? who) - (raise-argument-error '_file/guard "symbol?" who)) - (make-ctype - _path - (lambda (p) - (let ([cp (cleanse-path (path->complete-path p))]) - (scheme_security_check_file who cp mode) - cp)) - #f))) - -(define _file/r (_file/guard '(read) '_file/r)) -(define _file/rw (_file/guard '(read write) '_file/rw)) - -#| -;; -- Tests -- - -(require rackunit - racket/runtime-path) - -(define-runtime-module-path pub-mod0 racket/list) -(define-runtime-module-path priv-mod0 racket/private/stx) - -(define pub-mod (resolved-module-path-name pub-mod0)) -(define priv-mod (resolved-module-path-name priv-mod0)) - -(define (mk-fun modes) - ;; receives path pointer, casts as int, who cares - (get-ffi-obj "scheme_make_integer_value" (ffi-lib #f) - (_fun (path) :: - (path : (_file/guard modes)) - -> _scheme))) - -(define (fun path modes) - ((mk-fun modes) path)) - -(define sg0 (current-security-guard)) - -(define sg-ro - (make-security-guard - sg0 - (lambda (who path modes) - (when (or (memq 'write modes) (memq 'delete modes)) - (error who "write/delete not allowed"))) - void void)) - -(define sg-priv - (make-security-guard - sg0 - (lambda (who path modes) - (when (and path (regexp-match #rx"private" (path->string path))) - (error who "no access to private paths: ~e" path))) - void void)) - -;; Test works on both strings and paths, rel and abs. - -(define-syntax-rule (check-ok expr) (check-not-exn (lambda () expr))) -(define-syntax-rule (check-err expr) (check-exn exn:fail? (lambda () expr))) - -(define-syntax-rule (run1 expr ok?) - (void - (if ok? - (check-not-exn (lambda () expr)) - (check-exn exn:fail? (lambda () expr))))) - -(define (run path modes ok?) - (run1 (security-guard-check-file 'me path modes) ok?) - (run1 (fun path modes) ok?)) - -(test-case "default security guard" - (parameterize ((current-security-guard sg0)) - (run "foo.txt" '(read) #t) - (run "bar.txt" '(write delete) #t) - (run pub-mod '(read) #t) - (run pub-mod '(write) #t) - (run priv-mod '(read) #t) - (run priv-mod '(read write delete) #t))) - -(test-case "read-only security-guard" - (parameterize ((current-security-guard sg-ro)) - (run "foo.txt" '(read) #t) - (run "bar.txt" '(write delete) #f) - (run pub-mod '(read) #t) - (run pub-mod '(write) #f) - (run priv-mod '(read) #t) - (run priv-mod '(read write delete) #f))) - -(test-case "private security-guard" - (parameterize ((current-security-guard sg-priv)) - (run pub-mod '(read) #t) - (run pub-mod '(write) #t) - (run priv-mod '(read) #f) - (run priv-mod '(read write delete) #f))) - -(provide (all-defined-out)) -|# + security-guard-check-file-link + security-guard-check-network) diff --git a/racket/collects/ffi/unsafe.rkt b/racket/collects/ffi/unsafe.rkt index dc2bb4ed56..ccacf7c2c1 100644 --- a/racket/collects/ffi/unsafe.rkt +++ b/racket/collects/ffi/unsafe.rkt @@ -2,6 +2,7 @@ ;; Foreign Racket interface (require '#%foreign setup/dirs racket/unsafe/ops racket/private/for + (only-in '#%unsafe unsafe-thread-at-root) (for-syntax racket/base racket/list syntax/stx racket/syntax racket/struct-info)) @@ -1951,39 +1952,25 @@ ;; We need to make a thread that runs in a privildged custodian and ;; that doesn't retain the current namespace --- either directly ;; or indirectly through some parameter setting in the current thread. - (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)] - [no-cells ((get-ffi-obj 'scheme_empty_cell_table #f (_fun -> _gcpointer)))] - [min-config ((get-ffi-obj 'scheme_minimal_config #f (_fun -> _gcpointer)))] - [thread/details (get-ffi-obj 'scheme_thread_w_details #f (_fun _scheme - _gcpointer ; config - _gcpointer ; cells - _pointer ; break_cell - _scheme ; custodian - _int ; suspend-to-kill? - -> _scheme))] - [logger (current-logger)] + (let ([logger (current-logger)] [cweh #f]) ; <- avoids a reference to a module-level binding (set! cweh call-with-exception-handler) (set! killer-thread - (thread/details (lambda () - (let retry-loop () - (call-with-continuation-prompt - (lambda () - (cweh - (lambda (exn) - (log-message logger - 'error - (if (exn? exn) - (exn-message exn) - (format "~s" exn)) - #f) - (abort-current-continuation void)) - (lambda () - (let loop () (will-execute killer-executor) (loop)))))) - (retry-loop))) - min-config - no-cells - #f ; default break cell - priviledged-custodian - 0)))) + (unsafe-thread-at-root + (lambda () + (let retry-loop () + (call-with-continuation-prompt + (lambda () + (cweh + (lambda (exn) + (log-message logger + 'error + (if (exn? exn) + (exn-message exn) + (format "~s" exn)) + #f) + (abort-current-continuation void)) + (lambda () + (let loop () (will-execute killer-executor) (loop)))))) + (retry-loop))))))) (will-register killer-executor obj finalizer)))) diff --git a/racket/collects/ffi/unsafe/custodian.rkt b/racket/collects/ffi/unsafe/custodian.rkt index bc9e74d29c..83b10e46d8 100644 --- a/racket/collects/ffi/unsafe/custodian.rkt +++ b/racket/collects/ffi/unsafe/custodian.rkt @@ -1,48 +1,26 @@ #lang racket/base (require ffi/unsafe - ffi/unsafe/atomic) + ffi/unsafe/atomic + (only-in '#%unsafe + unsafe-make-custodian-at-root + unsafe-custodian-register + unsafe-custodian-unregister)) -(provide (protect-out register-custodian-shutdown +(provide (protect-out make-custodian-at-root + register-custodian-shutdown register-finalizer-and-custodian-shutdown unregister-custodian-shutdown)) -(define _Scheme_Custodian_Reference-pointer - (_gcable (_cpointer 'Scheme_Custodian_Reference))) - -(define scheme_add_managed - (get-ffi-obj 'scheme_add_managed #f - (_fun _racket _racket _fpointer _racket _int - -> _Scheme_Custodian_Reference-pointer))) -(define scheme_add_managed_close_on_exit - (get-ffi-obj 'scheme_add_managed_close_on_exit #f - (_fun _racket _racket _fpointer _racket - -> _Scheme_Custodian_Reference-pointer))) - -(define scheme_remove_managed - (get-ffi-obj 'scheme_remove_managed #f - (_fun _Scheme_Custodian_Reference-pointer _racket -> _void))) - -(define (shutdown-callback impl proc+box) - ((car proc+box) impl)) -(define shutdown-callback-box (box #f)) -(define shutdown_callback - (cast shutdown-callback (_fun #:atomic? #t #:keep shutdown-callback-box - _racket _racket -> _void) _fpointer)) +(define (make-custodian-at-root) + (unsafe-make-custodian-at-root)) (define (register-custodian-shutdown obj proc [custodian (current-custodian)] #:at-exit? [at-exit? #f] #:weak? [weak? #f]) - (define proc+box (cons proc - shutdown-callback-box)) ; proc as data -> ffi callback retained - (if at-exit? - (scheme_add_managed_close_on_exit custodian - obj shutdown_callback proc+box) - (scheme_add_managed custodian - obj shutdown_callback proc+box - (if weak? 0 1)))) + (unsafe-custodian-register custodian obj proc at-exit? weak?)) (define (unregister-custodian-shutdown obj mref) - (scheme_remove_managed mref obj)) + (unsafe-custodian-unregister obj mref)) (define (register-finalizer-and-custodian-shutdown value callback [custodian (current-custodian)] diff --git a/racket/collects/ffi/unsafe/try-atomic.rkt b/racket/collects/ffi/unsafe/try-atomic.rkt index 792db8a8b0..8d5981ac21 100644 --- a/racket/collects/ffi/unsafe/try-atomic.rkt +++ b/racket/collects/ffi/unsafe/try-atomic.rkt @@ -1,20 +1,15 @@ #lang racket/base (require ffi/unsafe - ffi/unsafe/atomic) + ffi/unsafe/atomic + (only-in '#%unsafe + unsafe-abort-current-continuation/no-wind + unsafe-call-with-composable-continuation/no-wind + unsafe-set-on-atomic-timeout!)) (provide call-as-nonatomic-retry-point can-try-atomic? try-atomic) -(define scheme_abort_continuation_no_dws - (get-ffi-obj 'scheme_abort_continuation_no_dws #f (_fun _scheme _scheme -> _scheme))) -(define scheme_call_with_composable_no_dws - (get-ffi-obj 'scheme_call_with_composable_no_dws #f (_fun _scheme _scheme -> _scheme))) -(define scheme_set_on_atomic_timeout - (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun _int -> _void) -> _pointer))) -(define scheme_restore_on_atomic_timeout - (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun _pointer -> _pointer))) - (define freezer-tag (make-continuation-prompt-tag)) (define freezer-box-key (gensym)) (define in-try-atomic-key (gensym)) @@ -66,9 +61,6 @@ (define (can-try-atomic?) (and (freezer-box) (not (in-try-atomic?)))) -;; prevent GC of handler while it's installed: -(define saved-ptrs (make-hasheq)) - (define (try-atomic thunk default #:should-give-up? [should-give-up? (let ([now (current-inexact-milliseconds)]) @@ -87,22 +79,21 @@ ;; try to do some work: (let* ([ready? #f] [done? #f] - [handler (lambda (must-give-up) + [handler (lambda (must-give-up?) (when (and ready? (not done?) - (or (positive? must-give-up) + (or must-give-up? (force-timeout) (should-give-up?))) - (scheme_call_with_composable_no_dws + (unsafe-call-with-composable-continuation/no-wind (lambda (proc) (set-box! b (cons proc (unbox b))) - (scheme_restore_on_atomic_timeout #f) - (scheme_abort_continuation_no_dws + (unsafe-set-on-atomic-timeout! #f) + (unsafe-abort-current-continuation/no-wind freeze-tag (lambda () default))) freeze-tag) (void)))]) - (hash-set! saved-ptrs handler #t) (with-continuation-mark in-try-atomic-key #t (let/ec esc ;; esc + dynamic-wind prevents escape via alternate prompt tags (dynamic-wind @@ -112,7 +103,7 @@ (lambda () (call-with-continuation-prompt ; to catch aborts (lambda () - (when (scheme_set_on_atomic_timeout handler) + (when (unsafe-set-on-atomic-timeout! handler) (error 'try-atomic "nested atomic timeout")) (set! ready? #t) (begin0 @@ -132,7 +123,6 @@ (set! done? #t) (thunk)))) (lambda () - (hash-remove! saved-ptrs handler) - (scheme_restore_on_atomic_timeout #f) + (unsafe-set-on-atomic-timeout! #f) (unless done? (esc (void))))))))]))) diff --git a/racket/collects/openssl/mzssl.rkt b/racket/collects/openssl/mzssl.rkt index ca3576e1db..f98344ad16 100644 --- a/racket/collects/openssl/mzssl.rkt +++ b/racket/collects/openssl/mzssl.rkt @@ -29,6 +29,7 @@ TO DO: ffi/unsafe/atomic ffi/unsafe/alloc ffi/file + ffi/unsafe/custodian racket/list racket/port racket/tcp @@ -424,8 +425,6 @@ TO DO: (define SSL_TLSEXT_ERR_OK 0) (define SSL_TLSEXT_ERR_NOACK 3) -(define-mzscheme scheme_make_custodian (_fun _pointer -> _scheme)) - (define-runtime-path ssl-dh4096-param-path "dh4096.pem") ;; Make this bigger than 4096 to accommodate at least @@ -1147,9 +1146,8 @@ TO DO: (loop))))))) (define (kernel-thread thunk) - ;; Since we provide #f to scheme_make_custodian, - ;; the custodian is managed directly by the root: - (parameterize ([current-custodian (scheme_make_custodian #f)]) + ;; Run with a custodian that is managed directly by the root custodian: + (parameterize ([current-custodian (make-custodian-at-root)]) (thread thunk))) (define (make-ssl-output-port mzssl) diff --git a/racket/collects/racket/place.rkt b/racket/collects/racket/place.rkt index b5a9feade2..a8b60dc531 100644 --- a/racket/collects/racket/place.rkt +++ b/racket/collects/racket/place.rkt @@ -1,6 +1,6 @@ #lang racket/base (require (prefix-in pl- '#%place) - (only-in '#%paramz parameterization-key make-custodian-from-main) + (only-in '#%paramz parameterization-key) (only-in '#%futures processor-count) '#%place-struct racket/fixnum diff --git a/racket/collects/racket/place/private/th-place.rkt b/racket/collects/racket/place/private/th-place.rkt index 7fc703710c..9a69d4cf80 100644 --- a/racket/collects/racket/place/private/th-place.rkt +++ b/racket/collects/racket/place/private/th-place.rkt @@ -1,7 +1,8 @@ #lang racket/base (require (prefix-in pl- '#%place) '#%boot - (only-in '#%paramz parameterization-key make-custodian-from-main) + (only-in '#%paramz parameterization-key) + (only-in '#%unsafe unsafe-make-custodian-at-root) '#%place-struct racket/fixnum racket/flonum @@ -48,7 +49,7 @@ (unless (symbol? funcname) (raise-argument-error 'dynamic-place "symbol?" 1 mod funcname)) (define-values (pch cch) (th-place-channel)) - (define cust (make-custodian-from-main)) + (define cust (unsafe-make-custodian-at-root)) (define cust-box (make-custodian-box cust #t)) (define result-box (box 0)) (define plumber (make-plumber)) diff --git a/racket/collects/racket/unsafe/ops.rkt b/racket/collects/racket/unsafe/ops.rkt index 2b301726f4..b024a74add 100644 --- a/racket/collects/racket/unsafe/ops.rkt +++ b/racket/collects/racket/unsafe/ops.rkt @@ -14,7 +14,15 @@ unsafe-impersonate-procedure unsafe-start-atomic unsafe-end-atomic unsafe-start-breakable-atomic unsafe-end-breakable-atomic - unsafe-in-atomic?) + unsafe-in-atomic? + unsafe-thread-at-root + unsafe-make-custodian-at-root + unsafe-custodian-register + unsafe-custodian-unregister + unsafe-register-process-global + unsafe-set-on-atomic-timeout! + unsafe-abort-current-continuation/no-wind + unsafe-call-with-composable-continuation/no-wind) (rename-out [new:unsafe-impersonate-procedure unsafe-impersonate-procedure] [new:unsafe-chaperone-procedure unsafe-chaperone-procedure]) (prefix-out unsafe- diff --git a/racket/src/racket/include/schthread.h b/racket/src/racket/include/schthread.h index 5ad783f410..f4a0ed7f4a 100644 --- a/racket/src/racket/include/schthread.h +++ b/racket/src/racket/include/schthread.h @@ -122,7 +122,7 @@ typedef intptr_t objhead; typedef void (*Scheme_Sleep_Proc)(float seconds, void *fds); -typedef void (*Scheme_On_Atomic_Timeout_Proc)(int must_give_up); +typedef void (*Scheme_On_Atomic_Timeout_Proc)(void *data, int must_give_up); /* **************************************** */ @@ -376,6 +376,7 @@ typedef struct Thread_Local_Variables { Scheme_Sleep_Proc scheme_place_sleep_; struct GHBN_Thread_Data *ghbn_thread_data_; Scheme_On_Atomic_Timeout_Proc on_atomic_timeout_; + void *on_atomic_timeout_data_; int atomic_timeout_auto_suspend_; int atomic_timeout_atomic_level_; void *scheme_inotify_server_; @@ -778,6 +779,7 @@ XFORM_GC_VARIABLE_STACK_THROUGH_THREAD_LOCAL; #define scheme_place_sleep XOA (scheme_get_thread_local_variables()->scheme_place_sleep_) #define ghbn_thread_data XOA (scheme_get_thread_local_variables()->ghbn_thread_data_) #define on_atomic_timeout XOA (scheme_get_thread_local_variables()->on_atomic_timeout_) +#define on_atomic_timeout_data XOA (scheme_get_thread_local_variables()->on_atomic_timeout_data_) #define atomic_timeout_auto_suspend XOA (scheme_get_thread_local_variables()->atomic_timeout_auto_suspend_) #define atomic_timeout_atomic_level XOA (scheme_get_thread_local_variables()->atomic_timeout_atomic_level_) #define scheme_inotify_server XOA (scheme_get_thread_local_variables()->scheme_inotify_server_) diff --git a/racket/src/racket/src/cstartup.inc b/racket/src/racket/src/cstartup.inc index b59b14c9c7..afa7d75582 100644 --- a/racket/src/racket/src/cstartup.inc +++ b/racket/src/racket/src/cstartup.inc @@ -1,5 +1,5 @@ { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,54,0,0,0,1,0,0,8,0,18,0, 22,0,26,0,31,0,38,0,42,0,47,0,59,0,66,0,69,0,82,0,89, 0,94,0,103,0,109,0,123,0,137,0,140,0,146,0,157,0,159,0,173,0, @@ -102,7 +102,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2090); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,183,0,0,0,1,0,0,8,0,16,0, 29,0,34,0,51,0,63,0,85,0,114,0,158,0,164,0,178,0,193,0,211, 0,223,0,239,0,253,0,19,1,39,1,73,1,90,1,107,1,130,1,145,1, @@ -917,7 +917,7 @@ 1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2,29,11,11,11,11, 11,11,11,9,9,11,11,11,10,47,80,143,39,39,20,122,145,2,1,54,16, 40,2,3,2,4,2,5,2,6,2,7,2,8,2,9,30,2,11,1,20,112, -97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6, +97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,5, 30,2,11,1,23,101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114, 105,122,97,116,105,111,110,11,4,2,12,2,13,2,14,2,15,2,16,2,17, 2,18,30,2,11,1,19,99,97,99,104,101,45,99,111,110,102,105,103,117,114, @@ -1011,7 +1011,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 19015); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,15,0,0,0,1,0,0,8,0,23,0, 48,0,65,0,83,0,105,0,128,0,149,0,171,0,181,0,191,0,199,0,209, 0,217,0,0,0,253,1,0,0,3,1,5,105,110,115,112,48,76,35,37,112, @@ -1042,7 +1042,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 581); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,102,0,0,0,1,0,0,8,0,15,0, 26,0,53,0,59,0,73,0,86,0,112,0,129,0,151,0,159,0,171,0,186, 0,202,0,220,0,241,0,253,0,13,1,36,1,60,1,72,1,103,1,108,1, @@ -1485,7 +1485,7 @@ 9,20,122,145,2,1,39,16,1,11,16,0,20,27,15,56,9,2,2,2,2, 29,11,11,11,11,11,11,11,9,9,11,11,11,10,43,80,143,39,39,20,122, 145,2,1,44,16,28,2,3,2,4,30,2,6,1,20,112,97,114,97,109,101, -116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,6,30,2,6,1,23, +116,101,114,105,122,97,116,105,111,110,45,107,101,121,11,5,30,2,6,1,23, 101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105, 111,110,11,4,30,2,7,74,112,97,116,104,45,115,116,114,105,110,103,63,42, 196,15,2,8,30,2,7,73,114,101,114,111,111,116,45,112,97,116,104,44,196, @@ -1496,7 +1496,7 @@ 14,30,2,7,75,102,105,110,100,45,99,111,108,45,102,105,108,101,49,196,4, 30,2,7,78,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,42, 196,11,2,23,2,24,30,2,6,76,114,101,112,97,114,97,109,101,116,101,114, -105,122,101,11,7,16,0,40,42,39,16,0,39,16,16,2,15,2,16,2,8, +105,122,101,11,6,16,0,40,42,39,16,0,39,16,16,2,15,2,16,2,8, 2,12,2,17,2,18,2,11,2,4,2,10,2,3,2,20,2,13,2,14,2, 9,2,19,2,22,55,11,11,11,16,3,2,23,2,21,2,24,16,3,11,11, 11,16,3,2,23,2,21,2,24,42,42,40,12,11,11,16,0,16,0,16,0, @@ -1538,7 +1538,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 10343); } { - SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,51,84,0,0,0,0,0,0,0,0,0,0, + SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,54,46,57,46,48,46,53,84,0,0,0,0,0,0,0,0,0,0, 0,0,0,0,0,0,0,0,0,0,18,0,0,0,1,0,0,8,0,18,0, 22,0,28,0,42,0,56,0,68,0,88,0,102,0,117,0,130,0,135,0,139, 0,151,0,235,0,242,0,20,1,0,0,224,1,0,0,3,1,5,105,110,115, diff --git a/racket/src/racket/src/fun.c b/racket/src/racket/src/fun.c index 8de905c00a..92ffb41941 100644 --- a/racket/src/racket/src/fun.c +++ b/racket/src/racket/src/fun.c @@ -203,6 +203,9 @@ static Scheme_Object *do_cc_guard(Scheme_Object *v, Scheme_Object *cc_guard, Sch static Scheme_Object *chaperone_unsafe_undefined(int argc, Scheme_Object **argv); +static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]); + static Scheme_Object * scheme_extract_one_cc_mark_with_meta(Scheme_Object *mark_set, Scheme_Object *key, Scheme_Object *prompt_tag, Scheme_Meta_Continuation **_meta, @@ -765,6 +768,9 @@ scheme_init_unsafe_fun (Scheme_Env *env) "unsafe-impersonate-procedure", 2, -1), env); + + GLOBAL_PRIM_W_ARITY("unsafe-abort-current-continuation/no-wind", unsafe_abort_continuation_no_dws, 2, 2, env); + GLOBAL_PRIM_W_ARITY("unsafe-call-with-composable-continuation/no-wind", unsafe_call_with_control_no_dws, 2, 2, env); } void @@ -7723,6 +7729,12 @@ Scheme_Object *scheme_abort_continuation_no_dws (Scheme_Object *pt, Scheme_Objec return do_abort_continuation(2, a, 1); } +static Scheme_Object *unsafe_abort_continuation_no_dws(int argc, Scheme_Object *argv[]) +{ + /* See scheme_abort_continuation_no_dws() */ + return do_abort_continuation(argc, argv, 1); +} + static Scheme_Object *do_call_with_control (int argc, Scheme_Object *argv[], int no_dws) { Scheme_Object *prompt_tag; @@ -7769,6 +7781,12 @@ Scheme_Object *scheme_call_with_composable_no_dws (Scheme_Object *proc, Scheme_O return do_call_with_control(2, a, 1); } +static Scheme_Object *unsafe_call_with_control_no_dws(int argc, Scheme_Object *argv[]) +{ + /* See scheme_call_with_composable_no_dws() */ + return do_call_with_control(argc, argv, 1); +} + static Scheme_Cont_Mark *copy_cm_shared_on_write(Scheme_Meta_Continuation *mc) { Scheme_Cont_Mark *cp; diff --git a/racket/src/racket/src/schemef.h b/racket/src/racket/src/schemef.h index c18ff0c56f..3a53e4a845 100644 --- a/racket/src/racket/src/schemef.h +++ b/racket/src/racket/src/schemef.h @@ -204,7 +204,7 @@ MZ_EXTERN void scheme_pop_break_enable(Scheme_Cont_Frame_Data *cframe, int post_ MZ_EXTERN Scheme_Object *scheme_abort_continuation_no_dws(Scheme_Object *pt, Scheme_Object *v); MZ_EXTERN Scheme_Object *scheme_call_with_composable_no_dws(Scheme_Object *proc, Scheme_Object *pt); -MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p); +MZ_EXTERN Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p, void *data); /*========================================================================*/ /* error handling */ diff --git a/racket/src/racket/src/schminc.h b/racket/src/racket/src/schminc.h index 50fdb985b8..2d1bba8600 100644 --- a/racket/src/racket/src/schminc.h +++ b/racket/src/racket/src/schminc.h @@ -15,7 +15,7 @@ #define USE_COMPILED_STARTUP 1 #define EXPECTED_PRIM_COUNT 1156 -#define EXPECTED_UNSAFE_COUNT 133 +#define EXPECTED_UNSAFE_COUNT 141 #define EXPECTED_FLFXNUM_COUNT 69 #define EXPECTED_EXTFL_COUNT 45 #define EXPECTED_FUTURES_COUNT 15 diff --git a/racket/src/racket/src/schvers.h b/racket/src/racket/src/schvers.h index 055a2a3201..d355eb00e6 100644 --- a/racket/src/racket/src/schvers.h +++ b/racket/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "6.9.0.4" +#define MZSCHEME_VERSION "6.9.0.5" #define MZSCHEME_VERSION_X 6 #define MZSCHEME_VERSION_Y 9 #define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/racket/src/racket/src/thread.c b/racket/src/racket/src/thread.c index 172e664b57..018aff0f4d 100644 --- a/racket/src/racket/src/thread.c +++ b/racket/src/racket/src/thread.c @@ -240,6 +240,7 @@ HOOK_SHARED_OK void (*scheme_notify_multithread)(int on); HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds); HOOK_SHARED_OK int (*scheme_check_for_break)(void); THREAD_LOCAL_DECL(static Scheme_On_Atomic_Timeout_Proc on_atomic_timeout); +THREAD_LOCAL_DECL(static void *on_atomic_timeout_data); THREAD_LOCAL_DECL(static int atomic_timeout_auto_suspend); THREAD_LOCAL_DECL(static int atomic_timeout_atomic_level); @@ -371,7 +372,6 @@ static Scheme_Object *evt_p(int argc, Scheme_Object *args[]); static Scheme_Object *evts_to_evt(int argc, Scheme_Object *args[]); static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[]); -static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[]); static Scheme_Object *custodian_p(int argc, Scheme_Object *argv[]); static Scheme_Object *custodian_close_all(int argc, Scheme_Object *argv[]); static Scheme_Object *custodian_to_list(int argc, Scheme_Object *argv[]); @@ -381,6 +381,15 @@ static Scheme_Object *custodian_box_value(int argc, Scheme_Object *argv[]); static Scheme_Object *custodian_box_p(int argc, Scheme_Object *argv[]); static Scheme_Object *call_as_nested_thread(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_thread_at_root(int argc, Scheme_Object *argv[]); + +static Scheme_Object *unsafe_make_custodian_at_root(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_custodian_register(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_custodian_unregister(int argc, Scheme_Object *argv[]); + +static Scheme_Object *unsafe_register_process_global(int argc, Scheme_Object *argv[]); +static Scheme_Object *unsafe_set_on_atomic_timeout(int argc, Scheme_Object *argv[]); + static Scheme_Object *make_plumber(int argc, Scheme_Object *argv[]); static Scheme_Object *plumber_p(int argc, Scheme_Object *argv[]); static Scheme_Object *plumber_flush_all(int argc, Scheme_Object *argv[]); @@ -410,6 +419,10 @@ static Scheme_Object *make_security_guard(int argc, Scheme_Object *argv[]); static Scheme_Object *security_guard_p(int argc, Scheme_Object *argv[]); static Scheme_Object *current_security_guard(int argc, Scheme_Object *argv[]); +static Scheme_Object *security_guard_check_file(int argc, Scheme_Object *argv[]); +static Scheme_Object *security_guard_check_file_link(int argc, Scheme_Object *argv[]); +static Scheme_Object *security_guard_check_network(int argc, Scheme_Object *argv[]); + static Scheme_Object *cache_configuration(int argc, Scheme_Object **argv); static Scheme_Object *make_thread_set(int argc, Scheme_Object *argv[]); @@ -671,6 +684,16 @@ scheme_init_unsafe_thread (Scheme_Env *env) "unsafe-in-atomic?", 0, 0), env); + + GLOBAL_PRIM_W_ARITY("unsafe-thread-at-root", unsafe_thread_at_root, 1, 1, env); + + GLOBAL_PRIM_W_ARITY("unsafe-make-custodian-at-root", unsafe_make_custodian_at_root, 0, 0, env); + GLOBAL_PRIM_W_ARITY("unsafe-custodian-register", unsafe_custodian_register, 5, 5, env); + GLOBAL_PRIM_W_ARITY("unsafe-custodian-unregister", unsafe_custodian_unregister, 2, 2, env); + + GLOBAL_PRIM_W_ARITY("unsafe-register-process-global", unsafe_register_process_global, 2, 2, env); + + GLOBAL_PRIM_W_ARITY("unsafe-set-on-atomic-timeout!", unsafe_set_on_atomic_timeout, 1, 1, env); } void scheme_init_thread_places(void) { @@ -680,6 +703,7 @@ void scheme_init_thread_places(void) { REGISTER_SO(gc_prepost_callback_descs); REGISTER_SO(place_local_misc_table); REGISTER_SO(gc_info_prefab); + REGISTER_SO(on_atomic_timeout_data); gc_info_prefab = scheme_lookup_prefab_type(scheme_intern_symbol("gc-info"), 10); } @@ -748,10 +772,13 @@ void scheme_init_paramz(Scheme_Env *env) GLOBAL_PRIM_W_ARITY("extend-parameterization" , scheme_extend_parameterization , 1, -1, newenv); GLOBAL_PRIM_W_ARITY("check-for-break" , check_break_now , 0, 0, newenv); GLOBAL_PRIM_W_ARITY("reparameterize" , reparameterize , 1, 1, newenv); - GLOBAL_PRIM_W_ARITY("make-custodian-from-main", make_custodian_from_main, 0, 0, newenv); GLOBAL_PRIM_W_ARITY("cache-configuration" , cache_configuration, 2, 2, newenv); + GLOBAL_PRIM_W_ARITY("security-guard-check-file", security_guard_check_file, 3, 3, newenv); + GLOBAL_PRIM_W_ARITY("security-guard-check-file-link", security_guard_check_file_link, 3, 3, newenv); + GLOBAL_PRIM_W_ARITY("security-guard-check-network", security_guard_check_network, 4, 4, newenv); + scheme_finish_primitive_module(newenv); scheme_protect_primitive_provide(newenv, NULL); } @@ -1377,6 +1404,50 @@ void scheme_remove_managed(Scheme_Custodian_Reference *mr, Scheme_Object *o) remove_managed(mr, o, NULL, NULL); } +static void call_registered_callback(Scheme_Object *v, void *callback) +{ + Scheme_Object *argv[1]; + + argv[0] = v; + + scheme_start_in_scheduler(); + _scheme_apply_multi(callback, 1, argv); + scheme_end_in_scheduler(); +} + +static Scheme_Object *unsafe_custodian_register(int argc, Scheme_Object *argv[]) +{ + Scheme_Custodian_Reference *mr; + Scheme_Custodian *custodian = (Scheme_Custodian *)argv[0]; + Scheme_Object *v = argv[1]; + Scheme_Object *callback = argv[2]; + int at_exit = SCHEME_TRUEP(argv[3]); + int init_weak = SCHEME_TRUEP(argv[4]); + + /* Some checks, just to be polite */ + if (!SCHEME_CUSTODIANP(argv[0])) + scheme_wrong_contract("unsafe-custodian-register", "custodian?", 0, argc, argv); + if (!SCHEME_PROCP(callback)) + scheme_wrong_contract("unsafe-custodian-register", "procedure?", 2, argc, argv); + + if (at_exit) + mr = scheme_add_managed_close_on_exit(custodian, v, call_registered_callback, callback); + else + mr = scheme_add_managed(custodian, v, call_registered_callback, callback, !init_weak); + + return scheme_make_cptr(mr, NULL); +} + +static Scheme_Object *unsafe_custodian_unregister(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *v = argv[0]; + Scheme_Custodian_Reference *mr = (Scheme_Custodian_Reference *)SCHEME_CPTR_VAL(argv[1]); + + scheme_remove_managed(mr, v); + + return scheme_void; +} + Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_Func cf) { Scheme_Thread *kill_self = NULL; @@ -1567,7 +1638,7 @@ static Scheme_Object *make_custodian(int argc, Scheme_Object *argv[]) return (Scheme_Object *)scheme_make_custodian(m); } -static Scheme_Object *make_custodian_from_main(int argc, Scheme_Object *argv[]) +static Scheme_Object *unsafe_make_custodian_at_root(int argc, Scheme_Object *argv[]) { return (Scheme_Object *)scheme_make_custodian(NULL); } @@ -2714,6 +2785,24 @@ void *scheme_register_process_global(const char *key, void *val) return old_val; } +static Scheme_Object *unsafe_register_process_global(int argc, Scheme_Object *argv[]) +{ + void *val; + + if (!SCHEME_BYTE_STRINGP(argv[0])) + scheme_wrong_contract("unsafe-register-process-global", "bytes?", 0, argc, argv); + if (!scheme_is_cpointer(argv[0])) + scheme_wrong_contract("unsafe-register-process-global", "cpointer?", 1, argc, argv); + + val = scheme_register_process_global(SCHEME_BYTE_STR_VAL(argv[0]), + scheme_extract_pointer(argv[1])); + + if (val) + return scheme_make_cptr(val, NULL); + else + return scheme_false; +} + void scheme_init_process_globals(void) { #if defined(MZ_USE_MZRT) @@ -3294,6 +3383,18 @@ static Scheme_Object *sch_thread(int argc, Scheme_Object *args[]) return scheme_thread(args[0]); } +static Scheme_Object *unsafe_thread_at_root(int argc, Scheme_Object *args[]) +{ + scheme_check_proc_arity("unsafe-thread-at-root", 0, 0, argc, args); + + return scheme_thread_w_details(args[0], + scheme_minimal_config(), + scheme_empty_cell_table(), + NULL, /* default break cell */ + main_custodian, + 0); +} + static Scheme_Object *sch_thread_nokill(int argc, Scheme_Object *args[]) { scheme_check_proc_arity("thread/suspend-to-kill", 0, 0, argc, args); @@ -4816,7 +4917,7 @@ static void call_on_atomic_timeout(int must) local variable so that the function call isn't obscured to xform: */ oat = on_atomic_timeout; - oat(must); + oat(on_atomic_timeout_data, must); restore_thread_schedule_state(p, &ssr, 1); } @@ -5487,12 +5588,13 @@ int scheme_wait_until_suspend_ok(void) return did; } -Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p) +Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p, void *data) { Scheme_On_Atomic_Timeout_Proc old; old = on_atomic_timeout; on_atomic_timeout = p; + on_atomic_timeout_data = data; if (p) { atomic_timeout_auto_suspend = 1; atomic_timeout_atomic_level = do_atomic; @@ -5503,6 +5605,27 @@ Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Time return old; } +static void call_timeout_callback(void *data, int must_give_up) +{ + Scheme_Object *a[1]; + a[0] = (must_give_up ? scheme_true : scheme_false); + + scheme_start_in_scheduler(); + _scheme_apply_multi((Scheme_Object *)data, 1, a); + scheme_end_in_scheduler(); +} + +static Scheme_Object *unsafe_set_on_atomic_timeout(int argc, Scheme_Object *argv[]) +{ + Scheme_On_Atomic_Timeout_Proc r; + + if (SCHEME_FALSEP(argv[0])) + r = scheme_set_on_atomic_timeout(NULL, NULL); + else + r = scheme_set_on_atomic_timeout(call_timeout_callback, argv[0]); + + return (r ? scheme_true : scheme_false); +} static Scheme_Object *unsafe_start_atomic(int argc, Scheme_Object **argv) { @@ -8526,6 +8649,102 @@ static Scheme_Object *current_security_guard(int argc, Scheme_Object *argv[]) -1, security_guard_p, "security-guard?", 0); } +static Scheme_Object *security_guard_check_file(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *l, *a; + int guards = 0; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("security-guard-check-file", "symbol?", 0, argc, argv); + + if (!SCHEME_PATH_STRINGP(argv[1])) + scheme_wrong_contract("security-guard-check-file", "path-string?", 1, argc, argv); + + l = argv[2]; + while (SCHEME_PAIRP(l)) { + a = SCHEME_CAR(l); + if (SAME_OBJ(a, exists_symbol)) + guards |= SCHEME_GUARD_FILE_EXISTS; + else if (SAME_OBJ(a, delete_symbol)) + guards |= SCHEME_GUARD_FILE_DELETE; + else if (SAME_OBJ(a, execute_symbol)) + guards |= SCHEME_GUARD_FILE_EXECUTE; + else if (SAME_OBJ(a, write_symbol)) + guards |= SCHEME_GUARD_FILE_WRITE; + else if (SAME_OBJ(a, read_symbol)) + guards |= SCHEME_GUARD_FILE_READ; + else + break; + + l = SCHEME_CDR(l); + } + + if (!SCHEME_NULLP(l)) + scheme_wrong_contract("security-guard-check-file", + "(listof (or/c 'read 'write 'execute 'delete 'exists))", + 2, argc, argv); + + a = argv[1]; + if (!SCHEME_PATHP(a)) + a = scheme_char_string_to_path(a); + + scheme_security_check_file(scheme_symbol_val(argv[0]), + SCHEME_PATH_VAL(a), + guards); + + return scheme_void; +} + +static Scheme_Object *security_guard_check_file_link(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *a, *b; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("security-guard-check-file-link", "symbol?", 0, argc, argv); + + if (!SCHEME_PATH_STRINGP(argv[1])) + scheme_wrong_contract("security-guard-check-file-link", "path-string?", 1, argc, argv); + + if (!SCHEME_PATH_STRINGP(argv[2])) + scheme_wrong_contract("security-guard-check-file-link", "path-string?", 2, argc, argv); + + a = argv[1]; + if (!SCHEME_PATHP(a)) + a = scheme_char_string_to_path(a); + + b = argv[2]; + if (!SCHEME_PATHP(b)) + b = scheme_char_string_to_path(b); + + scheme_security_check_file_link(scheme_symbol_val(argv[0]), SCHEME_PATH_VAL(a), SCHEME_PATH_VAL(b)); + + return scheme_void; +} + +static Scheme_Object *security_guard_check_network(int argc, Scheme_Object *argv[]) +{ + Scheme_Object *a; + + if (!SCHEME_SYMBOLP(argv[0])) + scheme_wrong_contract("security-guard-check-network", "symbol?", 0, argc, argv); + + if (!SCHEME_CHAR_STRINGP(argv[1])) + scheme_wrong_contract("security-guard-check-network", "string?", 1, argc, argv); + + if (!SCHEME_INTP(argv[2]) + || (SCHEME_INT_VAL(argv[2]) < 1) + || (SCHEME_INT_VAL(argv[2]) > 65535)) + scheme_wrong_contract("security-guard-check-network", "(integer-in 1 65535)", 2, argc, argv); + + a = scheme_char_string_to_byte_string(argv[1]); + + scheme_security_check_network(scheme_symbol_val(argv[0]), + SCHEME_BYTE_STR_VAL(a), + SCHEME_INT_VAL(argv[2]), + SCHEME_TRUEP(argv[3])); + + return scheme_void; +} void scheme_security_check_file(const char *who, const char *filename, int guards) {