File: coerce.scm

package info (click to toggle)
scheme48 1.8%2Bdfsg-1
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 14,980 kB
  • ctags: 14,127
  • sloc: lisp: 76,272; ansic: 71,514; sh: 3,026; makefile: 637
file content (29 lines) | stat: -rw-r--r-- 818 bytes parent folder | download | duplicates (4)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
; Copyright (c) 1993-2008 by Richard Kelsey.  See file COPYING.



(define-local-syntax (define-primitive id nargs)
  (let ((args (reverse (list-tail '(z y x) (- '3 nargs)))))
    `(define (,id . ,args)
       (call-primitively ,id . ,args))))

(define-primitive make-byte-vector 1)
(define-primitive null-pointer? 1)

(define (byte-vector-ref vec index)
  (call-primitively byte-contents-int8 (pointer-add vec index)))

(define (byte-vector-set! vec index value)
  (call-primitively byte-set-contents-int8! (pointer-add vec index) value))

(define (pointer->integer x)
  (call-primitively coerce x '(pointer int8) 'int32))

(define (integer->pointer x)
  (call-primitively coerce x 'int32 '(pointer int8)))

(define (test)
  (let ((bv (make-byte-vector 10)))
    (if (null-pointer? bv)
	100
	(pointer->integer bv))))