Commit | Line | Data |
---|---|---|
a7ee7f7c AW |
1 | #!/bin/sh |
2 | exec guile -q -s "$0" "$@" | |
3 | !# | |
4 | ;;; test-foreign-object-scm --- Foreign object interface. -*- Scheme -*- | |
5 | ;;; | |
6 | ;;; Copyright (C) 2014 Free Software Foundation, Inc. | |
7 | ;;; | |
8 | ;;; This library is free software; you can redistribute it and/or | |
9 | ;;; modify it under the terms of the GNU Lesser General Public | |
10 | ;;; License as published by the Free Software Foundation; either | |
11 | ;;; version 3 of the License, or (at your option) any later version. | |
12 | ;;; | |
13 | ;;; This library is distributed in the hope that it will be useful, | |
14 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
16 | ;;; Lesser General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU Lesser General Public | |
19 | ;;; License along with this library; if not, write to the Free Software | |
20 | ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA | |
21 | ||
22 | (use-modules (system foreign) | |
23 | (system foreign-object) | |
24 | (rnrs bytevectors) | |
25 | (oop goops)) | |
26 | ||
27 | (define (libc-ptr name) | |
28 | (catch #t | |
29 | (lambda () (dynamic-pointer name (dynamic-link))) | |
30 | (lambda (k . args) | |
31 | (print-exception (current-error-port) #f k args) | |
32 | (write "Skipping test.\n" (current-error-port)) | |
33 | (exit 0)))) | |
34 | ||
35 | (define malloc (pointer->procedure '* (libc-ptr "malloc") (list size_t))) | |
36 | (define memcpy (pointer->procedure void (libc-ptr "memcpy") (list '* '* size_t))) | |
37 | (define free (pointer->procedure void (libc-ptr "free") '(*))) | |
38 | ||
39 | (define (finalize-cstr cstr) | |
40 | (free (make-pointer (addr cstr)))) | |
41 | ||
42 | (define-foreign-object-type <cstr> make-cstr (addr len) | |
43 | #:finalizer finalize-cstr) | |
44 | ||
45 | (define (cstr->string cstr) | |
46 | (pointer->string (make-pointer (addr cstr)) (len cstr) "UTF-8")) | |
47 | ||
48 | (define* (string->cstr str #:optional (k make-cstr)) | |
49 | (let* ((bv (string->utf8 str)) | |
50 | (len (bytevector-length bv)) | |
51 | (mem (malloc len))) | |
52 | (when (null-pointer? mem) | |
53 | (error "Out of memory.")) | |
54 | (memcpy mem (bytevector->pointer bv) len) | |
55 | (k (pointer-address mem) len))) | |
56 | ||
57 | (define-method (write (cstr <cstr>) port) | |
58 | (format port "<<cstr> ~s>" (cstr->string cstr))) | |
59 | ||
60 | (define-method (display (cstr <cstr>) port) | |
61 | (display (cstr->string cstr) port)) | |
62 | ||
63 | (define-method (+ (a <cstr>) (b <cstr>)) | |
64 | (string->cstr (string-append (cstr->string a) (cstr->string b)))) | |
65 | ||
66 | (define-method (equal? (a <cstr>) (b <cstr>)) | |
67 | (equal? (cstr->string a) (cstr->string b))) | |
68 | ||
69 | (define failed? #f) | |
70 | (define-syntax test | |
71 | (syntax-rules () | |
72 | ((_ exp res) | |
73 | (let ((expected res) | |
74 | (actual exp)) | |
75 | (if (not (equal? actual expected)) | |
76 | (begin | |
77 | (set! failed? #t) | |
78 | (format (current-error-port) | |
79 | "bad return from expression `~a': expected ~A; got ~A~%" | |
80 | 'exp expected actual))))))) | |
81 | ||
82 | (test (string->cstr "Hello, world!") | |
83 | (+ (string->cstr "Hello, ") (string->cstr "world!"))) | |
84 | ||
85 | ;; GOOPS construction syntax instead of make-cstr. | |
86 | (test (string->cstr "Hello, world!") | |
87 | (string->cstr "Hello, world!" | |
88 | (lambda (addr len) | |
89 | (make <cstr> #:addr addr #:len len)))) | |
90 | ||
91 | ;; Subclassing. | |
92 | (define-class <wrapped-cstr> (<cstr>) | |
93 | (wrapped-string #:init-keyword #:wrapped-string | |
94 | #:getter wrapped-string | |
95 | #:init-form (error "missing #:wrapped-string"))) | |
96 | ||
97 | (define (string->wrapped-cstr string) | |
98 | (string->cstr string (lambda (addr len) | |
99 | (make <wrapped-cstr> #:addr addr #:len len | |
100 | #:wrapped-string string)))) | |
101 | ||
102 | (let ((wrapped-cstr (string->wrapped-cstr "Hello, world!"))) | |
103 | ;; Tests that <cst> methods work on <wrapped-cstr>. | |
104 | (test "Hello, world!" (cstr->string wrapped-cstr)) | |
105 | ;; Test the additional #:wrapped-string slot. | |
106 | (test "Hello, world!" (wrapped-string wrapped-cstr))) | |
107 | ||
108 | (gc) (gc) (gc) | |
109 | ||
110 | ;; Sleep 50 milliseconds to allow the finalization thread to run. | |
111 | (usleep #e50e3) | |
112 | ||
113 | ;; But we don't really know if it ran. Oh well. | |
114 | ||
115 | (exit (if failed? 1 0)) | |
116 | ||
117 | ;; Local Variables: | |
118 | ;; mode: scheme | |
119 | ;; End: |