Changeset 9711 in project
 Timestamp:
 03/15/08 07:47:53 (13 years ago)
 Location:
 release/3/syntacticclosures
 Files:

 2 edited
Legend:
 Unmodified
 Added
 Removed

release/3/syntacticclosures/syntacticclosures.scm
r5660 r9711 1420 1420 (letrec 1421 1421 ((loop 1422 (lambda (pattern expression) 1423 (cond ((identifier? pattern) 1424 (if (memq pattern keywords) 1425 (let ((temp (rename 'temp))) 1426 `((,(rename 'lambda) 1427 (,temp) 1428 (,(rename 'if) 1429 (,(rename 'identifier?) ,temp) 1430 (,rcompare ,temp 1431 (,rrename ,(syntaxquote pattern))) 1432 #f)) 1433 ,expression)) 1434 `#t)) 1435 ((and (zeroormore? pattern rename compare) 1436 (null? (cddr pattern))) 1437 (dolist (car pattern) expression)) 1438 ((and (atleastone? pattern rename compare) 1439 (null? (cddr pattern))) 1440 `(,(rename 'if) (,(rename 'null?) ,expression) 1441 #f 1442 ,(dolist (car pattern) expression))) 1443 ((pair? pattern) 1444 (let ((generatepair 1445 (lambda (expression) 1446 (conjunction 1447 `(,(rename 'pair?) ,expression) 1448 (conjunction 1449 (loop (car pattern) 1450 `(,(rename 'car) ,expression)) 1451 (loop (cdr pattern) 1452 `(,(rename 'cdr) ,expression))))))) 1453 (if (identifier? expression) 1454 (generatepair expression) 1455 (let ((temp (rename 'temp))) 1456 `((,(rename 'lambda) (,temp) ,(generatepair temp)) 1457 ,expression))))) 1458 ((null? pattern) 1459 `(,(rename 'null?) ,expression)) 1460 ((vector? pattern) 1461 (letrec 1462 ((len (vectorlength pattern)) 1463 (generatevector 1464 (lambda (len res) 1465 (if (negative? len) 1466 res 1467 (generatevector 1468 ( len 1) 1469 (conjunction (loop (vectorref pattern len) 1470 `(,(rename 'vectorref) 1471 ,expression 1472 ,len)) 1473 res)))))) 1474 (if (zero? len) 1475 `(,(rename 'equal?) ,expression '#()) 1476 (conjunction 1477 `(,(rename 'vector?) ,expression) 1478 (if (compare (vectorref pattern ( len 1)) (rename '...)) 1422 (lambda (pattern expression) 1423 (cond ((identifier? pattern) 1424 (if (memq pattern keywords) 1425 (let ((temp (rename 'temp))) 1426 `((,(rename 'lambda) 1427 (,temp) 1428 (,(rename 'if) 1429 (,(rename 'identifier?) ,temp) 1430 (,rcompare ,temp 1431 (,rrename ,(syntaxquote pattern))) 1432 #f)) 1433 ,expression)) 1434 `#t)) 1435 ((and (zeroormore? pattern rename compare) 1436 (null? (cddr pattern))) 1437 (dolist (car pattern) expression)) 1438 ((and (atleastone? pattern rename compare) 1439 (null? (cddr pattern))) 1440 `(,(rename 'if) (,(rename 'null?) ,expression) 1441 #f 1442 ,(dolist (car pattern) expression))) 1443 ((pair? pattern) 1444 (let ((generatepair 1445 (lambda (expression) 1446 (conjunction 1447 `(,(rename 'pair?) ,expression) 1448 (conjunction 1449 (loop (car pattern) 1450 `(,(rename 'car) ,expression)) 1451 (loop (cdr pattern) 1452 `(,(rename 'cdr) ,expression))))))) 1453 (if (identifier? expression) 1454 (generatepair expression) 1455 (let ((temp (rename 'temp))) 1456 `((,(rename 'lambda) (,temp) ,(generatepair temp)) 1457 ,expression))))) 1458 ((null? pattern) 1459 `(,(rename 'null?) ,expression)) 1460 ;; just revert to this if you have problems with 1461 ;; the optimized code below 1462 ;;((vector? pattern) 1463 ;; (conjunction `(,(rename 'vector?) ,expression) 1464 ;; (loop (vector>list pattern) `(,(rename 'vector>list) ,expression)))) 1465 ((vector? pattern) 1466 (letrec 1467 ((len (vectorlength pattern)) 1468 (generatevector 1469 (lambda (i res) 1470 (if (negative? i) 1471 res 1472 (generatevector 1473 ( i 1) 1474 (conjunction (loop (vectorref pattern i) 1475 `(,(rename 'vectorref) 1476 ,expression 1477 ,i)) 1478 res)))))) 1479 (cond 1480 ((zero? len) 1481 `(,(rename 'equal?) ,expression '#())) 1482 ((and (= len 2) 1483 (compare (vectorref pattern 1) 1484 (rename '...)) 1485 (identifier? (vectorref pattern 0))) 1486 ;; shortcut for the #(a ...) pattern 1487 `(,(rename 'vector?) ,expression)) 1488 (else 1479 1489 (conjunction 1480 `(,(rename '>=) 1481 (,(rename 'vectorlength) ,expression) 1482 ,( len 2)) 1483 (conjunction 1484 (generatevector ( len 2) #t) 1485 (dovec (vectorref pattern ( len 1)) 1486 expression 1487 ( len 1)))) 1488 (conjunction 1489 `(,(rename '>=) 1490 (,(rename 'vectorlength) ,expression) 1491 ,( len 2)) 1492 (generatevector ( len 1) #t))))))) 1493 (else 1494 `(,(rename 'equal?) ,expression 1495 (,(rename 'quote) ,pattern)))))) 1490 `(,(rename 'vector?) ,expression) 1491 (if (compare (vectorref pattern ( len 1)) 1492 (rename '...)) 1493 (conjunction 1494 `(,(rename '>=) 1495 (,(rename 'vectorlength) ,expression) 1496 ,( len 2)) 1497 (conjunction 1498 (generatevector ( len 2) #t) 1499 (dovec (vectorref pattern ( len 2)) 1500 expression 1501 ( len 2)))) 1502 (conjunction 1503 `(,(rename '=) 1504 (,(rename 'vectorlength) ,expression) 1505 ,len) 1506 (generatevector ( len 1) #t)))))))) 1507 (else 1508 `(,(rename 'equal?) ,expression 1509 (,(rename 'quote) ,pattern)))))) 1496 1510 (dolist 1497 1511 (lambda (pattern expression) … … 1579 1593 (loop (car template) ellipses) 1580 1594 (loop (cdr template) ellipses))) 1595 ((vector? template) 1596 `(,(rename 'list>vector) ,(loop (vector>list template) ellipses))) 1581 1597 (else 1582 1598 `(,(rename 'quote) ,template))))) 
release/3/syntacticclosures/syntacticclosures.setup
r6639 r9711 4 4 'syntacticclosures 5 5 '("syntacticclosures.so" "syntacticclosures.html" "syntacticclosureschickenmacros.scm") 6 '((version 0.98 7)6 '((version 0.988) 7 7 (documentation "syntacticclosures.html") 8 8 (syntax) ) )
Note: See TracChangeset
for help on using the changeset viewer.