Artifact
f189f8138976b9bf68f85bf9b6df551935b017d7:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 28 63 29 ;; Copyright (c)
0010: 20 32 30 30 39 20 44 65 72 69 63 6b 20 45 64 64 2009 Derick Edd
0020: 69 6e 67 74 6f 6e 2e 20 20 41 6c 6c 20 72 69 67 ington. All rig
0030: 68 74 73 20 72 65 73 65 72 76 65 64 2e 0a 3b 3b hts reserved..;;
0040: 20 4c 69 63 65 6e 73 65 64 20 75 6e 64 65 72 20 Licensed under
0050: 61 6e 20 4d 49 54 2d 73 74 79 6c 65 20 6c 69 63 an MIT-style lic
0060: 65 6e 73 65 2e 20 20 4d 79 20 6c 69 63 65 6e 73 ense. My licens
0070: 65 20 69 73 20 69 6e 20 74 68 65 20 66 69 6c 65 e is in the file
0080: 0a 3b 3b 20 6e 61 6d 65 64 20 4c 49 43 45 4e 53 .;; named LICENS
0090: 45 20 66 72 6f 6d 20 74 68 65 20 6f 72 69 67 69 E from the origi
00a0: 6e 61 6c 20 63 6f 6c 6c 65 63 74 69 6f 6e 20 74 nal collection t
00b0: 68 69 73 20 66 69 6c 65 20 69 73 20 64 69 73 74 his file is dist
00c0: 72 69 62 75 74 65 64 0a 3b 3b 20 77 69 74 68 2e ributed.;; with.
00d0: 20 20 49 66 20 74 68 69 73 20 66 69 6c 65 20 69 If this file i
00e0: 73 20 72 65 64 69 73 74 72 69 62 75 74 65 64 20 s redistributed
00f0: 77 69 74 68 20 73 6f 6d 65 20 6f 74 68 65 72 20 with some other
0100: 63 6f 6c 6c 65 63 74 69 6f 6e 2c 20 6d 79 0a 3b collection, my.;
0110: 3b 20 6c 69 63 65 6e 73 65 20 6d 75 73 74 20 61 ; license must a
0120: 6c 73 6f 20 62 65 20 69 6e 63 6c 75 64 65 64 2e lso be included.
0130: 0a 0a 3b 3b 20 4e 4f 54 45 3a 20 49 20 62 65 6c ..;; NOTE: I bel
0140: 69 65 76 65 20 74 68 69 73 20 63 75 72 72 65 6e ieve this curren
0150: 74 6c 79 20 77 6f 72 6b 73 20 6f 6e 6c 79 20 6f tly works only o
0160: 6e 20 4c 69 6e 75 78 2e 0a 3b 3b 20 4e 4f 54 45 n Linux..;; NOTE
0170: 3a 20 49 66 20 4c 61 72 63 65 6e 79 27 73 20 46 : If Larceny's F
0180: 46 49 20 63 68 61 6e 67 65 73 2c 20 74 68 69 73 FI changes, this
0190: 20 6d 61 79 20 6e 6f 20 6c 6f 6e 67 65 72 20 77 may no longer w
01a0: 6f 72 6b 2e 0a 0a 28 6c 69 62 72 61 72 79 20 28 ork...(library (
01b0: 73 72 66 69 20 73 39 38 20 6f 73 2d 65 6e 76 69 srfi s98 os-envi
01c0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
01d0: 73 29 0a 20 20 28 65 78 70 6f 72 74 0a 20 20 20 s). (export.
01e0: 20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 get-environment
01f0: 2d 76 61 72 69 61 62 6c 65 20 67 65 74 2d 65 6e -variable get-en
0200: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
0210: 6c 65 73 29 0a 20 20 28 69 6d 70 6f 72 74 0a 20 les). (import.
0220: 20 20 20 28 72 6e 72 73 20 62 61 73 65 29 0a 20 (rnrs base).
0230: 20 20 20 28 72 6e 72 73 20 63 6f 6e 74 72 6f 6c (rnrs control
0240: 29 0a 20 20 20 20 28 72 6e 72 73 20 62 79 74 65 ). (rnrs byte
0250: 76 65 63 74 6f 72 73 29 0a 20 20 20 20 28 72 6e vectors). (rn
0260: 72 73 20 69 6f 20 70 6f 72 74 73 29 0a 20 20 20 rs io ports).
0270: 20 28 70 72 69 6d 69 74 69 76 65 73 0a 20 20 20 (primitives.
0280: 20 20 66 6f 72 65 69 67 6e 2d 70 72 6f 63 65 64 foreign-proced
0290: 75 72 65 20 23 3b 66 6f 72 65 69 67 6e 2d 76 61 ure #;foreign-va
02a0: 72 69 61 62 6c 65 20 66 6f 72 65 69 67 6e 2d 6e riable foreign-n
02b0: 75 6c 6c 2d 70 6f 69 6e 74 65 72 3f 20 73 69 7a ull-pointer? siz
02c0: 65 6f 66 3a 70 6f 69 6e 74 65 72 0a 20 20 20 20 eof:pointer.
02d0: 20 25 70 65 65 6b 2d 70 6f 69 6e 74 65 72 20 25 %peek-pointer %
02e0: 70 65 65 6b 38 75 20 76 6f 69 64 2a 2d 3e 61 64 peek8u void*->ad
02f0: 64 72 65 73 73 20 66 66 69 2f 64 6c 6f 70 65 6e dress ffi/dlopen
0300: 20 66 66 69 2f 64 6c 73 79 6d 29 0a 20 20 20 20 ffi/dlsym).
0310: 28 73 72 66 69 20 70 72 69 76 61 74 65 20 66 65 (srfi private fe
0320: 61 74 75 72 65 2d 63 6f 6e 64 29 29 0a 0a 20 20 ature-cond))..
0330: 3b 3b 20 54 4f 44 4f 3a 20 57 69 6c 6c 20 74 68 ;; TODO: Will th
0340: 65 20 63 6f 6e 76 65 6e 69 65 6e 74 20 73 74 72 e convenient str
0350: 69 6e 67 20 63 6f 6e 76 65 72 74 65 72 73 20 75 ing converters u
0360: 73 65 20 74 68 65 20 6e 61 74 69 76 65 20 74 72 se the native tr
0370: 61 6e 73 63 6f 64 65 72 20 69 6e 0a 20 20 3b 3b anscoder in. ;;
0380: 20 20 20 20 20 20 20 74 68 65 20 66 75 74 75 72 the futur
0390: 65 3f 20 20 53 6f 20 74 68 61 74 20 73 63 68 65 e? So that sche
03a0: 6d 65 2d 73 74 72 2d 3e 63 2d 73 74 72 2d 62 76 me-str->c-str-bv
03b0: 20 61 6e 64 20 63 2d 73 74 72 2d 70 74 72 2d 3e and c-str-ptr->
03c0: 73 63 68 65 6d 65 2d 73 74 72 0a 20 20 3b 3b 20 scheme-str. ;;
03d0: 20 20 20 20 20 20 77 6f 6e 27 74 20 62 65 20 6e won't be n
03e0: 65 65 64 65 64 2e 0a 0a 20 20 28 64 65 66 69 6e eeded... (defin
03f0: 65 20 28 73 63 68 65 6d 65 2d 73 74 72 2d 3e 63 e (scheme-str->c
0400: 2d 73 74 72 2d 62 76 20 78 29 0a 20 20 20 20 28 -str-bv x). (
0410: 6c 65 74 2a 20 28 28 62 76 20 28 73 74 72 69 6e let* ((bv (strin
0420: 67 2d 3e 62 79 74 65 76 65 63 74 6f 72 20 78 20 g->bytevector x
0430: 28 6e 61 74 69 76 65 2d 74 72 61 6e 73 63 6f 64 (native-transcod
0440: 65 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 er))).
0450: 20 28 6c 65 6e 20 28 62 79 74 65 76 65 63 74 6f (len (bytevecto
0460: 72 2d 6c 65 6e 67 74 68 20 62 76 29 29 0a 20 20 r-length bv)).
0470: 20 20 20 20 20 20 20 20 20 28 62 76 2f 7a 20 28 (bv/z (
0480: 6d 61 6b 65 2d 62 79 74 65 76 65 63 74 6f 72 20 make-bytevector
0490: 28 2b 20 31 20 6c 65 6e 29 29 29 29 0a 20 20 20 (+ 1 len)))).
04a0: 20 20 20 28 62 79 74 65 76 65 63 74 6f 72 2d 63 (bytevector-c
04b0: 6f 70 79 21 20 62 76 20 30 20 62 76 2f 7a 20 30 opy! bv 0 bv/z 0
04c0: 20 6c 65 6e 29 0a 20 20 20 20 20 20 28 62 79 74 len). (byt
04d0: 65 76 65 63 74 6f 72 2d 75 38 2d 73 65 74 21 20 evector-u8-set!
04e0: 62 76 2f 7a 20 6c 65 6e 20 30 29 0a 20 20 20 20 bv/z len 0).
04f0: 20 20 62 76 2f 7a 29 29 0a 0a 20 20 28 64 65 66 bv/z)).. (def
0500: 69 6e 65 20 28 63 2d 73 74 72 2d 70 74 72 2d 3e ine (c-str-ptr->
0510: 73 63 68 65 6d 65 2d 73 74 72 20 78 29 0a 20 20 scheme-str x).
0520: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 78 20 (let loop ((x
0530: 78 29 20 28 61 20 27 28 29 29 29 0a 20 20 20 20 x) (a '())).
0540: 20 20 28 6c 65 74 20 28 28 62 20 28 25 70 65 65 (let ((b (%pee
0550: 6b 38 75 20 78 29 29 29 0a 20 20 20 20 20 20 20 k8u x))).
0560: 20 28 69 66 20 28 7a 65 72 6f 3f 20 62 29 0a 20 (if (zero? b).
0570: 20 20 20 20 20 20 20 20 20 28 62 79 74 65 76 65 (byteve
0580: 63 74 6f 72 2d 3e 73 74 72 69 6e 67 20 28 75 38 ctor->string (u8
0590: 2d 6c 69 73 74 2d 3e 62 79 74 65 76 65 63 74 6f -list->bytevecto
05a0: 72 20 28 72 65 76 65 72 73 65 20 61 29 29 0a 20 r (reverse a)).
05b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
05c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 61 (na
05d0: 74 69 76 65 2d 74 72 61 6e 73 63 6f 64 65 72 29 tive-transcoder)
05e0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f ). (loo
05f0: 70 20 28 2b 20 31 20 78 29 20 28 63 6f 6e 73 20 p (+ 1 x) (cons
0600: 62 20 61 29 29 29 29 29 29 0a 20 20 0a 20 20 28 b a)))))). . (
0610: 64 65 66 69 6e 65 20 67 65 74 65 6e 76 0a 20 20 define getenv.
0620: 20 20 28 66 6f 72 65 69 67 6e 2d 70 72 6f 63 65 (foreign-proce
0630: 64 75 72 65 20 22 67 65 74 65 6e 76 22 20 27 28 dure "getenv" '(
0640: 62 6f 78 65 64 29 20 27 76 6f 69 64 2a 29 29 0a boxed) 'void*)).
0650: 20 20 0a 20 20 28 64 65 66 69 6e 65 20 28 67 65 . (define (ge
0660: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
0670: 72 69 61 62 6c 65 20 6e 61 6d 65 29 20 0a 20 20 riable name) .
0680: 20 20 28 75 6e 6c 65 73 73 20 28 73 74 72 69 6e (unless (strin
0690: 67 3f 20 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 g? name). (
06a0: 61 73 73 65 72 74 69 6f 6e 2d 76 69 6f 6c 61 74 assertion-violat
06b0: 69 6f 6e 20 27 67 65 74 2d 65 6e 76 69 72 6f 6e ion 'get-environ
06c0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 6e ment-variable "n
06d0: 6f 74 20 61 20 73 74 72 69 6e 67 22 20 6e 61 6d ot a string" nam
06e0: 65 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 70 e)). (let ((p
06f0: 20 28 67 65 74 65 6e 76 20 28 73 63 68 65 6d 65 (getenv (scheme
0700: 2d 73 74 72 2d 3e 63 2d 73 74 72 2d 62 76 20 6e -str->c-str-bv n
0710: 61 6d 65 29 29 29 29 0a 20 20 20 20 20 20 28 61 ame)))). (a
0720: 6e 64 20 70 0a 20 20 20 20 20 20 20 20 20 20 20 nd p.
0730: 28 63 2d 73 74 72 2d 70 74 72 2d 3e 73 63 68 65 (c-str-ptr->sche
0740: 6d 65 2d 73 74 72 20 28 76 6f 69 64 2a 2d 3e 61 me-str (void*->a
0750: 64 64 72 65 73 73 20 70 29 29 29 29 29 0a 0a 20 ddress p)))))..
0760: 20 3b 3b 20 54 4f 44 4f 3a 20 57 69 6c 6c 20 66 ;; TODO: Will f
0770: 6f 72 65 69 67 6e 2d 76 61 72 69 61 62 6c 65 20 oreign-variable
0780: 73 75 70 70 6f 72 74 20 61 20 70 6f 69 6e 74 65 support a pointe
0790: 72 20 74 79 70 65 20 69 6e 20 74 68 65 20 66 75 r type in the fu
07a0: 74 75 72 65 3f 0a 20 20 3b 3b 20 20 20 20 20 20 ture?. ;;
07b0: 20 57 6f 75 6c 64 20 74 68 69 73 20 62 65 20 74 Would this be t
07c0: 68 65 20 63 6f 72 72 65 63 74 20 77 61 79 20 74 he correct way t
07d0: 6f 20 75 73 65 20 69 74 3f 0a 20 20 23 3b 28 64 o use it?. #;(d
07e0: 65 66 69 6e 65 20 65 6e 76 69 72 6f 6e 0a 20 20 efine environ.
07f0: 20 20 20 20 28 66 6f 72 65 69 67 6e 2d 76 61 72 (foreign-var
0800: 69 61 62 6c 65 20 22 65 6e 76 69 72 6f 6e 22 20 iable "environ"
0810: 27 76 6f 69 64 2a 29 29 0a 0a 20 20 3b 3b 20 54 'void*)).. ;; T
0820: 4f 44 4f 3a 20 49 73 20 28 66 66 69 2f 64 6c 6f ODO: Is (ffi/dlo
0830: 70 65 6e 20 22 22 29 20 6f 6b 61 79 3f 20 20 49 pen "") okay? I
0840: 74 20 77 6f 72 6b 73 20 66 6f 72 20 6d 65 20 6f t works for me o
0850: 6e 20 55 62 75 6e 74 75 20 4c 69 6e 75 78 20 38 n Ubuntu Linux 8
0860: 2e 31 30 2e 0a 20 20 28 64 65 66 69 6e 65 20 65 .10.. (define e
0870: 6e 76 69 72 6f 6e 0a 20 20 20 20 28 66 65 61 74 nviron. (feat
0880: 75 72 65 2d 63 6f 6e 64 0a 20 20 20 20 20 28 6c ure-cond. (l
0890: 69 6e 75 78 0a 20 20 20 20 20 20 28 25 70 65 65 inux. (%pee
08a0: 6b 2d 70 6f 69 6e 74 65 72 20 28 66 66 69 2f 64 k-pointer (ffi/d
08b0: 6c 73 79 6d 20 28 66 66 69 2f 64 6c 6f 70 65 6e lsym (ffi/dlopen
08c0: 20 22 22 29 20 22 65 6e 76 69 72 6f 6e 22 29 29 "") "environ"))
08d0: 29 29 29 0a 0a 20 20 28 64 65 66 69 6e 65 20 28 ))).. (define (
08e0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
08f0: 76 61 72 69 61 62 6c 65 73 29 0a 20 20 20 20 28 variables). (
0900: 64 65 66 69 6e 65 20 28 65 6e 74 72 79 2d 3e 70 define (entry->p
0910: 61 69 72 20 78 29 20 0a 20 20 20 20 20 20 28 6c air x) . (l
0920: 65 74 2a 20 28 28 73 20 28 63 2d 73 74 72 2d 70 et* ((s (c-str-p
0930: 74 72 2d 3e 73 63 68 65 6d 65 2d 73 74 72 20 78 tr->scheme-str x
0940: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0950: 28 6c 65 6e 20 28 73 74 72 69 6e 67 2d 6c 65 6e (len (string-len
0960: 67 74 68 20 73 29 29 29 0a 20 20 20 20 20 20 20 gth s))).
0970: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 20 30 (let loop ((i 0
0980: 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 )). (if
0990: 20 28 3c 20 69 20 6c 65 6e 29 0a 20 20 20 20 20 (< i len).
09a0: 20 20 20 20 20 20 20 28 69 66 20 28 63 68 61 72 (if (char
09b0: 3d 3f 20 23 5c 3d 20 28 73 74 72 69 6e 67 2d 72 =? #\= (string-r
09c0: 65 66 20 73 20 69 29 29 0a 20 20 20 20 20 20 20 ef s i)).
09d0: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 28 73 75 (cons (su
09e0: 62 73 74 72 69 6e 67 20 73 20 30 20 69 29 0a 20 bstring s 0 i).
09f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a00: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 73 20 (substring s
0a10: 28 2b 20 31 20 69 29 20 6c 65 6e 29 29 0a 20 20 (+ 1 i) len)).
0a20: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
0a30: 70 20 28 2b 20 31 20 69 29 29 29 0a 20 20 20 20 p (+ 1 i))).
0a40: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 73 20 (cons s
0a50: 23 46 29 29 29 29 29 0a 20 20 20 20 28 6c 65 74 #F))))). (let
0a60: 20 6c 6f 6f 70 20 28 28 65 20 65 6e 76 69 72 6f loop ((e enviro
0a70: 6e 29 20 28 61 20 27 28 29 29 29 0a 20 20 20 20 n) (a '())).
0a80: 20 20 28 6c 65 74 20 28 28 65 6e 74 72 79 20 28 (let ((entry (
0a90: 25 70 65 65 6b 2d 70 6f 69 6e 74 65 72 20 65 29 %peek-pointer e)
0aa0: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
0ab0: 66 6f 72 65 69 67 6e 2d 6e 75 6c 6c 2d 70 6f 69 foreign-null-poi
0ac0: 6e 74 65 72 3f 20 65 6e 74 72 79 29 0a 20 20 20 nter? entry).
0ad0: 20 20 20 20 20 20 20 61 0a 20 20 20 20 20 20 20 a.
0ae0: 20 20 20 28 6c 6f 6f 70 20 28 2b 20 73 69 7a 65 (loop (+ size
0af0: 6f 66 3a 70 6f 69 6e 74 65 72 20 65 29 0a 20 20 of:pointer e).
0b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
0b10: 6f 6e 73 20 28 65 6e 74 72 79 2d 3e 70 61 69 72 ons (entry->pair
0b20: 20 65 6e 74 72 79 29 20 61 29 29 29 29 29 29 0a entry) a)))))).
0b30: 29 0a ).