diff options
author | michele.simionato <devnull@localhost> | 2009-03-23 07:13:56 +0000 |
---|---|---|
committer | michele.simionato <devnull@localhost> | 2009-03-23 07:13:56 +0000 |
commit | 25bd0f39b2879fd117b43b6dbad7ef030596329e (patch) | |
tree | 11ef1c8d0370189652df8aa3ee637251029074a3 /scheme | |
parent | c5135c9ccf5a70c7c862a04c326c527f9f4581cb (diff) | |
download | micheles-25bd0f39b2879fd117b43b6dbad7ef030596329e.tar.gz |
Committed a lot of work on my Adventures
Diffstat (limited to 'scheme')
-rw-r--r-- | scheme/aps/lang.sls | 33 | ||||
-rw-r--r-- | scheme/aps/list-match.sls | 70 | ||||
-rw-r--r-- | scheme/sweet-macros/main.sls | 13 |
3 files changed, 72 insertions, 44 deletions
diff --git a/scheme/aps/lang.sls b/scheme/aps/lang.sls index 1693259..8b23089 100644 --- a/scheme/aps/lang.sls +++ b/scheme/aps/lang.sls @@ -1,6 +1,6 @@ #!r6rs (library (aps lang) -(export :) +(export : identifier-append identifier-prepend get-name-from-define) (import (rnrs) (sweet-macros)) ;;COLON @@ -17,4 +17,35 @@ (syntax-violation ': "Not an identifier" #'let-form)) )) ;;END + + +;;GET-NAME-FROM-DEFINE +(define get-name-from-define + (syntax-match (define) + (sub (define (name . args) body body* ...) #'name + (identifier? #'name) + (syntax-violation 'get-name-from-define "not a name" #'name)) + (sub (define name value) #'name + (identifier? #'name) + (syntax-violation 'get-name-from-define "not a name" #'name)) + )) + +;;END + +;;IDENTIFIER-APPEND +;; take an identifier and return a new one with an appended suffix +(define (identifier-append id . strings) + (datum->syntax id (string->symbol + (apply string-append + (symbol->string (syntax->datum id)) strings)))) +;;END + +;;IDENTIFIER-PREPEND +;; take an identifier and return a new one with an prepended suffix +(define (identifier-prepend id . strings) + (define prefix (apply string-append strings)) + (datum->syntax id (string->symbol + (string-append + prefix (symbol->string (syntax->datum id)))))) +;;END ) diff --git a/scheme/aps/list-match.sls b/scheme/aps/list-match.sls index 8e87e5b..7e115f5 100644 --- a/scheme/aps/list-match.sls +++ b/scheme/aps/list-match.sls @@ -1,42 +1,38 @@ (library (aps list-match) -;;; Version: 0.2 -;;; Author: Michele Simionato -;;; Email: michele.simionato@gmail.com -;;; Date: 31-Jan-2009 -;;; Licence: BSD -(export list-match) +(export list-match _match) (import (rnrs) (sweet-macros)) -(def-syntax list-match-aux - (syntax-match (quote quasiquote) - (sub (_ obj pattern action) - #'(list-match-aux obj pattern action #t)) - (sub (_ obj () action guard) - #'(and (null? obj) guard action)) - (sub (_ obj underscore action guard) - #'(and guard action) - (and (identifier? #'underscore)(free-identifier=? #'underscore #'_))) - (sub (_ obj var action guard) - #'(let ((var obj)) (and guard action)) - (identifier? #'var)) - (sub (_ obj (quote datum) action guard) - #'(and (equal? obj (quote datum)) guard action)) - (sub (_ obj (quasiquote datum) action guard) - #'(and (equal? obj (quasiquote datum)) guard action)) - (sub (_ obj (kar . kdr) action guard) - #'(and (pair? obj) - (let ((kar-obj (car obj)) (kdr-obj (cdr obj))) - (list-match-aux kar-obj kar - (list-match-aux kdr-obj kdr action guard))))) - (sub (_ obj const action guard) - #'(and (equal? obj const) guard action)) - )) +;; see http://groups.google.com/group/comp.lang.scheme/msg/7701b9231835635f?hl=en + +(def-syntax (list-match lst (sub pattern template guard ...) ...) + #'(let ((obj lst)) + (cond + ((_match obj pattern (list template) guard ...) => car) ... + (else (error 'list-match "pattern failure" obj)))) + (for-all (lambda (s) (eq? (syntax->datum s) 'sub)) #'(sub ...))) -(def-syntax list-match - (syntax-match (when) - (sub (list-match lst (when pattern action guard ...) ...) - #'(let ((ls lst)) - (cond - ((list-match-aux ls pattern (list action) guard ...) => car) ... - (else (error 'list-match "pattern mismatch" ls))))))) +(def-syntax _match + (syntax-match (quote quasiquote) + (sub (_ obj pattern template) + #'(_match obj pattern template #t)) + (sub (_ obj () template guard) + #'(and (null? obj) guard template)) + (sub (_ obj underscore template guard) + #'(and guard template) + (and (identifier? #'underscore) (free-identifier=? #'underscore #'_))) + (sub (_ obj var template guard) + #'(let ((var obj)) (and guard template)) + (identifier? (syntax var))) + (sub (_ obj (quote datum) template guard) + #'(and (equal? obj (quote datum)) template)) + (sub (_ obj (quasiquote datum) template guard ) + #'(and (equal? obj (quasiquote datum)) guard template)) + (sub (_ obj (kar . kdr) template guard) + #'(let ((ob obj)) + (and (pair? ob) + (let ((kar-obj (car ob)) (kdr-obj (cdr ob))) + (_match kar-obj kar + (_match kdr-obj kdr template guard)))))) + (sub (_ obj const template guard) + #'(and (equal? obj const) guard template)))) ) diff --git a/scheme/sweet-macros/main.sls b/scheme/sweet-macros/main.sls index 6cee564..946daf0 100644 --- a/scheme/sweet-macros/main.sls +++ b/scheme/sweet-macros/main.sls @@ -59,12 +59,13 @@ (sub (def-syntax name transformer) #'(define-syntax name - (syntax-match (<source> <transformer>) - (sub (name <transformer>) #'(... (... transformer))) - (sub (name <source>) #''(... (... transformer))) - (sub x (transformer #'x)))) - (identifier? #'name) - (syntax-violation 'def-syntax "Invalid name" #'name)) + (lambda (x) + (syntax-case x (<source> <transformer>) + ((name <transformer>) #'(... (... transformer))) + ((name <source>) #''(... (... transformer))) + (x (transformer #'x))))) + (identifier? #'name)) + ;(syntax-violation 'def-syntax "Invalid name" #'name)) (sub (def-syntax name (extends parent) (literal ...) clause ...) #'(def-syntax name |