mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

Replace ice-9 match's structures with guile's records

Browse source 
* module/system/base/syntax.scm (define-record): Rebase to implement on
  top of Guile's records, which are the substrate of srfi-9's records.
  (%compute-initargs): Rename from %make-struct, just return the list of
  values.
  (get-slot, set-slot!, slot): Removed, no longer used.
  (record-case): Allow slots of the form (MYNAME SLOTNAME), which binds
  SLOTNAME to MYNAME (instead of SLOTNAME to SLOTNAME).
  (record-case, record?): No more ice-9 match!

* module/system/il/compile.scm (codegen): Tweaks so that the new record
  code works.

* module/system/il/ghil.scm: Fix some slot references.

* module/system/vm/assemble.scm (preprocess, codegen): Remove calls to
  `slot'.
  (codegen): Fix some slot references.
This commit is contained in:
Andy Wingo 2008-05-04 17:25:13 +02:00
parent a27bf0b7f6
commit f540e3271b
4 changed files with 54 additions and 83 deletions
Download patch file Download diff file Expand all files Collapse all files

101
module/system/base/syntax.scm
View file

@ -53,8 +53,12 @@
(define-macro (define-record def)
(let* ((name (car def)) (slots (cdr def))
(stem (symbol-trim-both name (list->char-set '(#\< #\>)))))
(slot-names (map (lambda (slot) (if (pair? slot) (car slot) slot))
slots))
(stem (symbol-trim-both name (list->char-set '(#\< #\>))))
(type (make-record-type (symbol->string name) slot-names)))
`(begin
(define ,name ,type)
(define ,(symbol-append 'make- stem)
(let ((slots (list ,@(map (lambda (slot)
(if (pair? slot)
@ -62,36 +66,28 @@
`',slot))
slots))))
(lambda args
(vector ',name (%make-struct args slots)))))
(define (,(symbol-append name '?) x)
(and (vector? x) (eq? (vector-ref x 0) ',name)))
,@(do ((n 1 (1+ n))
(slots (cdr def) (cdr slots))
(ls '() (append (let* ((sdef (car slots))
(sname (if (pair? sdef) (car sdef) sdef)))
`((define ,(string->symbol
(format #f "~A-~A" name n))
(lambda (x) (slot x ',sname)))
(define ,(symbol-append stem '- sname)
,(make-procedure-with-setter
(lambda (x) (get-slot x sname))
(lambda (x v) (set-slot! x sname v))))))
ls)))
((null? slots) (reverse! ls))))))
(apply ,(record-constructor type)
(,%compute-initargs args slots)))))
(define ,(symbol-append name '?) ,(record-predicate type))
,@(map (lambda (sname)
`(define ,(symbol-append stem '- sname)
,(make-procedure-with-setter
(record-accessor type sname)
(record-modifier type sname))))
slot-names))))
(define (%make-struct args slots)
(define (finish-bindings out)
(define (%compute-initargs args slots)
(define (finish out)
(map (lambda (slot)
(let ((name (if (pair? slot) (car slot) slot)))
(or (assq name out)
(if (pair? slot)
(cons name (cdr slot))
(error "unbound slot" args slots name)))))
(cond ((assq name out) => cdr)
((pair? slot) (cdr slot))
(else (error "unbound slot" args slots name)))))
slots))
(let lp ((in args) (positional slots) (out '()))
(cond
((null? in)
(finish-bindings out))
(finish out))
((keyword? (car in))
(let ((sym (keyword->symbol (car in))))
(cond
@ -106,21 +102,6 @@
(lp (cdr in) (cdr positional)
(acons (car positional) (car in) out))))))
(define (get-slot struct name . names)
(let ((data (assq name (vector-ref struct 1))))
(cond ((not data) (error "unknown slot" name))
((null? names) (cdr data))
(else (apply get-slot (cdr data) names)))))
(define (set-slot! struct name . rest)
(let ((data (assq name (vector-ref struct 1))))
(cond ((not data) (error "unknown slot" name))
((null? (cdr rest)) (set-cdr! data (car rest)))
(else (apply set-slot! (cdr data) rest)))))
(define slot
(make-procedure-with-setter get-slot set-slot!))
;;;
;;; Variants
@ -142,33 +123,23 @@
(define-macro (record-case record . clauses)
(let ((r (gensym)))
(define (process-clause clause)
(let ((record-type (caar clause))
(slots (cdar clause))
(body (cdr clause)))
`(((record-predicate ,record-type) ,r)
(let ,(map (lambda (slot)
`(,slot ((record-accessor ,record-type ',slot) ,r)))
slots)
,@body))))
(if (eq? (car clause) 'else)
clause
(let ((record-type (caar clause))
(slots (cdar clause))
(body (cdr clause)))
`(((record-predicate ,record-type) ,r)
(let ,(map (lambda (slot)
(if (pair? slot)
`(,(car slot) ((record-accessor ,record-type ',(cadr slot)) ,r))
`(,slot ((record-accessor ,record-type ',slot) ,r))))
slots)
,@body)))))
`(let ((,r ,record))
(cond ,@(map process-clause clauses)
(else (error "unhandled record" ,r))))))
;; These are short-lived, and headed to the chopping block.
(use-modules (ice-9 match))
(define-macro (record-case record . clauses)
(define (process-clause clause)
(if (eq? (car clause) 'else)
clause
`(($ ,@(car clause)) ,@(cdr clause))))
`(,match ,record ,@(map process-clause clauses)))
(define (record? x)
(and (vector? x)
(not (zero? (vector-length x)))
(symbol? (vector-ref x 0))
(eqv? (string-ref (symbol->string (vector-ref x 0)) 0) #\<)))
(export record?)
(cond ,@(let ((clauses (map process-clause clauses)))
(if (assq 'else clauses)
clauses
(append clauses `((else (error "unhandled record" ,r))))))))))
;;;

20
module/system/il/compile.scm
View file

@ -276,10 +276,10 @@
((<ghil-lambda> env loc vars rest body)
(return-code! (codegen tree)))
((<ghil-inline> env loc inst args)
((<ghil-inline> env loc inline args)
;; ARGS...
;; (INST NARGS)
(push-call! loc inst args)
(push-call! loc inline args)
(maybe-drop)
(maybe-return))
@ -293,19 +293,19 @@
;;
;; main
(record-case ghil
((<ghil-lambda> env loc args rest body)
(let* ((vars (ghil-env-variables env))
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) vars))
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) vars)))
((<ghil-lambda> env loc vars rest body)
(let* ((evars (ghil-env-variables env))
(locs (pick (lambda (v) (eq? (ghil-var-kind v) 'local)) evars))
(exts (pick (lambda (v) (eq? (ghil-var-kind v) 'external)) evars)))
;; initialize variable indexes
(finalize-index! args)
(finalize-index! vars)
(finalize-index! locs)
(finalize-index! exts)
;; meta bindings
(push-bindings! args)
(push-bindings! vars)
;; export arguments
(do ((n 0 (1+ n))
(l args (cdr l)))
(l vars (cdr l)))
((null? l))
(let ((v (car l)))
(case (ghil-var-kind v)
@ -315,7 +315,7 @@
;; compile body
(comp body #t #f)
;; create GLIL
(let ((vars (make-glil-vars :nargs (length args)
(let ((vars (make-glil-vars :nargs (length vars)
:nrest (if rest 1 0)
:nlocs (length locs)
:nexts (length exts))))

2
module/system/il/ghil.scm
View file

@ -155,7 +155,7 @@
(define-public (make-ghil-env e)
(record-case e
((<ghil-mod>) (%make-ghil-env :mod e :parent e))
((<ghil-env> m) (%make-ghil-env :mod m :parent e))))
((<ghil-env> mod) (%make-ghil-env :mod mod :parent e))))
(define (ghil-env-toplevel? e)
(eq? (ghil-env-mod e) (gil-env-parent e)))

14
module/system/vm/assemble.scm
View file

@ -54,14 +54,14 @@
(define (preprocess x e)
(record-case x
((<glil-asm> vars body)
(let* ((venv (make-venv :parent e :nexts (slot vars 'nexts) :closure? #f))
(let* ((venv (make-venv :parent e :nexts (glil-vars-nexts vars) :closure? #f))
(body (map (lambda (x) (preprocess x venv)) body)))
(make-vm-asm :venv venv :glil x :body body)))
((<glil-external> op depth index)
(do ((d depth (- d 1))
(e e (slot e 'parent)))
(e e (venv-parent e)))
((= d 0))
(set! (slot e 'closure?) #t))
(set! (venv-closure? e) #t))
x)
(else x)))
@ -100,9 +100,9 @@
(record-case x
((<vm-asm> venv)
(push-object! (codegen x #f))
(if (slot venv 'closure?) (push-code! `(make-closure))))
(if (venv-closure? venv) (push-code! `(make-closure))))
((<glil-bind> binds)
((<glil-bind> (binds vars))
(let ((bindings
(map (lambda (v)
(let ((name (car v)) (type (cadr v)) (i (caddr v)))
@ -123,8 +123,8 @@
((<glil-void>)
(push-code! '(void)))
((<glil-const> x)
(push-object! x))
((<glil-const> obj)
(push-object! obj))
((<glil-argument> op index)
(if (eq? op 'ref)