~ chicken-core (chicken-5) 6a22ce5f51fe1ac2dd2f30cca09f3d02cc621a73
commit 6a22ce5f51fe1ac2dd2f30cca09f3d02cc621a73
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Aug 25 23:07:04 2014 +0200
Commit: Christian Kellermann <ckeen@pestilenz.org>
CommitDate: Fri Sep 12 09:23:24 2014 +0200
Removed memory-mapped files, object-eviction, binary-search and queues - these are now available as eggs.
Signed-off-by: Christian Kellermann <ckeen@pestilenz.org>
diff --git a/NEWS b/NEWS
index 6966d313..1a1daa0f 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,9 @@
+5.0.0 (preliminary)
+
+- Removed support for memory-mapped files (posix), queues (data-structures),
+ binary-search (data-structures) and object-eviction (lolevel). These
+ are now available as eggs.
+
4.9.1
- Security fixes
diff --git a/data-structures.import.scm b/data-structures.import.scm
index 2ddd78b7..561ffadd 100644
--- a/data-structures.import.scm
+++ b/data-structures.import.scm
@@ -32,7 +32,6 @@
alist-update
any?
atom?
- binary-search
butlast
chop
complement
@@ -48,22 +47,10 @@
identity
intersperse
join
- list->queue
list-of?
- make-queue
merge
merge!
o
- queue->list
- queue-add!
- queue-empty?
- queue-first
- queue-last
- queue-length
- queue-push-back!
- queue-push-back-list!
- queue-remove!
- queue?
rassoc
reverse-string-append
sort
diff --git a/data-structures.scm b/data-structures.scm
index a94c163d..22637e4c 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -757,138 +757,3 @@
(cdar dag)
'()
state)))))
-
-
-;;; Binary search:
-
-(define binary-search
- (lambda (vec proc)
- (if (pair? vec)
- (set! vec (list->vector vec))
- (##sys#check-vector vec 'binary-search) )
- (let ([len (##sys#size vec)])
- (and (fx> len 0)
- (let loop ([ps 0]
- [pe len] )
- (let ([p (fx+ ps (##core#inline "C_fixnum_shift_right" (fx- pe ps) 1))])
- (let* ([x (##sys#slot vec p)]
- [r (proc x)] )
- (cond [(fx= r 0) p]
- [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
- [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) )
-
-
-
-; Support for queues
-;
-; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
-;
-; This code is in the public domain.
-;
-; (heavily adapated for use with CHICKEN by felix)
-;
-
-
-; Elements in a queue are stored in a list. The last pair in the list
-; is stored in the queue type so that datums can be added in constant
-; time.
-
-(define (make-queue) (##sys#make-structure 'queue '() '() 0))
-(define (queue? x) (##sys#structure? x 'queue))
-
-(define (queue-length q) ; thread-safe
- (##sys#check-structure q 'queue 'queue-length)
- (##sys#slot q 3))
-
-(define (queue-empty? q) ; thread-safe
- (##sys#check-structure q 'queue 'queue-empty?)
- (eq? '() (##sys#slot q 1)) )
-
-(define queue-first ; thread-safe
- (lambda (q)
- (##sys#check-structure q 'queue 'queue-first)
- (let ((first-pair (##sys#slot q 1)))
- (when (eq? '() first-pair)
- (##sys#error 'queue-first "queue is empty" q))
- (##sys#slot first-pair 0) ) ) )
-
-(define queue-last ; thread-safe
- (lambda (q)
- (##sys#check-structure q 'queue 'queue-last)
- (let ((last-pair (##sys#slot q 2)))
- (when (eq? '() last-pair)
- (##sys#error 'queue-last "queue is empty" q))
- (##sys#slot last-pair 0) ) ) )
-
-(define (queue-add! q datum) ; thread-safe
- (##sys#check-structure q 'queue 'queue-add!)
- (let ((new-pair (cons datum '())))
- (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
- (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
- (##sys#setslot q 2 new-pair)
- (##sys#setislot q 3 (fx+ (##sys#slot q 3) 1))
- (##core#undefined) ) )
-
-(define queue-remove! ; thread-safe
- (lambda (q)
- (##sys#check-structure q 'queue 'queue-remove!)
- (let ((first-pair (##sys#slot q 1)))
- (when (eq? '() first-pair)
- (##sys#error 'queue-remove! "queue is empty" q) )
- (let ((first-cdr (##sys#slot first-pair 1)))
- (##sys#setslot q 1 first-cdr)
- (if (eq? '() first-cdr)
- (##sys#setslot q 2 '()) )
- (##sys#setislot q 3 (fx- (##sys#slot q 3) 1))
- (##sys#slot first-pair 0) ) ) ) )
-
-(define (queue->list q)
- (##sys#check-structure q 'queue 'queue->list)
- (let loop ((lst (##sys#slot q 1)) (lst2 '()))
- (if (null? lst)
- (##sys#fast-reverse lst2)
- (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) lst2)))))
-
-(define (list->queue lst0)
- (##sys#check-list lst0 'list->queue)
- (##sys#make-structure
- 'queue lst0
- (if (eq? lst0 '())
- '()
- (do ((lst lst0 (##sys#slot lst 1)))
- ((eq? (##sys#slot lst 1) '()) lst)
- (if (or (not (##core#inline "C_blockp" lst))
- (not (##core#inline "C_pairp" lst)) )
- (##sys#error-not-a-proper-list lst0 'list->queue) ) ) )
- (##sys#length lst0)) )
-
-
-; (queue-push-back! queue item)
-; Pushes an item into the first position of a queue.
-
-(define (queue-push-back! q item) ; thread-safe
- (##sys#check-structure q 'queue 'queue-push-back!)
- (let ((newlist (cons item (##sys#slot q 1))))
- (##sys#setslot q 1 newlist)
- (if (eq? '() (##sys#slot q 2))
- (##sys#setslot q 2 newlist))
- (##sys#setislot q 3 (fx+ (##sys#slot q 3) 1))))
-
-; (queue-push-back-list! queue item-list)
-; Pushes the items in item-list back onto the queue,
-; so that (car item-list) becomes the next removable item.
-
-(define-inline (last-pair lst0)
- (do ((lst lst0 (##sys#slot lst 1)))
- ((eq? (##sys#slot lst 1) '()) lst)))
-
-(define (queue-push-back-list! q itemlist)
- (##sys#check-structure q 'queue 'queue-push-back-list!)
- (##sys#check-list itemlist 'queue-push-back-list!)
- (let* ((newlist (append itemlist (##sys#slot q 1)))
- (newtail (if (eq? newlist '())
- '()
- (last-pair newlist))))
- (##sys#setslot q 1 newlist)
- (##sys#setslot q 2 newtail)
- (##sys#setislot q 3 (fx+ (##sys#slot q 3) (##core#inline "C_i_length" itemlist)))))
diff --git a/lolevel.import.scm b/lolevel.import.scm
index 7a60cc56..1e6f028e 100644
--- a/lolevel.import.scm
+++ b/lolevel.import.scm
@@ -50,12 +50,6 @@
object->pointer
object-become!
object-copy
- object-evict
- object-evict-to-location
- object-evicted?
- object-release
- object-size
- object-unevict
pointer->address
pointer-like?
pointer->object
diff --git a/lolevel.scm b/lolevel.scm
index b8ed9952..aeaeb79b 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -473,133 +473,6 @@ EOF
(##sys#setslot v i (##sys#slot x i)) ) ) )
-
-;;; Evict objects into static memory:
-
-(define (object-evicted? x) (##core#inline "C_permanentp" x))
-
-(define (object-evict x . allocator)
- (let ([allocator
- (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ]
- [tab (make-hash-table eq?)] )
- (##sys#check-closure allocator 'object-evict)
- (let evict ([x x])
- (cond [(not (##core#inline "C_blockp" x)) x ]
- [(hash-table-ref/default tab x #f) ]
- [else
- (let* ([n (##sys#size x)]
- [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
- [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
- (when (symbol? x) (##sys#setislot y 0 (void)))
- (hash-table-set! tab x y)
- (unless (##core#inline "C_byteblockp" x)
- (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
- [(fx>= i n)]
- ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
- (##sys#setislot y i (evict (##sys#slot x i))) ) )
- y ) ] ) ) ) )
-
-(define (object-evict-to-location x ptr . limit)
- (##sys#check-special ptr 'object-evict-to-location)
- (let* ([limit (and (pair? limit)
- (let ([limit (car limit)])
- (##sys#check-exact limit 'object-evict-to-location)
- limit)) ]
- [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
- [tab (make-hash-table eq?)]
- [x2
- (let evict ([x x])
- (cond [(not (##core#inline "C_blockp" x)) x ]
- [(hash-table-ref/default tab x #f) ]
- [else
- (let* ([n (##sys#size x)]
- [bytes
- (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
- (##core#inline "C_bytes" 1) ) ] )
- (when limit
- (set! limit (fx- limit bytes))
- (when (fx< limit 0)
- (signal
- (make-composite-condition
- (make-property-condition
- 'exn 'location 'object-evict-to-location
- 'message "cannot evict object - limit exceeded"
- 'arguments (list x limit))
- (make-property-condition 'evict 'limit limit) ) ) ) )
- (let ([y (##core#inline "C_evict_block" x ptr2)])
- (when (symbol? x) (##sys#setislot y 0 (void)))
- (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
- (hash-table-set! tab x y)
- (unless (##core#inline "C_byteblockp" x)
- (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
- [(fx>= i n)]
- (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
- y) ) ] ) ) ] )
- (values x2 ptr2) ) )
-
-(define (object-release x . releaser)
- (let ([free (if (pair? releaser)
- (car releaser)
- (foreign-lambda void "C_free" c-pointer) ) ]
- [released '() ] )
- (let release ([x x])
- (cond [(not (##core#inline "C_blockp" x)) x ]
- [(not (##core#inline "C_permanentp" x)) x ]
- [(memq x released) x ]
- [else
- (let ([n (##sys#size x)])
- (set! released (cons x released))
- (unless (##core#inline "C_byteblockp" x)
- (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
- [(fx>= i n)]
- (release (##sys#slot x i))) )
- (free
- (##sys#address->pointer
- (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
-
-(define (object-size x)
- (let ([tab (make-hash-table eq?)])
- (let evict ([x x])
- (cond [(not (##core#inline "C_blockp" x)) 0 ]
- [(hash-table-ref/default tab x #f) 0 ]
- [else
- (let* ([n (##sys#size x)]
- [bytes
- (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
- (##core#inline "C_bytes" 1) ) ] )
- (hash-table-set! tab x #t)
- (unless (##core#inline "C_byteblockp" x)
- (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
- [(fx>= i n)]
- (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
- bytes) ] ) ) ) )
-
-(define (object-unevict x #!optional full)
- (let ([tab (make-hash-table eq?)])
- (let copy ([x x])
- (cond [(not (##core#inline "C_blockp" x)) x ]
- [(not (##core#inline "C_permanentp" x)) x ]
- [(hash-table-ref/default tab x #f) ]
- [(##core#inline "C_byteblockp" x)
- (if full
- (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
- (hash-table-set! tab x y)
- y)
- x) ]
- [(symbol? x)
- (let ([y (##sys#intern-symbol (##sys#slot x 1))])
- (hash-table-set! tab x y)
- y) ]
- [else
- (let* ([words (##sys#size x)]
- [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
- (hash-table-set! tab x y)
- (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
- ((fx>= i words))
- (##sys#setslot y i (copy (##sys#slot y i))) )
- y) ] ) ) ) )
-
-
;;; `become':
(define (object-become! alst)
diff --git a/manual/Acknowledgements b/manual/Acknowledgements
index 107a9444..c8c4f090 100644
--- a/manual/Acknowledgements
+++ b/manual/Acknowledgements
@@ -77,7 +77,6 @@ CHICKEN contains code from several people:
; Richard O'Keefe : sorting routines.
; Alex Shinn : the [[http://synthcode.com/scheme/irregex/|irregex]] regular expression package.
; Olin Shivers : implementation of {{let-optionals[*]}} and reference implementations of SRFI-1, SRFI-13 and SRFI-14.
-; Andrew Wilcox : queues.
The documentation and examples for explicit renaming macros was taken from
the following paper:
diff --git a/manual/Types b/manual/Types
index b2861f6c..904a37ef 100644
--- a/manual/Types
+++ b/manual/Types
@@ -186,12 +186,10 @@ these names directly in type-specifications - {{TYPE}} corresponds to
<tr><td>{{f32vector}}</td><td>SRFI-4 byte vector</td></tr>
<tr><td>{{f64vector}}</td><td>SRFI-4 byte vector</td></tr>
<tr><td>{{thread}}</td><td>SRFI-18 thread</td></tr>
-<tr><td>{{queue}}</td><td>see "data-structures" unit</td></tr>
<tr><td>{{environment}}</td><td>evaluation environment</td></tr>
<tr><td>{{time}}</td><td>SRFI-18 "time" object</td></tr>
<tr><td>{{continuation}}</td><td>continuation object</td></tr>
<tr><td>{{lock}}</td><td>lock object from "posix" unit</td></tr>
-<tr><td>{{mmap}}</td><td>memory mapped file</td></tr>
<tr><td>{{condition}}</td><td>object representing exception</td></tr>
<tr><td>{{hash-table}}</td><td>SRFI-69 hash-table</td></tr>
<tr><td>{{tcp-listener}}</td><td>listener object from "tcp" unit</td></tr>
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
index 803db577..c38ac0c7 100644
--- a/manual/Unit data-structures
+++ b/manual/Unit data-structures
@@ -123,103 +123,6 @@ between each sublist. {{LIST}} defaults to the empty list.
Returns true if {{X}} is one of the tails (cdr's) of {{LIST}}.
-=== Queues
-
-
-==== list->queue
-
-<procedure>(list->queue LIST)</procedure>
-
-Returns {{LIST}} converted into a queue, where the first element
-of the list is the same as the first element of the queue. The resulting
-queue may share memory with the list and the list should not be modified
-after this operation.
-
-
-==== make-queue
-
-<procedure>(make-queue)</procedure>
-
-Returns a newly created queue.
-
-
-==== queue?
-
-<procedure>(queue? X)</procedure>
-
-Returns {{#t}} if {{X}} is a queue, or {{#f}} otherwise.
-
-
-==== queue-length
-
-<procedure>(queue-length QUEUE)</procedure>
-
-Returns the current number of items stored in {{QUEUE}}.
-
-
-==== queue->list
-
-<procedure>(queue->list QUEUE)</procedure>
-
-Returns {{QUEUE}} converted into a list, where the first element
-of the list is the same as the first element of the queue. The resulting
-list is freshly allocated and does not share memory with the queue object.
-
-
-==== queue-add!
-
-<procedure>(queue-add! QUEUE X)</procedure>
-
-Adds {{X}} to the rear of {{QUEUE}}.
-
-
-==== queue-empty?
-
-<procedure>(queue-empty? QUEUE)</procedure>
-
-Returns {{#t}} if {{QUEUE}} is empty, or {{#f}} otherwise.
-
-
-==== queue-first
-
-<procedure>(queue-first QUEUE)</procedure>
-
-Returns the first element of {{QUEUE}}. If {{QUEUE}} is empty
-an error is signaled
-
-
-==== queue-last
-
-<procedure>(queue-last QUEUE)</procedure>
-
-Returns the last element of {{QUEUE}}. If {{QUEUE}} is empty
-an error is signaled
-
-
-==== queue-remove!
-
-<procedure>(queue-remove! QUEUE)</procedure>
-
-Removes and returns the first element of {{QUEUE}}. If {{QUEUE}}
-is empty an error is signaled
-
-
-==== queue-push-back!
-
-<procedure>(queue-push-back! QUEUE ITEM)</procedure>
-
-Pushes an item into the first position of a queue, i.e. the next
-{{queue-remove!}} will return {{ITEM}}.
-
-
-==== queue-push-back-list!
-
-<procedure>(queue-push-back-list! QUEUE LIST)</procedure>
-
-Pushes the items in item-list back onto the queue,
-so that {{(car LIST)}} becomes the next removable item.
-
-
=== Sorting
@@ -583,20 +486,6 @@ A single value version of {{compose}} (slightly faster). {{(o)}} is equivalent
to {{identity}}.
-=== Binary searching
-
-
-==== binary-search
-
-<procedure>(binary-search SEQUENCE PROC)</procedure>
-
-Performs a binary search in {{SEQUENCE}}, which should be a sorted
-list or vector. {{PROC}} is called to compare items in the sequence,
-should accept a single argument and return an exact integer: zero if the
-searched value is equal to the current item, negative if the searched
-value is ''less'' than the current item, and positive otherwise.
-Returns the index of the found value or {{#f}} otherwise.
-
---
Previous: [[Unit expand]]
diff --git a/manual/Unit lolevel b/manual/Unit lolevel
index c7911220..7f800066 100644
--- a/manual/Unit lolevel
+++ b/manual/Unit lolevel
@@ -348,7 +348,6 @@ on the locative. The container object can be computed by calling the
{{locative->object}} procedure.
Locatives may be passed to foreign procedures that expect pointer arguments.
-The effect of creating locatives for evicted data (see {{object-evict}}) is undefined.
==== make-locative
@@ -530,101 +529,6 @@ for the source and destination arguments.
Signals an error if any of the above constraints is violated.
-
-=== Data in unmanaged memory
-
-
-==== object-evict
-
-<procedure>(object-evict X [ALLOCATOR])</procedure>
-
-Copies the object {{X}} recursively into the memory pointed to by the foreign
-pointer object returned by {{ALLOCATOR}}. The freshly copied object is
-returned. {{ALLOCATOR}} should be a procedure of a single argument
-(the number of bytes to allocate), and defaults to {{allocate}}.
-
-This facility allows moving arbitrary objects into static memory, but care
-should be taken when mutating evicted data: setting slots in evicted
-vector-like objects to non-evicted data is not allowed. It '''is''' possible to
-set characters/bytes in evicted strings or byte-vectors, though. It is
-advisable '''not''' to evict ports, because they might be mutated by certain
-file-operations. {{object-evict}} is able to handle circular and shared
-structures.
-
-Evicted symbols are no longer unique: a fresh copy of the
-symbol is created, so
-
-<enscript highlight=scheme>
-(define x 'foo)
-(define y (object-evict 'foo))
-y ==> foo
-(eq? x y) ==> #f
-(define z (object-evict '(bar bar)))
-(eq? (car z) (cadr z)) ==> #t
-</enscript>
-
-This loss of uniqueness also implies that an evicted structure --
-such as one created with {{define-record}} -- cannot be operated on with
-the existing predicate or accessors, as internally a symbol is used to
-denote the type:
-
-<enscript highlight=scheme>
-(define-record point x y)
-(point? (make-point x y)) ; => #t
-(point? (object-evict (make-point x y))) ; => #f
-</enscript>
-
-==== object-evict-to-location
-
-<procedure>(object-evict-to-location X POINTER* [LIMIT])</procedure>
-
-As {{object-evict}} but moves the object at the address pointed to by
-the pointer-like object {{POINTER*}}. If the number of copied bytes exceeds
-the optional {{LIMIT}} then an error is signalled (specifically a composite
-condition of types {{exn}} and {{evict}}. The latter provides
-a {{limit}} property which holds the exceeded limit. Two values are
-returned: the evicted object and a new pointer pointing to the first
-free address after the evicted object.
-
-Use of anything other than a pointer object as the {{POINTER*}} argument is
-questionable.
-
-==== object-evicted?
-
-<procedure>(object-evicted? X)</procedure>
-
-Returns {{#t}} if {{X}} is a non-immediate evicted data object, or {{#f}}
-otherwise.
-
-
-==== object-release
-
-<procedure>(object-release X [RELEASER])</procedure>
-
-Frees memory occupied by the evicted object {{X}} recursively.
-{{RELEASER}} should be a procedure of a single argument (a foreign
-pointer object to the static memory to be freed) and defaults to
-{{free}}.
-
-
-==== object-unevict
-
-<procedure>(object-unevict X [FULL])</procedure>
-
-Copies the object {{X}} and nested objects back into the normal Scheme heap.
-Symbols are re-interned into the symbol table. Strings and byte-vectors are
-'''not''' copied, unless {{FULL}} is given and not {{#f}}.
-
-
-==== object-size
-
-<procedure>(object-size X)</procedure>
-
-Returns the number of bytes that would be needed to evict the data object
-{{X}}. If {{X}} is an immediate object, zero is returned.
-
-
-
=== Record instance
diff --git a/manual/Unit posix b/manual/Unit posix
index af889722..73050973 100644
--- a/manual/Unit posix
+++ b/manual/Unit posix
@@ -1036,90 +1036,6 @@ the environment of the current process. If the variable is not defined,
nothing happens.
-=== Memory mapped I/O
-
-Memory mapped I/O takes the contents of a file descriptor and places them in memory.
-
-==== memory-mapped-file?
-
-<procedure>(memory-mapped-file? X)</procedure>
-
-Returns {{#t}}, if {{X}} is an object representing a memory
-mapped file, or {{#f}} otherwise.
-
-==== map-file-to-memory
-
-<procedure>(map-file-to-memory ADDRESS LEN PROTECTION FLAG FILENO [OFFSET])</procedure>
-
-Maps a section of a file to memory using the C function
-{{mmap()}}. {{ADDRESS}} should be a foreign pointer object
-or {{#f}}; {{LEN}} specifies the size of the section to
-be mapped; {{PROTECTION}} should be one or more of the flags
-{{prot/read, prot/write, prot/exec}} or {{prot/none}}
-'''bitwise-ior'''ed together; {{FLAG}} should be one or more of
-the flags {{map/fixed, map/shared, map/private, map/anonymous}} or
-{{map/file}}; {{FILENO}} should be the file-descriptor of the
-mapped file. The optional argument {{OFFSET}} gives the offset of
-the section of the file to be mapped and defaults to 0. This procedure
-returns an object representing the mapped file section. The procedure
-{{move-memory!}} can be used to access the mapped memory.
-
-==== memory-mapped-file-pointer
-
-<procedure>(memory-mapped-file-pointer MMAP)</procedure>
-
-Returns a machine pointer to the start of the memory region to which
-the file is mapped.
-
-==== unmap-file-from-memory
-
-<procedure>(unmap-file-from-memory MMAP [LEN])</procedure>
-
-Unmaps the section of a file mapped to memory using the C function
-{{munmap()}}. {{MMAP}} should be a mapped file as returned
-by the procedure {{map-file-to-memory}}. The optional argument
-{{LEN}} specifies the length of the section to be unmapped and
-defaults to the complete length given when the file was mapped.
-
-==== Memory Mapped I/O Example
-
-<enscript highlight=scheme>
-;; example-mmap.scm
-;;
-;; basic example of memory mapped I/O
-;;
-;; This example does no error checking or cleanup, and serves
-;; only to demonstrate how the mmap functions work together.
-;;
-(use posix)
-(use lolevel)
-
- ; open a file using the posix module, so we have the file descriptor.
-(let* ((fd (file-open "example-mmap.scm" (+ open/rdonly open/nonblock)))
- ; fstat(2) the file descriptor fd to determine its size
- (size (file-size fd))
- ; mmap(2) the file for reading.
- (mmap (map-file-to-memory #f
- size
- prot/read
- (+ map/file map/shared)
- fd))
- ; return a pointer object to the beginning of the memory map.
- (buf (memory-mapped-file-pointer mmap))
- ; allocate a string the same size as the file.
- (str (make-string size)))
- ; copy the mapped memory into a string
- (move-memory! buf str size)
- (display str)
- ; alternately, print the string byte-by-byte without copying.
- (let loop ((p buf)
- (i 0))
- (unless (= i size)
- (display (integer->char (pointer-s8-ref p)))
- (loop (pointer+ p 1) (+ i 1)))))
-</enscript>
-
-
=== Date and time routines
==== seconds->local-time
@@ -1386,7 +1302,6 @@ not be obtained. On Windows, this procedure always returns {{0}},
; {{initialize-groups}} : {{initgroups}}
; {{local-time->seconds}} : {{mktime}}
; {{local-timezone-abbreviation}} : {{localtime}}
-; {{map-file-to-memory}} : {{mmap}}
; {{open-input-file*}} : {{fdopen}}
; {{open-output-file*}} : {{fdopen}}
; {{open-input-pipe}} : {{popen}}
@@ -1419,7 +1334,6 @@ not be obtained. On Windows, this procedure always returns {{0}},
; {{terminal-port?}} : {{isatty}}
; {{time->string}} : {{asctime}}
; {{unsetenv}} : {{putenv}}
-; {{unmap-file-from-memory}} : {{munmap}}
; {{user-information}} : {{getpwnam/getpwuid}}
; {{utc-time->seconds}} : {{timegm}}
diff --git a/posix.import.scm b/posix.import.scm
index 02d3ca8c..17f38a74 100644
--- a/posix.import.scm
+++ b/posix.import.scm
@@ -136,14 +136,6 @@
initialize-groups
local-time->seconds
local-timezone-abbreviation
- map-file-to-memory
- map/anonymous
- map/file
- map/fixed
- map/private
- map/shared
- memory-mapped-file-pointer
- memory-mapped-file?
open-input-file*
open-input-pipe
open-output-file*
@@ -189,10 +181,6 @@
process-run
process-signal
process-wait
- prot/exec
- prot/none
- prot/read
- prot/write
read-symbolic-link
regular-file?
seconds->local-time
@@ -253,7 +241,6 @@
terminal-port?
terminal-size
time->string
- unmap-file-from-memory
unsetenv
user-information
utc-time->seconds
diff --git a/posixunix.scm b/posixunix.scm
index b6f9fccc..4e79c633 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1429,57 +1429,6 @@ EOF
"system error while trying to access file" filename) ) ) ) )
-;;; Memory mapped I/O:
-
-(define-foreign-variable _prot_read int "PROT_READ")
-(define-foreign-variable _prot_write int "PROT_WRITE")
-(define-foreign-variable _prot_exec int "PROT_EXEC")
-(define-foreign-variable _prot_none int "PROT_NONE")
-
-(define prot/read _prot_read)
-(define prot/write _prot_write)
-(define prot/exec _prot_exec)
-(define prot/none _prot_none)
-
-(define-foreign-variable _map_fixed int "MAP_FIXED")
-(define-foreign-variable _map_shared int "MAP_SHARED")
-(define-foreign-variable _map_private int "MAP_PRIVATE")
-(define-foreign-variable _map_anonymous int "MAP_ANON")
-(define-foreign-variable _map_file int "MAP_FILE")
-
-(define map/fixed _map_fixed)
-(define map/shared _map_shared)
-(define map/private _map_private)
-(define map/anonymous _map_anonymous)
-(define map/file _map_file)
-
-(define map-file-to-memory
- (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer)] )
- (lambda (addr len prot flag fd . off)
- (let ([addr (if (not addr) (##sys#null-pointer) addr)]
- [off (if (pair? off) (car off) 0)] )
- (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
- (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
- (let ([addr2 (mmap addr len prot flag fd off)])
- (when (eq? -1 (##sys#pointer->address addr2))
- (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
- (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
-
-(define unmap-file-from-memory
- (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
- (lambda (mmap . len)
- (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
- (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
- (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
- (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
-
-(define (memory-mapped-file-pointer mmap)
- (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
- (##sys#slot mmap 1) )
-
-(define (memory-mapped-file? x)
- (##sys#structure? x 'mmap) )
-
;;; Time related things:
(define string->time
diff --git a/posixwin.scm b/posixwin.scm
index 0af657d6..5c9aa220 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -1391,170 +1391,6 @@ EOF
(##sys#error 'current-user-name "cannot retrieve current user-name") ) ) )
-;;; memory mapped files
-
-#>
-#define PROT_NONE 0
-#define PROT_READ 1
-#define PROT_WRITE 2
-#define PROT_EXEC 4
-#define MAP_FILE 0
-#define MAP_SHARED 1
-#define MAP_PRIVATE 2
-#define MAP_FIXED 0x10
-#define MAP_ANONYMOUS 0x20
-
-// This value is available starting with Windows XP with SP2
-// and Windows Server 2003 with SP1.
-#ifndef FILE_MAP_EXECUTE
-#define FILE_MAP_EXECUTE 0x20
-#endif//FILE_MAP_EXECUTE
-
-static int page_flags[] =
-{
- 0,
- PAGE_READONLY,
- PAGE_READWRITE,
- PAGE_READWRITE,
- PAGE_EXECUTE_READ,
- PAGE_EXECUTE_READ,
- PAGE_EXECUTE_READWRITE
-};
-
-static int file_flags[] =
-{
- 0,
- FILE_MAP_READ,
- FILE_MAP_READ|FILE_MAP_WRITE,
- FILE_MAP_READ|FILE_MAP_WRITE,
- FILE_MAP_READ|FILE_MAP_EXECUTE,
- FILE_MAP_READ|FILE_MAP_EXECUTE,
- FILE_MAP_READ|FILE_MAP_WRITE|FILE_MAP_EXECUTE
-};
-
-void* mmap(void* addr,int len,int prot,int flags,int fd,int off)
-{
- HANDLE hMap;
- HANDLE hFile;
-
- void* ptr;
-
- if ((flags & MAP_FIXED) || (flags & MAP_PRIVATE) || (flags & MAP_ANONYMOUS))
- {
- errno = EINVAL;
- return (void*)-1;
- }
-
- /*
- * We must cast because _get_osfhandle returns intptr_t, but it must
- * be compared with INVALID_HANDLE_VALUE, which is a HANDLE type.
- * Who comes up with this shit?
- */
- hFile = (HANDLE)_get_osfhandle(fd);
- if (hFile == INVALID_HANDLE_VALUE)
- {
- return (void*)-1;
- }
-
- hMap = CreateFileMapping(
- hFile,
- NULL,
- page_flags[prot & (PROT_READ|PROT_WRITE|PROT_EXEC)],
- 0,
- 0,
- NULL);
-
- if (hMap == INVALID_HANDLE_VALUE)
- {
- set_last_errno();
- return (void*)-1;
- }
-
- ptr = MapViewOfFile(
- hMap,
- file_flags[prot & (PROT_READ|PROT_WRITE|PROT_EXEC)],
- 0,
- off,
- len);
-
- if (ptr == NULL)
- {
- set_last_errno();
- ptr = (void*)-1;
- }
-
- CloseHandle(hMap);
-
- return ptr;
-}
-
-int munmap(void* addr,int len)
-{
- if (UnmapViewOfFile(addr))
- {
- errno = 0;
- return 0;
- }
- set_last_errno();
- return -1;
-}
-
-int is_bad_mmap(void* p)
-{
- void* bad_ptr;
- bad_ptr = (void*)-1;
- return p == bad_ptr;
-}
-<#
-
-(define-foreign-variable _prot_none int "PROT_NONE")
-(define-foreign-variable _prot_read int "PROT_READ")
-(define-foreign-variable _prot_write int "PROT_WRITE")
-(define-foreign-variable _prot_exec int "PROT_EXEC")
-(define-foreign-variable _map_file int "MAP_FILE")
-(define-foreign-variable _map_shared int "MAP_SHARED")
-(define-foreign-variable _map_fixed int "MAP_FIXED")
-(define-foreign-variable _map_private int "MAP_PRIVATE")
-(define-foreign-variable _map_anonymous int "MAP_ANONYMOUS")
-
-(define prot/none _prot_none)
-(define prot/read _prot_read)
-(define prot/write _prot_write)
-(define prot/exec _prot_exec)
-(define map/file _map_file)
-(define map/shared _map_shared)
-(define map/private _map_private)
-(define map/fixed _map_fixed)
-(define map/anonymous _map_anonymous)
-
-(define map-file-to-memory
- (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer)]
- [bad-mmap? (foreign-lambda bool "is_bad_mmap" c-pointer)] )
- (lambda (addr len prot flag fd . off)
- (let ([addr (if (not addr) (##sys#null-pointer) addr)]
- [off (if (pair? off) (car off) 0)] )
- (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
- (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
- (let ([addr2 (mmap addr len prot flag fd off)])
- (when (bad-mmap? addr2)
- (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
- (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
-
-(define unmap-file-from-memory
- (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
- (lambda (mmap . len)
- (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
- (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
- (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
- (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
-
-(define (memory-mapped-file-pointer mmap)
- (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
- (##sys#slot mmap 1) )
-
-(define (memory-mapped-file? x)
- (##sys#structure? x 'mmap) )
-
;;; unimplemented stuff:
(define-syntax define-unimplemented
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
index 51c25a9e..141e8d52 100644
--- a/tests/data-structures-tests.scm
+++ b/tests/data-structures-tests.scm
@@ -63,117 +63,3 @@
(assert (equal? '(a b c d) (topological-sort '((a b) (b c) (c d)) eq?)))
(assert (equal? '(c d a b) (topological-sort '((a b) (c d)) eq?)))
(assert-error (topological-sort '((a b) (b a)) eq?))
-
-;; Queues.
-
-;; These are tested extensively (and probably still not enough)
-;; because of the strange dealings with the front and end lists stored
-;; internally. If we run into errors, add more regression tests here.
-
-(let ((q (make-queue)))
- (assert (queue? q))
- (assert (queue-empty? q))
- (assert (= 0 (queue-length q)))
- (assert (null? (queue->list q)))
- (assert-error (queue-first q))
- (assert-error (queue-last q))
- (assert-error (queue-remove! q))
-
- (queue-add! q 'foo)
- (assert (eq? 'foo (queue-first q)))
- (assert (eq? 'foo (queue-last q)))
- (assert (not (queue-empty? q)))
- (assert (= (queue-length q) 1))
- (let ((l1 (queue->list q))
- (l2 (queue->list q)))
- (assert (equal? l1 '(foo)))
- (assert (equal? l2 '(foo)))
- (assert (not (eq? l1 l2))) ; Do not share memory
-
- (queue-add! q 'end)
-
- (queue-push-back! q 'front)
-
- (assert (equal? l1 '(foo)))) ; Does not share memory w/ queue
- (assert (equal? (queue->list q) '(front foo end)))
-
- (assert (eq? 'front (queue-remove! q)))
- (assert (eq? 'foo (queue-first q)))
- (assert (eq? 'end (queue-last q)))
-
- (queue-push-back-list! q '(one two))
- (assert (equal? (queue->list q) '(one two foo end)))
- (assert (= 4 (queue-length q)))
-
- (assert (eq? 'one (queue-remove! q)))
- (assert (eq? 'two (queue-remove! q)))
- (assert (= 2 (queue-length q)))
- (assert (eq? 'foo (queue-first q)))
- (assert (eq? 'end (queue-last q)))
- (assert (not (queue-empty? q)))
-
- (assert (eq? 'foo (queue-remove! q)))
- (assert (eq? 'end (queue-first q)))
- (assert (eq? 'end (queue-last q)))
- (assert (= (queue-length q) 1))
- (assert (not (queue-empty? q)))
-
- (assert (eq? 'end (queue-remove! q)))
- (assert (queue-empty? q))
- (assert (= (queue-length q) 0))
- (assert-error (queue-first q))
- (assert-error (queue-last q))
- (assert-error (queue-remove! q)))
-
-(let ((q (list->queue (list 'one 'two))))
- (assert (queue? q))
- (assert (not (queue-empty? q)))
- (assert (= (queue-length q) 2))
- (assert (eq? 'one (queue-first q)))
- (assert (eq? 'two (queue-last q)))
-
- (assert (eq? 'one (queue-remove! q)))
- (assert (eq? 'two (queue-first q)))
- (assert (eq? 'two (queue-last q)))
- (assert (= (queue-length q) 1))
- (assert (not (queue-empty? q)))
-
- (assert (eq? 'two (queue-remove! q)))
- (assert-error (queue-first q))
- (assert-error (queue-last q))
- (assert (= (queue-length q) 0))
- (assert (queue-empty? q)))
-
-(let ((q (list->queue (list 'one))))
- (assert (queue? q))
- (assert (not (queue-empty? q)))
- (assert (= (queue-length q) 1))
- (assert (eq? 'one (queue-first q)))
- (assert (eq? 'one (queue-last q)))
-
- (queue-push-back! q 'zero)
- (assert (eq? 'zero (queue-first q)))
- (assert (eq? 'one (queue-last q)))
-
- (queue-add! q 'two)
- (assert (eq? 'zero (queue-first q)))
- (assert (eq? 'two (queue-last q)))
-
- (queue-add! q 'three)
- (assert (eq? 'zero (queue-first q)))
- (assert (eq? 'three (queue-last q)))
- (assert (equal? '(zero one two three) (queue->list q)))
-
- (assert (eq? 'zero (queue-remove! q)))
- (assert (eq? 'one (queue-first q)))
- (assert (eq? 'three (queue-last q)))
- (assert (= (queue-length q) 3))
- (assert (not (queue-empty? q)))
-
- (assert (eq? 'one (queue-remove! q)))
- (assert (eq? 'two (queue-remove! q)))
- (assert (eq? 'three (queue-remove! q)))
- (assert-error (queue-first q))
- (assert-error (queue-last q))
- (assert (= (queue-length q) 0))
- (assert (queue-empty? q)))
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index d0398fac..d0812fbf 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -228,26 +228,6 @@
(assert (equal? '#(test a b) (record->vector some-record)))
-; object-evict
-; object-evicted?
-; object-size
-; object-release
-
-(define tstvec (vector #f))
-(let ((sz (object-size tstvec)))
- (assert (and (integer? sz) (positive? sz))) )
-(define ev-tstvec (object-evict tstvec))
-(assert (not (eq? tstvec ev-tstvec)))
-(assert (object-evicted? ev-tstvec))
-(set! ev-tstvec
- (let ((old ev-tstvec))
- (object-release old)
- #f))
-
-; object-evict-to-location
-
-; object-unevict
-
; object-become!
(define some-foo '#(1 2 3))
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index 4459e36e..f2fd896e 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -43,17 +43,6 @@
(assert (equal? 'ok (read in)))
(assert (equal? 'err (read err))))
-(let ((tnpfilpn (create-temporary-file)))
- (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat)))
- (data "abcde")
- (size 5))
- (file-write tmpfilno data)
- (let ((mmap (map-file-to-memory #f size prot/read (+ map/shared map/file) tmpfilno))
- (str (make-string size)))
- (move-memory! (memory-mapped-file-pointer mmap) str size)
- (assert (blob=? (string->blob data) (string->blob str)))
- (unmap-file-from-memory mmap))))
-
(let* ((tmp-dir (create-temporary-directory))
(tmp-dot (make-pathname (list tmp-dir "foo" "bar") ".baz")))
(create-directory tmp-dot 'recursively)
diff --git a/types.db b/types.db
index 6a202dd9..50ba718b 100644
--- a/types.db
+++ b/types.db
@@ -1199,7 +1199,6 @@
((pair) (let ((#(tmp) #(1))) '#f))
(((not (or pair list))) (let ((#(tmp) #(1))) '#t)))
-(binary-search (forall (a) (#(procedure #:enforce) binary-search ((vector-of a) (procedure (a) *)) *)))
(butlast (forall (a) (#(procedure #:clean #:enforce) butlast ((pair a *)) (list-of a))))
(chop (forall (a) (#(procedure #:clean #:enforce) chop ((list-of a) fixnum) (list-of a))))
(complement (#(procedure #:clean #:enforce) complement ((procedure (#!rest) *)) (procedure (#!rest) boolean)))
@@ -1215,9 +1214,7 @@
(identity (forall (a) (#(procedure #:pure) identity (a) a)))
(intersperse (#(procedure #:clean #:enforce) intersperse (list *) list))
(join (#(procedure #:clean #:enforce) join ((list-of list) #!optional list) list))
-(list->queue (#(procedure #:clean #:enforce) list->queue (list) (struct queue)))
(list-of? (#(procedure #:clean #:enforce) list-of? ((procedure (*) *)) (procedure (list) boolean)))
-(make-queue (#(procedure #:pure) make-queue () (struct queue)))
(merge
(forall (e)
@@ -1228,22 +1225,6 @@
(#(procedure #:enforce) merge! ((list-of e) (list-of e) (procedure (e e) *)) (list-of e))))
(o (#(procedure #:clean #:enforce) o (#!rest (procedure (*) *)) (procedure (*) *)))
-(queue->list (#(procedure #:clean #:enforce) queue->list ((struct queue)) list))
-(queue-add! (#(procedure #:clean #:enforce) queue-add! ((struct queue) *) undefined))
-
-(queue-empty? (#(procedure #:clean #:enforce) queue-empty? ((struct queue)) boolean)
- (((struct queue)) (##core#inline "C_i_nullp" (##sys#slot #(1) '1))))
-
-(queue-first (#(procedure #:clean #:enforce) queue-first ((struct queue)) *))
-(queue-last (#(procedure #:clean #:enforce) queue-last ((struct queue)) *))
-
-(queue-length (#(procedure #:clean #:enforce) queue-length ((struct queue)) fixnum)
- (((struct queue)) (##sys#slot #(1) '3)))
-
-(queue-push-back! (#(procedure #:clean #:enforce) queue-push-back! ((struct queue) *) undefined))
-(queue-push-back-list! (#(procedure #:clean #:enforce) queue-push-back-list! ((struct queue) list) undefined))
-(queue-remove! (#(procedure #:clean #:enforce) queue-remove! ((struct queue)) *))
-(queue? (#(procedure #:pure #:predicate (struct queue)) queue? (*) boolean))
(rassoc (#(procedure #:clean #:enforce) rassoc (* (list-of pair) #!optional (procedure (* *) *)) *))
(reverse-string-append (#(procedure #:clean #:enforce) reverse-string-append ((list-of string)) string))
@@ -1509,12 +1490,6 @@
(object->pointer (#(procedure #:clean) object->pointer (*) *))
(object-become! (procedure object-become! (list) *))
(object-copy (#(procedure #:clean) object-copy (*) *))
-(object-evict (#(procedure #:clean #:enforce) object-evict (* #!optional (procedure (fixnum) pointer)) *))
-(object-evict-to-location (#(procedure #:clean #:enforce) object-evict-to-location (* (or pointer locative procedure port) #!optional fixnum) * pointer))
-(object-evicted? (#(procedure #:pure) object-evicted? (*) boolean))
-(object-release (#(procedure #:enforce) object-release (* #!optional (procedure (pointer) *)) *))
-(object-size (#(procedure #:clean) object-size (*) fixnum))
-(object-unevict (procedure object-unevict (* #!optional *) *))
(pointer+ (#(procedure #:clean #:enforce) pointer+ ((or pointer procedure port locative) fixnum) pointer))
(pointer->address (#(procedure #:clean #:enforce) pointer->address ((or pointer procedure port locative)) number)
@@ -1718,14 +1693,6 @@
(initialize-groups (#(procedure #:clean #:enforce) initialize-groups (string fixnum) undefined))
(local-time->seconds (#(procedure #:clean #:enforce) local-time->seconds ((vector fixnum fixnum fixnum fixnum fixnum fixnum fixnum fixnum boolean fixnum)) number))
(local-timezone-abbreviation (#(procedure #:clean) local-timezone-abbreviation () string))
-(map-file-to-memory (#(procedure #:clean #:enforce) map-file-to-memory (* fixnum fixnum fixnum fixnum #!optional fixnum) (struct mmap)))
-(map/anonymous fixnum)
-(map/file fixnum)
-(map/fixed fixnum)
-(map/private fixnum)
-(map/shared fixnum)
-(memory-mapped-file-pointer (#(procedure #:clean #:enforce) memory-mapped-file-pointer ((struct mmap)) pointer))
-(memory-mapped-file? (#(procedure #:clean #:predicate (struct mmap)) memory-mapped-file? (*) boolean))
(open-input-file* (#(procedure #:clean #:enforce) open-input-file* (fixnum #!optional symbol) input-port))
(open-input-pipe (#(procedure #:clean #:enforce) open-input-pipe (string #!optional symbol) input-port))
(open-output-file* (#(procedure #:clean #:enforce) open-output-file* (fixnum #!optional symbol) output-port))
@@ -1775,10 +1742,6 @@
(process-run (#(procedure #:clean #:enforce) process-run (string #!optional (list-of string)) fixnum))
(process-signal (#(procedure #:clean #:enforce) process-signal (fixnum #!optional fixnum) undefined))
(process-wait (#(procedure #:clean #:enforce) process-wait (#!optional fixnum *) fixnum fixnum fixnum))
-(prot/exec fixnum)
-(prot/none fixnum)
-(prot/read fixnum)
-(prot/write fixnum)
(read-symbolic-link (#(procedure #:clean #:enforce) read-symbolic-link (string #!optional boolean) string))
(regular-file? (#(procedure #:clean #:enforce) regular-file? ((or string fixnum)) boolean))
(seconds->local-time (#(procedure #:clean #:enforce) seconds->local-time (#!optional number) (vector fixnum fixnum fixnum fixnum fixnum fixnum fixnum fixnum boolean fixnum)))
Trap