home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
OS/2 Shareware BBS: 10 Tools
/
10-Tools.zip
/
mitsch75.zip
/
scheme-7_5_17-src.zip
/
scheme-7.5.17
/
src
/
runtime
/
sdata.scm
< prev
next >
Wrap
Text File
|
1999-01-02
|
3KB
|
97 lines
#| -*-Scheme-*-
$Id: sdata.scm,v 14.3 1999/01/02 06:19:10 cph Exp $
Copyright (c) 1988-1999 Massachusetts Institute of Technology
This program 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 2 of the License, or (at
your option) any later version.
This program 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, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|#
;;;; Abstract Data Field
;;; package: (runtime scode-data)
(declare (usual-integrations))
(define (&typed-singleton-cons type element)
(system-pair-cons type (unmap-reference-trap element) '()))
(define (&singleton-element singleton)
(map-reference-trap (lambda () (system-pair-car singleton))))
(define (&singleton-set-element! singleton new-element)
(system-pair-set-car! singleton (unmap-reference-trap new-element)))
(define (&typed-pair-cons type car cdr)
(system-pair-cons type
(unmap-reference-trap car)
(unmap-reference-trap cdr)))
(define (&pair-car pair)
(map-reference-trap (lambda () (system-pair-car pair))))
(define (&pair-set-car! pair new-car)
(system-pair-set-car! pair (unmap-reference-trap new-car)))
(define (&pair-cdr pair)
(map-reference-trap (lambda () (system-pair-cdr pair))))
(define (&pair-set-cdr! pair new-cdr)
(system-pair-set-cdr! pair (unmap-reference-trap new-cdr)))
(define (&typed-triple-cons type first second third)
(object-new-type type
(hunk3-cons (unmap-reference-trap first)
(unmap-reference-trap second)
(unmap-reference-trap third))))
(define (&triple-first triple)
(map-reference-trap (lambda () (system-hunk3-cxr0 triple))))
(define (&triple-set-first! triple new-first)
(system-hunk3-set-cxr0! triple (unmap-reference-trap new-first)))
(define (&triple-second triple)
(map-reference-trap (lambda () (system-hunk3-cxr1 triple))))
(define (&triple-set-second! triple new-second)
(system-hunk3-set-cxr1! triple (unmap-reference-trap new-second)))
(define (&triple-third triple)
(map-reference-trap (lambda () (system-hunk3-cxr2 triple))))
(define (&triple-set-third! triple new-third)
(system-hunk3-set-cxr2! triple (unmap-reference-trap new-third)))
(define (&typed-vector-cons type elements)
(system-list->vector
type
(let loop ((elements elements))
(if (null? elements)
'()
(cons (unmap-reference-trap (car elements))
(loop (cdr elements)))))))
(define (&vector-length vector)
(system-vector-length vector))
(define (&vector-ref vector index)
(map-reference-trap (lambda () (system-vector-ref vector index))))
(define (&subvector->list vector start stop)
(let loop ((sublist (system-subvector->list vector start stop)))
(if (null? sublist)
'()
(cons (map-reference-trap (lambda () (car sublist)))
(loop (cdr sublist))))))