added:
src/lab/ src/lab/ikarus.r6rs.records.procedural.ss src/lab/ikarus.r6rs.records.syntactic.ss These are nonworking versions of r6rs records facility
This commit is contained in:
Abdulaziz Ghuloum
parent
327de19e3b
commit
a6302bc57d
|
|
@ -8110,3 +8110,23 @@ Words allocated: 2754231001
|
|||
Words reclaimed: 0
|
||||
Elapsed time...: 25078 ms (User: 20914 ms; System: 4118 ms)
|
||||
Elapsed GC time: 13457 ms (CPU: 13523 in 10508 collections.)
|
||||
|
||||
****************************
|
||||
Benchmarking Larceny-r6rs on Mon Jun 18 18:05:57 AST 2007 under Darwin Vesuvius.local 8.9.1 Darwin Kernel Version 8.9.1: Thu Feb 22 20:55:00 PST 2007; root:xnu-792.18.15~1/RELEASE_I386 i386 i386
|
||||
|
||||
Testing sum1 under Larceny-r6rs
|
||||
Compiling...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
>
|
||||
Running...
|
||||
Larceny v0.93 "Deviated Prevert" (Nov 10 2006 04:27:45, precise:BSD Unix:unified)
|
||||
|
||||
|
||||
>
|
||||
Words allocated: 6553342
|
||||
Words reclaimed: 0
|
||||
Elapsed time...: 3454 ms (User: 2052 ms; System: 1399 ms)
|
||||
Elapsed GC time: 8 ms (CPU: 9 in 25 collections.)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,257 @@
|
|||
|
||||
(library (ikarus.r6rs.records.procedural)
|
||||
(export
|
||||
make-record-type-descriptor
|
||||
make-record-constructor-descriptor
|
||||
record-accessor record-mutator
|
||||
record-constructor record-predicate)
|
||||
(import
|
||||
(except (ikarus) record-constructor record-predicate)
|
||||
(ikarus system $records))
|
||||
|
||||
(define-record rtd (name size parent sealed? opaque? uid fields))
|
||||
(define rtd-alist '())
|
||||
(define (intern-rtd! uid rtd)
|
||||
(set! rtd-alist (cons (cons uid rtd) rtd-alist)))
|
||||
(define (lookup-rtd uid)
|
||||
(cond
|
||||
[(assq uid rtd-alist) => cdr]
|
||||
[else #f]))
|
||||
|
||||
|
||||
(define (record-type-descriptor? x) (rtd? x))
|
||||
|
||||
(module (make-record-type-descriptor)
|
||||
(define who 'make-record-type-descriptor)
|
||||
(define (make-rtd-aux name parent uid sealed? opaque? fields)
|
||||
(make-rtd name (vector-length fields) parent sealed? opaque? uid fields))
|
||||
(define (convert-fields pfv sv)
|
||||
(unless (vector? sv)
|
||||
(error who "invalid fields argument ~s" sv))
|
||||
(let ([n1 (vector-length pfv)]
|
||||
[n2 (vector-length sv)])
|
||||
(let ([v (make-vector (+ n1 n2))])
|
||||
(let f ([i 0])
|
||||
(unless (= i n1)
|
||||
(vector-set! v i (vector-ref pfv i))
|
||||
(f (add1 i))))
|
||||
(let f ([i 0])
|
||||
(unless (= i n2)
|
||||
(let ([x (vector-ref sv i)])
|
||||
(if (pair? x)
|
||||
(let ([m/u (car x)] [x (cdr x)])
|
||||
(if (pair? x)
|
||||
(let ([name (car x)])
|
||||
(unless (and (null? (cdr x)) (symbol? name))
|
||||
(error who "invalid fields argument ~s" sv))
|
||||
(vector-set! v (+ i n1)
|
||||
(cons (case m/u
|
||||
[(mutable) #t]
|
||||
[(immutable) #f]
|
||||
[else
|
||||
(error who "invalid fields argument ~s" sv)])
|
||||
name)))
|
||||
(error who "invalid fields argument ~s" sv)))
|
||||
(error who "invalid fields argument ~s" sv)))
|
||||
(f (add1 i))))
|
||||
v)))
|
||||
(define generate-rtd
|
||||
(lambda (name parent uid sealed? opaque? fields)
|
||||
(cond
|
||||
[(rtd? parent)
|
||||
(when (rtd-sealed? parent)
|
||||
(error who "cannot extend sealed parent ~s" parent))
|
||||
(make-rtd-aux name parent uid sealed?
|
||||
(or opaque? (rtd-opaque? parent))
|
||||
(convert-fields (rtd-fields parent) fields))]
|
||||
[(eqv? parent #f)
|
||||
(make-rtd-aux name parent uid sealed? opaque?
|
||||
(convert-fields '#() fields))]
|
||||
[else (error who "~s is not a valid parent" parent)])))
|
||||
(define (same-fields-as-rtd? fields rtd)
|
||||
(let* ([fv (rtd-fields rtd)]
|
||||
[n (vector-length fv)])
|
||||
(and (vector? fields)
|
||||
(= (vector-length fields) n)
|
||||
(let f ([i 0])
|
||||
(or (= i n)
|
||||
(let ([a (vector-ref fields i)]
|
||||
[b (vector-ref fv i)])
|
||||
(and
|
||||
(pair? a)
|
||||
(case (car a)
|
||||
[(mutable) (eqv? (car b) #t)]
|
||||
[(immutable) (eqv? (car b) #f)]
|
||||
[else #f])
|
||||
(let ([a (cdr a)])
|
||||
(and (pair? a)
|
||||
(null? (cdr a))
|
||||
(eq? (car a) (cdr b))))
|
||||
(f (+ i 1)))))))))
|
||||
(define make-nongenerative-rtd
|
||||
(lambda (name parent uid sealed? opaque? fields)
|
||||
(cond
|
||||
[(lookup-rtd uid) =>
|
||||
(lambda (rtd)
|
||||
(unless
|
||||
(and (eqv? name (rtd-name rtd))
|
||||
(eqv? parent (rtd-parent rtd))
|
||||
(eqv? sealed? (rtd-sealed? rtd))
|
||||
(eqv? opaque? (rtd-opaque? rtd))
|
||||
(same-fields-as-rtd? fields rtd))
|
||||
(error who "invalid arguments"))
|
||||
rtd)]
|
||||
[else
|
||||
(let ([rtd (generate-rtd name parent uid sealed? opaque? fields)])
|
||||
(intern-rtd! uid rtd)
|
||||
rtd)])))
|
||||
(define make-record-type-descriptor
|
||||
(lambda (name parent uid sealed? opaque? fields)
|
||||
(unless (symbol? name)
|
||||
(error who "~s is not a valid record type name" name))
|
||||
(unless (boolean? sealed?)
|
||||
(error who "~s is not a valid sealed? argument" sealed?))
|
||||
(unless (boolean? opaque?)
|
||||
(error who "~s is not a valid opaque? argument" opaque?))
|
||||
(cond
|
||||
[(symbol? uid)
|
||||
(make-nongenerative-rtd name parent uid sealed? opaque? fields)]
|
||||
[(eqv? uid #f)
|
||||
(generate-rtd name parent uid sealed? opaque? fields)]
|
||||
[else (error who "~s is not a valid uid" uid)]))))
|
||||
|
||||
(define-record rcd (rtd pproc proc))
|
||||
(define make-record-constructor-descriptor
|
||||
(lambda (rtd parent protocol)
|
||||
(define who 'make-record-constructor-descriptor)
|
||||
(define (make-rcd/default-proto&prcd rtd)
|
||||
(make-rcd rtd #f #f))
|
||||
(define (make-rcd/default-proto rtd parent)
|
||||
(cond
|
||||
[(not parent)
|
||||
(make-rcd/default-proto&prcd rtd)]
|
||||
[(rcd? parent)
|
||||
(error who "BUG1")]
|
||||
[else (error who "~s is not a valid record constructor descriptor"
|
||||
parent)]))
|
||||
(define (make-rcd/procedure-proto rtd parent protocol)
|
||||
(error who "BUG2"))
|
||||
(unless (rtd? rtd)
|
||||
(error who "~s is not an rtd" rtd))
|
||||
(cond
|
||||
[(not protocol)
|
||||
(make-rcd/default-proto rtd parent)]
|
||||
[(procedure? protocol)
|
||||
(make-rcd/procedure-proto rtd parent protocol)]
|
||||
[else (error who "~s is not a valid protocol" protocol)])))
|
||||
|
||||
(define (iota i n)
|
||||
(if (= i n)
|
||||
'()
|
||||
(cons i (iota (+ i 1) n))))
|
||||
(define (sym n)
|
||||
(string->symbol (format "v~s" n)))
|
||||
|
||||
(define (default-constructor-maker n)
|
||||
;;; FIXME: should cache compiled procedures
|
||||
(let ([vars (map sym (iota 0 n))])
|
||||
(eval `(lambda (rtd)
|
||||
(lambda ,vars
|
||||
($record rtd . ,vars)))
|
||||
(environment '(ikarus) '(ikarus system $records)))))
|
||||
|
||||
|
||||
|
||||
(define (record-constructor rcd)
|
||||
(define who 'record-constructor)
|
||||
(unless (rcd? rcd)
|
||||
(error who "~s is not a record constructor descriptor" rcd))
|
||||
(let ([rtd (rcd-rtd rcd)]
|
||||
[pproc (rcd-pproc rcd)]
|
||||
[proc (rcd-proc rcd)])
|
||||
(cond
|
||||
[(not pproc)
|
||||
(cond
|
||||
[(not proc)
|
||||
((default-constructor-maker (rtd-size rtd)) rtd)]
|
||||
[else (error who "BUG")])]
|
||||
[else (error who "BUG")])))
|
||||
|
||||
(define (record-accessor rtd k)
|
||||
(define who 'record-accessor)
|
||||
(unless (rtd? rtd)
|
||||
(error who "~s is not an rtd" rtd))
|
||||
(unless (and (fixnum? k) (fx>= k 0))
|
||||
(error who "~s is not a valid index" k))
|
||||
(let ([sz (rtd-size rtd)]
|
||||
[p (rtd-parent rtd)])
|
||||
(let ([i (if p (+ k (rtd-size p)) k)])
|
||||
(unless (fx< i sz)
|
||||
(error who "~s is not a valid index" k))
|
||||
(lambda (x)
|
||||
(cond
|
||||
[($record/rtd? x rtd) ($record-ref x i)]
|
||||
[($record? x)
|
||||
(let ([xrtd ($record-rtd x)])
|
||||
(unless (rtd? xrtd)
|
||||
(error who "~s is not of type ~s" x rtd))
|
||||
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i])
|
||||
(cond
|
||||
[(eq? prtd rtd) ($record-ref x i)]
|
||||
[(not prtd)
|
||||
(error who "~s is not of type ~s" x rtd)]
|
||||
[else (f (rtd-parent prtd) rtd x i)])))]
|
||||
[else (error who "~s is not of type ~s" x rtd)])))))
|
||||
|
||||
(define (record-mutator rtd k)
|
||||
(define who 'record-mutator)
|
||||
(unless (rtd? rtd)
|
||||
(error who "~s is not an rtd" rtd))
|
||||
(unless (and (fixnum? k) (fx>= k 0))
|
||||
(error who "~s is not a valid index" k))
|
||||
(let ([sz (rtd-size rtd)]
|
||||
[p (rtd-parent rtd)])
|
||||
(let ([i (if p (+ k (rtd-size p)) k)])
|
||||
(unless (fx< i sz)
|
||||
(error who "~s is not a valid index" k))
|
||||
(unless (car (vector-ref (rtd-fields rtd) k))
|
||||
(error who "field ~s of ~s is not mutable" k rtd))
|
||||
(lambda (x v)
|
||||
(cond
|
||||
[($record/rtd? x rtd) ($record-set! x i v)]
|
||||
[($record? x)
|
||||
(let ([xrtd ($record-rtd x)])
|
||||
(unless (rtd? xrtd)
|
||||
(error who "~s is not of type ~s" x rtd))
|
||||
(let f ([prtd (rtd-parent xrtd)] [rtd rtd] [x x] [i i] [v v])
|
||||
(cond
|
||||
[(eq? prtd rtd) ($record-set! x i v)]
|
||||
[(not prtd)
|
||||
(error who "~s is not of type ~s" x rtd)]
|
||||
[else (f (rtd-parent prtd) rtd x i v)])))]
|
||||
[else (error who "~s is not of type ~s" x rtd)])))))
|
||||
|
||||
(define (record-predicate rtd)
|
||||
(define who 'record-predicate)
|
||||
(unless (rtd? rtd)
|
||||
(error who "~s is not an rtd" rtd))
|
||||
(let ([sz (rtd-size rtd)]
|
||||
[p (rtd-parent rtd)])
|
||||
(lambda (x)
|
||||
(cond
|
||||
[($record/rtd? x rtd) #t]
|
||||
[($record? x)
|
||||
(let ([xrtd ($record-rtd x)])
|
||||
(and (rtd? xrtd)
|
||||
(let f ([prtd (rtd-parent xrtd)] [rtd rtd])
|
||||
(cond
|
||||
[(eq? prtd rtd) #t]
|
||||
[(not prtd) #f]
|
||||
[else (f (rtd-parent prtd) rtd)]))))]
|
||||
[else #f]))))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
)
|
||||
|
|
@ -0,0 +1,231 @@
|
|||
|
||||
|
||||
|
||||
;;; (define-record-type <namespec> <clause> ...)
|
||||
;;; <namespec> ::= (<record-name> <constructor-name> <predicate-name>)
|
||||
;;; | <record-name>
|
||||
;;; <clause> ::= (fields <fieldspec> ...)
|
||||
;;; | (protocol <expr>)
|
||||
;;; | (parent <parent-name>)
|
||||
;;; | (sealed <bool>) ; defaults to #f
|
||||
;;; | (opaque <bool>) ; defaults to #f
|
||||
;;; | (nongenerative <uid>) ; use uid
|
||||
;;; | (nongenerative) ; compile-time generative
|
||||
;;;
|
||||
;;; <fieldspec> ::= (immutable <fieldname> <accessorname>)
|
||||
;;; | (mutable <fieldname> <accessorname> <mutattorname>)
|
||||
;;; | (immutable <fieldname>)
|
||||
;;; | (mutable <fieldname>)
|
||||
;;; | <fieldname> ; defaults to immutable
|
||||
;;;
|
||||
;;; (record-type-descriptor <record-name>) => rtd
|
||||
;;; (record-constructor-descriptor <record-name>) => rcd
|
||||
|
||||
|
||||
(library (ikarus r6rs records syntactic)
|
||||
(export ---)
|
||||
(import ---)
|
||||
(define-syntax define-record-type
|
||||
(lambda (x)
|
||||
(define (id ctxt . str*)
|
||||
(datum->syntax ctxt
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(map (lambda (x)
|
||||
(cond
|
||||
[(symbol? x) (symbol->string x)]
|
||||
[(string? x) x]
|
||||
[else (error 'define-record-type "BUG")]))
|
||||
str*)))))
|
||||
(define (get-record-name spec)
|
||||
(syntax-case spec ()
|
||||
[(foo make-foo foo?) #'foo]
|
||||
[foo #'foo]))
|
||||
(define (get-record-constructor-name spec ctxt)
|
||||
(syntax-case spec ()
|
||||
[(foo make-foo foo?) #'make-foo]
|
||||
[foo (id ctxt "make-" (syntax->datum #'foo))]))
|
||||
(define (get-record-predicate-name spec ctxt)
|
||||
(syntax-case spec ()
|
||||
[(foo make-foo foo?) #'foo?]
|
||||
[foo (id ctxt (syntax->datum #'foo) "?")]))
|
||||
(define (get-clause id ls)
|
||||
(syntax-case ls ()
|
||||
[() #f]
|
||||
[((x . rest) . ls)
|
||||
(if (free-identifier=? id #'x)
|
||||
#'(x . rest)
|
||||
(get-clause id #'ls))]))
|
||||
(define (foo-rtd-code ctxt name clause*)
|
||||
(define (convert-field-spec* ls)
|
||||
(list #'quote
|
||||
(list->vector
|
||||
(map (lambda (x)
|
||||
(syntax-case x (mutable immutable)
|
||||
[(mutable name . rest) #'(mutable name)]
|
||||
[(immutable name . rest) #'(immutable name)]
|
||||
[name #'(immutable name)]))
|
||||
ls))))
|
||||
(with-syntax ([name name]
|
||||
[parent-rtd-code
|
||||
(syntax-case (get-clause #'parent clause*) ()
|
||||
[(_ name) #'(record-type-descriptor name)]
|
||||
[_ #'#f])]
|
||||
[uid-code
|
||||
(syntax-case (get-clause #'nongenerative clause*) ()
|
||||
[(_) (datum->syntax ctxt (gensym))]
|
||||
[(_ uid) #''uid]
|
||||
[_ #'#f])]
|
||||
[sealed?
|
||||
(syntax-case (get-clause #'sealed? clause*) ()
|
||||
[(_ #t) #'#t]
|
||||
[_ #'#f])]
|
||||
[opaque?
|
||||
(syntax-case (get-clause #'opaque? clause*) ()
|
||||
[(_ #t) #'#t]
|
||||
[_ #'#f])]
|
||||
[fields
|
||||
(syntax-case (get-clause #'fields clause*) ()
|
||||
[(_ field-spec* ...)
|
||||
(convert-field-spec* #'(field-spec* ...))]
|
||||
[_ #''#()])])
|
||||
#'(make-record-type-descriptor 'name
|
||||
parent-rtd-code
|
||||
uid-code sealed? opaque? fields)))
|
||||
(define (foo-rcd-code clause*)
|
||||
(with-syntax ([parent-rcd-code
|
||||
(syntax-case (get-clause #'parent clause*) ()
|
||||
[(_ name) #'(record-constructor-descriptor name)]
|
||||
[_ #'#f])])
|
||||
#'(make-record-constructor-descriptor foo-rtd
|
||||
parent-rcd-code protocol)))
|
||||
(define (get-protocol-code clause*)
|
||||
(syntax-case (get-clause #'protocol clause*) ()
|
||||
[(_ expr) #'expr]
|
||||
[_ #'#f]))
|
||||
(define (do-define-record ctxt namespec clause*)
|
||||
(let ([foo (get-record-name namespec)])
|
||||
(with-syntax ([foo foo]
|
||||
[make-foo (get-record-constructor-name namespec ctxt)]
|
||||
[foo? (get-record-predicate-name namespec ctxt)]
|
||||
[foo-rtd-code (foo-rtd-code ctxt name clause*)]
|
||||
[protocol-code (get-protocol-code clause*)])
|
||||
#'(begin
|
||||
(define foo-rtd foo-rtd-code)
|
||||
(define protocol protocol-code)
|
||||
(define foo-rcd foo-rcd-code)
|
||||
(define-syntax foo (list '$rtd #'foo-rtd #'foo-rcd))
|
||||
(define foo? (record-predicate foo-rtd))
|
||||
(define make-foo (record-constructor foo-rcd))
|
||||
(define foo-x* (record-accessor foo-rtd idx*))
|
||||
...
|
||||
(define set-foo-x!* (record-mutator foo-rtd mutable-idx*))
|
||||
...)
|
||||
(syntax-case x ()
|
||||
[(ctxt namespec clause* ...)
|
||||
(do-define-record #'ctxt #'namespec #'(clause* ...))])))
|
||||
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define-record foo (bar baz))
|
||||
==
|
||||
(define-record-type foo
|
||||
(fields bar baz)
|
||||
(nongenerative))
|
||||
|
||||
(define-record-type foo (fields x y) (nongenerative))
|
||||
==
|
||||
(begin
|
||||
(define-syntax foo `($rtd <foo-rtd> <foo-rcd>))
|
||||
;;; <foo-rcd> = #[rcd <foo-rtd> #f #f]
|
||||
;;; <foo-rtd> = #[rtd foo <gensym> #(x y) ---]
|
||||
(define (make-foo x y)
|
||||
($record '<foo-rtd> x y))
|
||||
(define (foo? x)
|
||||
($record/rtd? x '<foo-rtd>))
|
||||
(define (foo-x x)
|
||||
(if ($record/rtd? x '<foo-rtd>) ($record-ref x 0) (error ---)))
|
||||
(define (foo-y x)
|
||||
(if ($record/rtd? x '<foo-rtd>) ($record-ref x 1) (error ---))))
|
||||
|
||||
(record-type-descriptor foo)
|
||||
==
|
||||
'<foo-rtd>
|
||||
|
||||
(record-constructor-descriptor foo)
|
||||
==
|
||||
'<foo-rcd>
|
||||
|
||||
(record-constructor '<foo-rcd>)
|
||||
=>
|
||||
(default-rtd-constructor '<foo-rtd>)
|
||||
=>
|
||||
(lambda (x y)
|
||||
($record '<foo-rtd> x y))
|
||||
|
||||
|
||||
|
||||
(define-record-type foo (fields x y) (generative))
|
||||
==
|
||||
(begin
|
||||
(define foo-rtd (make-rtd --- ---))
|
||||
(define foo-rcd (make-rcd foo-rtd #f #f))
|
||||
(define-syntax foo `($rtd #'foo-rtd #'foo-rcd))
|
||||
(define (make-foo x y)
|
||||
($record foo-rtd x y))
|
||||
(define (foo? x)
|
||||
($record/rtd? x foo-rtd))
|
||||
(define (foo-x x)
|
||||
(if ($record/rtd? x foo-rtd) ($record-ref x 0) (error ---)))
|
||||
(define (foo-y x)
|
||||
(if ($record/rtd? x foo-rtd) ($record-ref x 1) (error ---))))
|
||||
|
||||
|
||||
(define-record-type foo
|
||||
(fields x y)
|
||||
(parent pfoo) ;;; pfoo = `($rtd <pfoo-rtd> <pfoo-rcd>)
|
||||
(nongenerative))
|
||||
==
|
||||
(begin
|
||||
(define-syntax foo `($rtd <foo-rtd> <foo-rcd>))
|
||||
;;; <pfoo-rcd> = #[rcd <foo-rtd> #f #f]
|
||||
;;; <foo-rcd> = #[rcd <foo-rtd> #f #f]
|
||||
;;; <foo-rtd> = #[rtd foo <gensym> #(x y) ---]
|
||||
(define (make-foo x y)
|
||||
($record '<foo-rtd> x y))
|
||||
(define (foo? x)
|
||||
($record/rtd? x '<foo-rtd>))
|
||||
(define (foo-x x)
|
||||
(if ($record/rtd? x '<foo-rtd>) ($record-ref x 2) (error ---)))
|
||||
(define (foo-y x)
|
||||
(if ($record/rtd? x '<foo-rtd>) ($record-ref x 3) (error ---))))
|
||||
|
||||
|
||||
|
||||
|
||||
(define-record-type bar
|
||||
(fields c)
|
||||
(parent foo)
|
||||
(protocol
|
||||
(lambda (p)
|
||||
(lambda (a b c)
|
||||
((p a b) c))))
|
||||
(sealed #f)
|
||||
(opaque #t)
|
||||
==
|
||||
(begin
|
||||
(define protocol-0
|
||||
(lambda (p)
|
||||
(lambda (a b c)
|
||||
((p a b) c))))
|
||||
(define bars-rtd '<some-rtd>)
|
||||
(define-syntax bar `($rtd <some rtd> <some rcd>))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -460,13 +460,6 @@
|
|||
[(P str) (K #t)]
|
||||
[(E str) (nop)])
|
||||
|
||||
;(define-primop primitive-set! unsafe
|
||||
; [(E x v) (mem-assign v (T x) (- disp-symbol-system-value symbol-tag))])
|
||||
;
|
||||
;(define-primop primitive-ref unsafe
|
||||
; [(V x) (prm 'mref (T x) (K (- disp-symbol-system-value symbol-tag)))]
|
||||
; [(E x) (nop)])
|
||||
|
||||
(define-primop $symbol-string unsafe
|
||||
[(V x) (prm 'mref (T x) (K (- disp-symbol-record-string symbol-ptag)))]
|
||||
[(E x) (nop)])
|
||||
|
|
@ -496,8 +489,6 @@
|
|||
[(E x v)
|
||||
(with-tmp ([x (T x)])
|
||||
(prm 'mset x (K (- disp-symbol-record-value symbol-ptag)) (T v))
|
||||
;(prm 'mset x (K (- disp-symbol-function symbol-tag))
|
||||
; (prm 'mref x (K (- disp-symbol-error-function symbol-tag))))
|
||||
(dirty-vector-set x))])
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue