[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 13/42: `class' is a hygienic macro
From: |
Andy Wingo |
Subject: |
[Guile-commits] 13/42: `class' is a hygienic macro |
Date: |
Sat, 10 Jan 2015 00:03:07 +0000 |
wingo pushed a commit to branch wip-goops-refactor
in repository guile.
commit 55ee6b224712c9020dd6a4bf43d26e0ba6aa6423
Author: Andy Wingo <address@hidden>
Date: Sun Jan 4 15:18:39 2015 -0500
`class' is a hygienic macro
* module/oop/goops.scm (class): Rewrite as a hygienic macro.
---
module/oop/goops.scm | 82 +++++++++++++++++++++++---------------------------
1 files changed, 38 insertions(+), 44 deletions(-)
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index f7ea30f..e5b4a49 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
;;; installed-scm-file
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011,
2013, 2014 Free Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011,
2013, 2014, 2015 Free Software Foundation, Inc.
;;;; Copyright (C) 1993-1998 Erick Gallesio - I3S-CNRS/ESSI <address@hidden>
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -590,20 +590,6 @@
;;; OPTION ::= KEYWORD VALUE
;;;
-(define (kw-do-map mapper f kwargs)
- (define (keywords l)
- (cond
- ((null? l) '())
- ((or (null? (cdr l)) (not (keyword? (car l))))
- (goops-error "malformed keyword arguments: ~a" kwargs))
- (else (cons (car l) (keywords (cddr l))))))
- (define (args l)
- (if (null? l) '() (cons (cadr l) (args (cddr l)))))
- ;; let* to check keywords first
- (let* ((k (keywords kwargs))
- (a (args kwargs)))
- (mapper f k a)))
-
(define (make-class supers slots . options)
(let* ((name (get-keyword #:name options (make-unbound)))
(supers (if (not (or-map (lambda (class)
@@ -638,35 +624,43 @@
;;; SLOT-DEFINITION ::= SLOT-NAME | (SLOT-NAME OPTION ...)
;;; OPTION ::= KEYWORD VALUE
;;;
-(define-macro (class supers . slots)
- (define (make-slot-definition-forms slots)
- (map
- (lambda (def)
- (cond
- ((pair? def)
- `(list ',(car def)
- ,@(kw-do-map append-map
- (lambda (kw arg)
- (case kw
- ((#:init-form)
- `(#:init-form ',arg
- #:init-thunk (lambda () ,arg)))
- (else (list kw arg))))
- (cdr def))))
- (else
- `(list ',def))))
- slots))
- (if (not (list? supers))
- (goops-error "malformed superclass list: ~S" supers))
- (let ((slots (take-while (lambda (x) (not (keyword? x))) slots))
- (options (or (find-tail keyword? slots) '())))
- `(make-class
- ;; evaluate super class variables
- (list ,@supers)
- ;; evaluate slot definitions, except the slot name!
- (list ,@(make-slot-definition-forms slots))
- ;; evaluate class options
- ,@options)))
+(define-syntax class
+ (lambda (x)
+ (define (parse-options options)
+ (syntax-case options ()
+ (() #'())
+ ((kw arg . options) (keyword? (syntax->datum #'kw))
+ (with-syntax ((options (parse-options #'options)))
+ (syntax-case #'kw ()
+ (#:init-form
+ #'(kw 'arg #:init-thunk (lambda () arg) . options))
+ (_
+ #'(kw arg . options)))))))
+ (define (check-valid-kwargs args)
+ (syntax-case args ()
+ (() #'())
+ ((kw arg . args) (keyword? (syntax->datum #'kw))
+ #`(kw arg . #,(check-valid-kwargs #'args)))))
+ (define (parse-slots-and-kwargs args)
+ (syntax-case args ()
+ (()
+ #'(() ()))
+ ((kw . _) (keyword? (syntax->datum #'kw))
+ #`(() #,(check-valid-kwargs args)))
+ (((name option ...) args ...)
+ (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...)))
+ ((option ...) (parse-options #'(option ...))))
+ #'(((list 'name option ...) . slots) kwargs)))
+ ((name args ...) (symbol? (syntax->datum #'name))
+ (with-syntax (((slots kwargs) (parse-slots-and-kwargs #'(args ...))))
+ #'(('(name) . slots) kwargs)))))
+ (syntax-case x ()
+ ((class (super ...) arg ...)
+ (with-syntax ((((slot-def ...) (option ...))
+ (parse-slots-and-kwargs #'(arg ...))))
+ #'(make-class (list super ...)
+ (list slot-def ...)
+ option ...))))))
(define-syntax define-class-pre-definition
(lambda (x)
- [Guile-commits] 05/42: More useless goops.c code removal, (continued)
- [Guile-commits] 05/42: More useless goops.c code removal, Andy Wingo, 2015/01/09
- [Guile-commits] 03/42: Rewrite %method-more-specific? to be in Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 04/42: Remove unused macros in goops.c, Andy Wingo, 2015/01/09
- [Guile-commits] 10/42: Remove declarations without definitions, Andy Wingo, 2015/01/09
- [Guile-commits] 08/42: Preparation for more GOOPS refactorings, Andy Wingo, 2015/01/09
- [Guile-commits] 06/42: compute-cpl implementation only in Scheme, Andy Wingo, 2015/01/09
- [Guile-commits] 09/42: Remove unused %fast-slot-ref / %fast-slot-set! from GOOPS, Andy Wingo, 2015/01/09
- [Guile-commits] 12/42: Deprecate scm_basic_make_class, Andy Wingo, 2015/01/09
- [Guile-commits] 14/42: define-generic, define-extended-generic are hygienic syntax, Andy Wingo, 2015/01/09
- [Guile-commits] 07/42: %init-goops-builtins is an extension, not a global, Andy Wingo, 2015/01/09
- [Guile-commits] 13/42: `class' is a hygienic macro,
Andy Wingo <=
- [Guile-commits] 16/42: Further GOOPS simplifications, Andy Wingo, 2015/01/09
- [Guile-commits] 18/42: Remove unused scm_t_method and SCM_METHOD, Andy Wingo, 2015/01/09
- [Guile-commits] 15/42: Remove unused *goops-module* definition., Andy Wingo, 2015/01/09
- [Guile-commits] 19/42: Deprecate scm_no_applicable_method C export, Andy Wingo, 2015/01/09
- [Guile-commits] 21/42: Remove useless scm_s_slot_set_x export, Andy Wingo, 2015/01/09
- [Guile-commits] 20/42: Remove unreachable code in scm_setter, Andy Wingo, 2015/01/09
- [Guile-commits] 02/42: Deprecate C interfaces scm_compute_applicable_methods, scm_find_method, Andy Wingo, 2015/01/09
- [Guile-commits] 23/42: Remove unused CPP defines naming <method> slots, Andy Wingo, 2015/01/09
- [Guile-commits] 27/42: Remove scm_at_assert_bound_ref, Andy Wingo, 2015/01/09
- [Guile-commits] 28/42: Remove scm_assert_bound, Andy Wingo, 2015/01/09