conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Improved error reports in records.procedural as per Derick 

Eddington's suggestions and removed the record-name check for
non-generative records.
This commit is contained in:
Abdulaziz Ghuloum 2007-12-01 22:32:19 -05:00
parent fc3f347830
commit 113add26ac
6 changed files with 73 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
doc/ikarus-scheme-users-guide.pdf
View File

Binary file not shown.

2
doc/ikarus-scheme-users-guide.tex
View File

@ -820,7 +820,7 @@ you need to specify that explicitly as in the following example.
This definition gives us, in addition to the constructor, predicate,
and accessors, two additional procedures:
\begin{itemize}
\item The mutators \texttt{set-point-x!} and \texttt{set-point-y!} that,
\item The mutators \texttt{point-x-set!} and \texttt{point-y-set!} that,
given a record of type point, and a new value, sets the value stored in the
\texttt{x} field or \texttt{y} field to the new value.
\end{itemize}

11
scheme/ikarus.records.procedural.ss
View File

@ -54,16 +54,14 @@
(not (rtd-opaque? rtd))))))
(define (record-rtd x)
(define (err x)
(error 'record-rtd "not a record" x))
(if ($struct? x)
(let ([rtd ($struct-rtd x)])
(if (rtd? rtd)
(if (not (rtd-opaque? rtd))
rtd
(err x))
(err x)))
(err x)))
(error 'record-rtd "record is opaque"))
(error 'record-rtd "not a record" x)))
(error 'record-rtd "not a record" x)))
(define (record-type-name x)
(if (rtd? x)
@ -179,7 +177,8 @@
[(lookup-rtd uid) =>
(lambda (rtd)
(unless
(and (eqv? name (rtd-name rtd))
(and ; must not check name!
; (eqv? name (rtd-name rtd))
(eqv? parent (rtd-parent rtd))
(eqv? sealed? (rtd-sealed? rtd))
(eqv? opaque? (rtd-opaque? rtd))

113
scheme/ikarus.sort.ss
View File

@ -20,65 +20,68 @@
(ikarus system $fx)
(except (ikarus) list-sort vector-sort vector-sort!))
(define (merge1 <? a1 ls1 ls2)
(cond
[(null? ls2) ls1]
[else
(let ([a2 (car ls2)])
(cond
[(<? a2 a1)
(cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
[else
(cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
(module (sort-tail)
(define (merge1 <? a1 ls1 ls2)
(cond
[(null? ls2) ls1]
[else
(let ([a2 (car ls2)])
(cond
[(<? a2 a1)
(cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
[else
(cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
(define (merge2 <? a2 ls1 ls2)
(cond
[(null? ls1) ls2]
[else
(let ([a1 (car ls1)])
(cond
[(<? a2 a1)
(cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
[else
(cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
(define (merge2 <? a2 ls1 ls2)
(cond
[(null? ls1) ls2]
[else
(let ([a1 (car ls1)])
(cond
[(<? a2 a1)
(cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
[else
(cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
(define (merge <? ls1 ls2)
(cond
[(null? ls2) ls1]
[else
(let ([a1 (car ls1)] [a2 (car ls2)])
(cond
[(<? a2 a1)
(cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
[else
(cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
(define (sort-head <? ls n)
(cond
[($fx= n 0) (values '() ls)]
[($fx= n 1)
(values (cons (car ls) '()) (cdr ls))]
[else
(let-values ([(sorted-head tail)
(sort-head <? ls ($fxsra n 1))])
(let-values ([(sorted-tail tail)
(sort-head <? tail ($fx- n ($fxsra n 1)))])
(values (merge <? sorted-head sorted-tail) tail)))]))
(define (sort-tail <? ls n)
(cond
[($fx<= n 1) ls]
[else
(let-values ([(sorted-head tail)
(sort-head <? ls ($fxsra n 1))])
(merge <? sorted-head (sort-tail <? tail ($fx- n ($fxsra n 1)))))]))
(define (merge <? ls1 ls2)
(cond
[(null? ls2) ls1]
[else
(let ([a1 (car ls1)] [a2 (car ls2)])
(cond
[(<? a2 a1)
(cons a2 (merge1 <? a1 ls1 (cdr ls2)))]
[else
(cons a1 (merge2 <? a2 (cdr ls1) ls2))]))]))
(define (sort-head <? ls n)
(cond
[($fx= n 0) (values '() ls)]
[($fx= n 1)
(values (cons (car ls) '()) (cdr ls))]
[else
(let-values ([(sorted-head tail)
(sort-head <? ls ($fxsra n 1))])
(let-values ([(sorted-tail tail)
(sort-head <? tail ($fx- n ($fxsra n 1)))])
(values (merge <? sorted-head sorted-tail) tail)))]))
(define (sort-tail <? ls n)
(cond
[($fx<= n 1) ls]
[else
(let-values ([(sorted-head tail)
(sort-head <? ls ($fxsra n 1))])
(merge <? sorted-head
(sort-tail <? tail ($fx- n ($fxsra n 1)))))])))
(define (list-sort <? ls)
(unless (procedure? <?)
(error 'list-sort "not a procedure" <?))
(sort-tail <? ls (length ls)))
(define (vector-sort <? v)
;;; FIXME: improve
(unless (procedure? <?)
@ -89,6 +92,8 @@
(sort-tail <? (vector->list v) (vector-length v))))
(define (vector-sort! <? v)
(import (ikarus system $vectors))
(import (ikarus system $pairs))
(unless (procedure? <?)
(error 'vector-sort! "not a procedure" <?))
(unless (vector? v)
@ -96,8 +101,8 @@
(let f ([i 0] [v v]
[ls (sort-tail <? (vector->list v) (vector-length v))])
(unless (null? ls)
(vector-set! v i (car ls))
(f (fx+ i 1) v (cdr ls)))))
($vector-set! v i ($car ls))
(f ($fx+ i 1) v ($cdr ls)))))
)

2
scheme/last-revision
View File

@ -1 +1 @@
1160
1162

13
scheme/pass-specify-rep-primops.ss
View File

@ -60,19 +60,20 @@
(dirty-vector-set addr))]
[else (dirty-vector-set addr)]))
(define (mem-assign v x i)
(define (slow-mem-assign v x i)
(with-tmp ([t (prm 'int+ x (K i))])
(make-seq
(prm 'mset t (K 0) (T v))
(dirty-vector-set t))))
(define (smart-mem-assign what v x i)
(struct-case what
(define (mem-assign v x i)
(struct-case v
[(constant t)
(if (or (fixnum? t) (immediate? t))
(prm 'mset x (K i) v)
(mem-assign v x i))]
[else (mem-assign v x i)]))
(prm 'mset x (K i) (T v))
(slow-mem-assign v x i))]
[else (slow-mem-assign v x i)]))
(define (align-code unknown-amt known-amt)
(prm 'sll