git.gag.com Git - fw/altos/blob - src/scheme/ao_scheme_const.scheme

   1 ;
   2 ; Copyright © 2016 Keith Packard <keithp@keithp.com>
   3 ;
   4 ; This program is free software; you can redistribute it and/or modify
   5 ; it under the terms of the GNU General Public License as published by
   6 ; the Free Software Foundation, either version 2 of the License, or
   7 ; (at your option) any later version.
   8 ;
   9 ; This program is distributed in the hope that it will be useful, but
  10 ; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ; General Public License for more details.
  13 ;
  14 ; Lisp code placed in ROM
  15
  16 (def (quote _?_) (lambda (a b) (cond ((eq? a b) a) (else (exit 1)))))
  17
  18                                         ; return a list containing all of the arguments
  19 (def (quote list) (lambda l l))
  20
  21 (def (quote def!)
  22      (macro (name value)
  23             (list
  24              def
  25              (list quote name)
  26              value)
  27             )
  28      )
  29
  30 (begin
  31  (def! append
  32    (lambda args
  33           (def! append-list
  34             (lambda (a b)
  35               (cond ((null? a) b)
  36                     (else (cons (car a) (append-list (cdr a) b)))
  37                     )
  38               )
  39             )
  40
  41           (def! append-lists
  42             (lambda (lists)
  43               (cond ((null? lists) lists)
  44                     ((null? (cdr lists)) (car lists))
  45                     (else (append-list (car lists) (append-lists (cdr lists))))
  46                     )
  47               )
  48             )
  49           (append-lists args)
  50           )
  51    )
  52  'append)
  53
  54 (append '(a b c) '(d e f) '(g h i))
  55
  56                                         ; boolean operators
  57
  58 (begin
  59  (def! or
  60    (macro l
  61           (def! _or
  62             (lambda (l)
  63               (cond ((null? l) #f)
  64                     ((null? (cdr l))
  65                      (car l))
  66                     (else
  67                      (list
  68                       cond
  69                       (list
  70                        (car l))
  71                       (list
  72                        'else
  73                        (_or (cdr l))
  74                        )
  75                       )
  76                      )
  77                     )
  78               )
  79             )
  80           (_or l)))
  81  'or)
  82
  83                                         ; execute to resolve macros
  84
  85 (_?_ (or #f #t) #t)
  86
  87 (begin
  88  (def! and
  89    (macro l
  90           (def! _and
  91             (lambda (l)
  92               (cond ((null? l) #t)
  93                     ((null? (cdr l))
  94                      (car l))
  95                     (else
  96                      (list
  97                       cond
  98                       (list
  99                        (car l)
 100                        (_and (cdr l))
 101                        )
 102                       )
 103                      )
 104                     )
 105               )
 106             )
 107           (_and l)
 108           )
 109    )
 110  'and)
 111
 112                                         ; execute to resolve macros
 113
 114 (_?_ (and #t #f) #f)
 115
 116                                         ; recursive equality
 117
 118 (begin
 119   (def! equal?
 120     (lambda (a b)
 121       (cond ((eq? a b) #t)
 122             ((and (pair? a) (pair? b))
 123              (and (equal? (car a) (car b))
 124                   (equal? (cdr a) (cdr b)))
 125              )
 126             ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
 127              ((lambda (i l)
 128                 (while (and (< i l)
 129                             (equal? (vector-ref a i)
 130                                     (vector-ref b i)))
 131                        (set! i (+ i 1)))
 132                 (eq? i l)
 133                 )
 134               0
 135               (vector-length a)
 136               )
 137              )
 138             (else #f)
 139             )
 140       )
 141     )
 142   'equal?
 143   )
 144
 145 (_?_ (equal? '(a b c) '(a b c)) #t)
 146 (_?_ (equal? '(a b c) '(a b b)) #f)
 147 (_?_ (equal? #(1 2 3) #(1 2 3)) #t)
 148 (_?_ (equal? #(1 2 3) #(4 5 6)) #f)
 149
 150 (def (quote _??_) (lambda (a b) (cond ((equal? a b) a) (else (exit)))))
 151
 152 (begin
 153  (def! quasiquote
 154    (macro (x)
 155           (def! constant?
 156                                         ; A constant value is either a pair starting with quote,
 157                                         ; or anything which is neither a pair nor a symbol
 158
 159             (lambda (exp)
 160               (cond ((pair? exp)
 161                      (eq? (car exp) 'quote)
 162                      )
 163                     (else
 164                      (not (symbol? exp))
 165                      )
 166                     )
 167               )
 168             )
 169           (def! combine-skeletons
 170             (lambda (left right exp)
 171               (cond
 172                ((and (constant? left) (constant? right))
 173                 (cond ((and (eqv? (eval left) (car exp))
 174                             (eqv? (eval right) (cdr exp)))
 175                        (list 'quote exp)
 176                        )
 177                       (else
 178                        (list 'quote (cons (eval left) (eval right)))
 179                        )
 180                       )
 181                 )
 182                ((null? right)
 183                 (list 'list left)
 184                 )
 185                ((and (pair? right) (eq? (car right) 'list))
 186                 (cons 'list (cons left (cdr right)))
 187                 )
 188                (else
 189                 (list 'cons left right)
 190                 )
 191                )
 192               )
 193             )
 194
 195           (def! expand-quasiquote
 196             (lambda (exp nesting)
 197               (cond
 198
 199                                         ; non cons -- constants
 200                                         ; themselves, others are
 201                                         ; quoted
 202
 203                ((not (pair? exp))
 204                 (cond ((constant? exp)
 205                        exp
 206                        )
 207                       (else
 208                        (list 'quote exp)
 209                        )
 210                       )
 211                 )
 212
 213                                         ; check for an unquote exp and
 214                                         ; add the param unquoted
 215
 216                ((and (eq? (car exp) 'unquote) (= (length exp) 2))
 217                 (cond ((= nesting 0)
 218                        (car (cdr exp))
 219                        )
 220                       (else
 221                        (combine-skeletons ''unquote
 222                                           (expand-quasiquote (cdr exp) (- nesting 1))
 223                                           exp))
 224                       )
 225                 )
 226
 227                                         ; nested quasi-quote --
 228                                         ; construct the right
 229                                         ; expression
 230
 231                ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
 232                 (combine-skeletons ''quasiquote
 233                                    (expand-quasiquote (cdr exp) (+ nesting 1))
 234                                    exp))
 235
 236                                         ; check for an
 237                                         ; unquote-splicing member,
 238                                         ; compute the expansion of the
 239                                         ; value and append the rest of
 240                                         ; the quasiquote result to it
 241
 242                ((and (pair? (car exp))
 243                      (eq? (car (car exp)) 'unquote-splicing)
 244                      (= (length (car exp)) 2))
 245                 (cond ((= nesting 0)
 246                        (list 'append (car (cdr (car exp)))
 247                              (expand-quasiquote (cdr exp) nesting))
 248                        )
 249                       (else
 250                        (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
 251                                           (expand-quasiquote (cdr exp) nesting)
 252                                           exp))
 253                       )
 254                 )
 255
 256                                         ; for other lists, just glue
 257                                         ; the expansion of the first
 258                                         ; element to the expansion of
 259                                         ; the rest of the list
 260
 261                (else (combine-skeletons (expand-quasiquote (car exp) nesting)
 262                                         (expand-quasiquote (cdr exp) nesting)
 263                                         exp)
 264                      )
 265                )
 266               )
 267             )
 268           (def! result (expand-quasiquote x 0))
 269           result
 270           )
 271    )
 272  'quasiquote)
 273
 274                                         ;
 275                                         ; Define a variable without returning the value
 276                                         ; Useful when defining functions to avoid
 277                                         ; having lots of output generated.
 278                                         ;
 279                                         ; Also accepts the alternate
 280                                         ; form for defining lambdas of
 281                                         ; (define (name x y z) sexprs ...)
 282                                         ;
 283
 284 (begin
 285  (def! define
 286    (macro (first . rest)
 287                                         ; check for alternate lambda definition form
 288
 289           (cond ((pair? first)
 290                  (set! rest
 291                        (append
 292                         (list
 293                          'lambda
 294                          (cdr first))
 295                         rest))
 296                  (set! first (car first))
 297                  )
 298                 (else
 299                  (set! rest (car rest))
 300                  )
 301                 )
 302           (def! result `(,begin
 303                          (,def (,quote ,first) ,rest)
 304                          (,quote ,first))
 305             )
 306           result
 307           )
 308    )
 309  'define
 310  )
 311
 312                                         ; basic list accessors
 313
 314 (define (caar l) (car (car l)))
 315
 316 (_??_ (caar '((1 2 3) (4 5 6))) 1)
 317
 318 (define (cadr l) (car (cdr l)))
 319
 320 (_??_ (cadr '(1 2 3 4 5 6)) 2)
 321
 322 (define (cdar l) (cdr (car l)))
 323
 324 (_??_ (cdar '((1 2) (3 4))) '(2))
 325
 326 (define (cddr l) (cdr (cdr l)))
 327
 328 (_??_ (cddr '(1 2 3)) '(3))
 329
 330 (define (caddr l) (car (cdr (cdr l))))
 331
 332 (_??_ (caddr '(1 2 3 4)) 3)
 333
 334                                         ; (if <condition> <if-true>)
 335                                         ; (if <condition> <if-true> <if-false)
 336
 337 (define if
 338   (macro (test . args)
 339          (cond ((null? (cdr args))
 340                 `(cond (,test ,(car args)))
 341                 )
 342                (else
 343                 `(cond (,test ,(car args))
 344                        (else ,(cadr args)))
 345                 )
 346                )
 347          )
 348   )
 349
 350 (_??_ (if (> 3 2) 'yes) 'yes)
 351 (_??_ (if (> 3 2) 'yes 'no) 'yes)
 352 (_??_ (if (> 2 3) 'no 'yes) 'yes)
 353 (_??_ (if (> 2 3) 'no) #f)
 354
 355                                         ; simple math operators
 356
 357 (define zero? (macro (value) `(eq? ,value 0)))
 358
 359 (_??_ (zero? 1) #f)
 360 (_??_ (zero? 0) #t)
 361 (_??_ (zero? "hello") #f)
 362
 363 (define positive? (macro (value) `(> ,value 0)))
 364
 365 (_??_ (positive? 12) #t)
 366 (_??_ (positive? -12) #f)
 367
 368 (define negative? (macro (value) `(< ,value 0)))
 369
 370 (_??_ (negative? 12) #f)
 371 (_??_ (negative? -12) #t)
 372
 373 (define (abs x) (if (>= x 0) x (- x)))
 374
 375 (_??_ (abs 12) 12)
 376 (_??_ (abs -12) 12)
 377
 378 (define max (lambda (first . rest)
 379                    (while (not (null? rest))
 380                      (cond ((< first (car rest))
 381                             (set! first (car rest)))
 382                            )
 383                      (set! rest (cdr rest))
 384                      )
 385                    first)
 386   )
 387
 388 (_??_ (max 1 2 3) 3)
 389 (_??_ (max 3 2 1) 3)
 390
 391 (define min (lambda (first . rest)
 392                    (while (not (null? rest))
 393                      (cond ((> first (car rest))
 394                             (set! first (car rest)))
 395                            )
 396                      (set! rest (cdr rest))
 397                      )
 398                    first)
 399   )
 400
 401 (_??_ (min 1 2 3) 1)
 402 (_??_ (min 3 2 1) 1)
 403
 404 (define (even? x) (zero? (% x 2)))
 405
 406 (_??_ (even? 2) #t)
 407 (_??_ (even? -2) #t)
 408 (_??_ (even? 3) #f)
 409 (_??_ (even? -1) #f)
 410
 411 (define (odd? x) (not (even? x)))
 412
 413 (_??_ (odd? 2) #f)
 414 (_??_ (odd? -2) #f)
 415 (_??_ (odd? 3) #t)
 416 (_??_ (odd? -1) #t)
 417
 418 (_??_ (list-tail '(1 2 3 . 4) 3) 4)
 419
 420 (define (list-ref x k)
 421   (car (list-tail x k))
 422   )
 423
 424 (_??_ (list-ref '(1 2 3 4) 3) 4)
 425
 426 (define (list-set! x k v)
 427   (set-car! (list-tail x k) v)
 428   x)
 429
 430 (list-set! (list 1 2 3) 1 4)
 431
 432                                         ; define a set of local
 433                                         ; variables all at once and
 434                                         ; then evaluate a list of
 435                                         ; sexprs
 436                                         ;
 437                                         ; (let (var-defines) sexprs)
 438                                         ;
 439                                         ; where var-defines are either
 440                                         ;
 441                                         ; (name value)
 442                                         ;
 443                                         ; or
 444                                         ;
 445                                         ; (name)
 446                                         ;
 447                                         ; e.g.
 448                                         ;
 449                                         ; (let ((x 1) (y)) (set! y (+ x 1)) y)
 450
 451 (define let
 452   (macro (vars . exprs)
 453          (define (make-names vars)
 454            (cond ((not (null? vars))
 455                   (cons (car (car vars))
 456                         (make-names (cdr vars))))
 457                  (else ())
 458                  )
 459            )
 460
 461                                         ; the parameters to the lambda is a list
 462                                         ; of nils of the right length
 463
 464          (define (make-vals vars)
 465            (cond ((not (null? vars))
 466                   (cons (cond ((null? (cdr (car vars))) ())
 467                               (else
 468                                (car (cdr (car vars))))
 469                               )
 470                         (make-vals (cdr vars))))
 471                  (else ())
 472                  )
 473            )
 474                                         ; prepend the set operations
 475                                         ; to the expressions
 476
 477                                         ; build the lambda.
 478
 479          `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
 480          )
 481      )
 482
 483
 484 (_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
 485
 486                                         ; define a set of local
 487                                         ; variables one at a time and
 488                                         ; then evaluate a list of
 489                                         ; sexprs
 490                                         ;
 491                                         ; (let* (var-defines) sexprs)
 492                                         ;
 493                                         ; where var-defines are either
 494                                         ;
 495                                         ; (name value)
 496                                         ;
 497                                         ; or
 498                                         ;
 499                                         ; (name)
 500                                         ;
 501                                         ; e.g.
 502                                         ;
 503                                         ; (let* ((x 1) (y)) (set! y (+ x 1)) y)
 504
 505 (define letrec
 506   (macro (vars . exprs)
 507
 508                                         ;
 509                                         ; make the list of names in the let
 510                                         ;
 511
 512          (define (make-names vars)
 513            (cond ((not (null? vars))
 514                   (cons (car (car vars))
 515                         (make-names (cdr vars))))
 516                  (else ())
 517                  )
 518            )
 519
 520                                         ; the set of expressions is
 521                                         ; the list of set expressions
 522                                         ; pre-pended to the
 523                                         ; expressions to evaluate
 524
 525          (define (make-exprs vars exprs)
 526            (cond ((null? vars) exprs)
 527                  (else
 528                   (cons
 529                    (list set
 530                          (list quote
 531                                (car (car vars))
 532                                )
 533                          (cond ((null? (cdr (car vars))) ())
 534                                (else (cadr (car vars))))
 535                          )
 536                    (make-exprs (cdr vars) exprs)
 537                    )
 538                   )
 539                  )
 540            )
 541
 542                                         ; the parameters to the lambda is a list
 543                                         ; of nils of the right length
 544
 545          (define (make-nils vars)
 546            (cond ((null? vars) ())
 547                  (else (cons () (make-nils (cdr vars))))
 548                  )
 549            )
 550                                         ; build the lambda.
 551
 552          `((lambda ,(make-names vars) ,@(make-exprs vars exprs)) ,@(make-nils vars))
 553          )
 554      )
 555
 556 (_??_ (letrec ((x 1) (y x)) (+ x y)) 2)
 557
 558                                         ; letrec is sufficient for let*
 559
 560 (define let* letrec)
 561
 562 (define when (macro (test . l) `(cond (,test ,@l))))
 563
 564 (_??_ (when #t (+ 1 2)) 3)
 565 (_??_ (when #f (+ 1 2)) #f)
 566
 567 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
 568
 569 (_??_ (unless #f (+ 2 3)) 5)
 570 (_??_ (unless #t (+ 2 3)) #f)
 571
 572 (define (reverse list)
 573   (define (_r old new)
 574     (if (null? old)
 575         new
 576         (_r (cdr old) (cons (car old) new))
 577         )
 578     )
 579   (_r list ())
 580   )
 581
 582 (_??_ (reverse '(1 2 3)) '(3 2 1))
 583
 584 (define make-list
 585   (lambda (a . b)
 586     (define (_m a x)
 587       (if (zero? a)
 588           x
 589           (_m (- a 1) (cons b x))
 590           )
 591       )
 592     (if (null? b)
 593         (set! b #f)
 594         (set! b (car b))
 595         )
 596     (_m a '())
 597     )
 598   )
 599
 600 (_??_ (make-list 10 'a) '(a a a a a a a a a a))
 601
 602 (_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
 603
 604 (define member (lambda (obj list . test?)
 605                       (cond ((null? list)
 606                              #f
 607                              )
 608                             (else
 609                              (if (null? test?) (set! test? equal?) (set! test? (car test?)))
 610                              (if (test? obj (car list))
 611                                  list
 612                                (member obj (cdr list) test?))
 613                              )
 614                             )
 615                       )
 616   )
 617
 618 (_??_ (member '(2) '((1) (2) (3)))  '((2) (3)))
 619
 620 (_??_ (member '(4) '((1) (2) (3))) #f)
 621
 622 (define (memq obj list) (member obj list eq?))
 623
 624 (_??_ (memq 2 '(1 2 3)) '(2 3))
 625
 626 (_??_ (memq 4 '(1 2 3)) #f)
 627
 628 (_??_ (memq '(2) '((1) (2) (3))) #f)
 629
 630 (define (memv obj list) (member obj list eqv?))
 631
 632 (_??_ (memv 2 '(1 2 3)) '(2 3))
 633
 634 (_??_ (memv 4 '(1 2 3)) #f)
 635
 636 (_??_ (memv '(2) '((1) (2) (3))) #f)
 637
 638 (define (assoc obj list . compare)
 639   (if (null? compare)
 640       (set! compare equal?)
 641       (set! compare (car compare))
 642       )
 643   (if (null? list)
 644       #f
 645     (if (compare obj (caar list))
 646         (car list)
 647         (assoc obj (cdr list) compare)
 648         )
 649     )
 650   )
 651
 652 (define (assq obj list) (assoc obj list eq?))
 653 (define (assv obj list) (assoc obj list eqv?))
 654
 655 (_??_ (assq 'a '((a 1) (b 2) (c 3))) '(a 1))
 656 (_??_ (assv 'b '((a 1) (b 2) (c 3))) '(b 2))
 657 (_??_ (assoc '(c) '((a 1) (b 2) ((c) 3))) '((c) 3))
 658
 659 (define char? integer?)
 660
 661 (_??_ (char? #\q) #t)
 662 (_??_ (char? "h") #f)
 663
 664 (define (char-upper-case? c) (<= #\A c #\Z))
 665
 666 (_??_ (char-upper-case? #\a) #f)
 667 (_??_ (char-upper-case? #\B) #t)
 668 (_??_ (char-upper-case? #\0) #f)
 669 (_??_ (char-upper-case? #\space) #f)
 670
 671 (define (char-lower-case? c) (<= #\a c #\a))
 672
 673 (_??_ (char-lower-case? #\a) #t)
 674 (_??_ (char-lower-case? #\B) #f)
 675 (_??_ (char-lower-case? #\0) #f)
 676 (_??_ (char-lower-case? #\space) #f)
 677
 678 (define (char-alphabetic? c) (or (char-upper-case? c) (char-lower-case? c)))
 679
 680 (_??_ (char-alphabetic? #\a) #t)
 681 (_??_ (char-alphabetic? #\B) #t)
 682 (_??_ (char-alphabetic? #\0) #f)
 683 (_??_ (char-alphabetic? #\space) #f)
 684
 685 (define (char-numeric? c) (<= #\0 c #\9))
 686
 687 (_??_ (char-numeric? #\a) #f)
 688 (_??_ (char-numeric? #\B) #f)
 689 (_??_ (char-numeric? #\0) #t)
 690 (_??_ (char-numeric? #\space) #f)
 691
 692 (define (char-whitespace? c) (or (<= #\tab c #\return) (= #\space c)))
 693
 694 (_??_ (char-whitespace? #\a) #f)
 695 (_??_ (char-whitespace? #\B) #f)
 696 (_??_ (char-whitespace? #\0) #f)
 697 (_??_ (char-whitespace? #\space) #t)
 698
 699 (define char->integer (macro (v) v))
 700 (define integer->char char->integer)
 701
 702 (define (char-upcase c) (if (char-lower-case? c) (+ c (- #\A #\a)) c))
 703
 704 (_??_ (char-upcase #\a) #\A)
 705 (_??_ (char-upcase #\B) #\B)
 706 (_??_ (char-upcase #\0) #\0)
 707 (_??_ (char-upcase #\space) #\space)
 708
 709 (define (char-downcase c) (if (char-upper-case? c) (+ c (- #\a #\A)) c))
 710
 711 (_??_ (char-downcase #\a) #\a)
 712 (_??_ (char-downcase #\B) #\b)
 713 (_??_ (char-downcase #\0) #\0)
 714 (_??_ (char-downcase #\space) #\space)
 715
 716 (define (digit-value c)
 717   (if (char-numeric? c)
 718       (- c #\0)
 719       #f)
 720   )
 721
 722 (_??_ (digit-value #\1) 1)
 723 (_??_ (digit-value #\a) #f)
 724
 725 (define string (lambda chars (list->string chars)))
 726
 727 (_??_ (string #\a #\b #\c) "abc")
 728
 729 (_??_ (apply cons '(a b)) '(a . b))
 730
 731 (define map
 732   (lambda (proc . lists)
 733          (define (_a lists)
 734            (cond ((null? lists) ())
 735                  (else
 736                   (cons (caar lists) (_a (cdr lists)))
 737                   )
 738                  )
 739            )
 740          (define (_n lists)
 741            (cond ((null? lists) ())
 742                  (else
 743                   (cons (cdr (car lists)) (_n (cdr lists)))
 744                   )
 745                  )
 746            )
 747          (define (_m lists)
 748            (cond ((null? (car lists)) ())
 749                  (else
 750                   (cons (apply proc (_a lists)) (_m (_n lists)))
 751                   )
 752                  )
 753            )
 754          (_m lists)
 755          )
 756   )
 757
 758 (_??_ (map cadr '((a b) (d e) (g h))) '(b e h))
 759
 760 (define for-each
 761   (lambda (proc . lists)
 762     (define (_f lists)
 763       (cond ((null? (car lists)) #t)
 764             (else
 765              (apply proc (map car lists))
 766              (_f (map cdr lists))
 767              )
 768             )
 769       )
 770     (_f lists)
 771     )
 772   )
 773
 774 (_??_ (let ((a 0))
 775         (for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
 776         a
 777         )
 778       6)
 779
 780
 781 (define (newline) (write-char #\newline))
 782
 783 (newline)
 784
 785 (_??_ (call-with-current-continuation
 786        (lambda (exit)
 787          (for-each (lambda (x)
 788                      (if (negative? x)
 789                          (exit x)))
 790                    '(54 0 37 -3 245 19))
 791          #t))
 792       -3)
 793
 794
 795                                         ; `q -> (quote q)
 796                                         ; `(q) -> (append (quote (q)))
 797                                         ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
 798                                         ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
 799
 800
 801
 802 (_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
 803
 804
 805 (define repeat
 806   (macro (count . rest)
 807          (define counter '__count__)
 808          (cond ((pair? count)
 809                 (set! counter (car count))
 810                 (set! count (cadr count))
 811                 )
 812                )
 813          `(let ((,counter 0)
 814                 (__max__ ,count)
 815                 )
 816             (while (< ,counter __max__)
 817               ,@rest
 818               (set! ,counter (+ ,counter 1))
 819               )
 820             )
 821          )
 822   )
 823
 824 (repeat 2 (write 'hello))
 825 (repeat (x 3) (write (list 'goodbye x)))
 826
 827 (define case
 828   (macro (test . l)
 829                                         ; construct the body of the
 830                                         ; case, dealing with the
 831                                         ; lambda version ( => lambda)
 832
 833          (define (_unarrow l)
 834            (cond ((null? l) l)
 835                  ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
 836                  (else l))
 837            )
 838
 839                                         ; Build the case elements, which is
 840                                         ; simply a list of cond clauses
 841
 842          (define (_case l)
 843
 844            (cond ((null? l) ())
 845
 846                                         ; else case
 847
 848                  ((eq? (caar l) 'else)
 849                   `((else ,@(_unarrow (cdr (car l))))))
 850
 851                                         ; regular case
 852
 853                  (else
 854                   (cons
 855                    `((eqv? ,(caar l) __key__)
 856                      ,@(_unarrow (cdr (car l))))
 857                    (_case (cdr l)))
 858                   )
 859                  )
 860            )
 861
 862                                         ; now construct the overall
 863                                         ; expression, using a lambda
 864                                         ; to hold the computed value
 865                                         ; of the test expression
 866
 867          `((lambda (__key__)
 868              (cond ,@(_case l))) ,test)
 869          )
 870   )
 871
 872 (_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one")
 873 (_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two")
 874 (_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three")
 875 (_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else")
 876 (_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve")
 877
 878 (define do
 879   (macro (vars test . cmds)
 880     (define (_step v)
 881       (if (null? v)
 882           '()
 883           (if (null? (cddr (car v)))
 884               (_step (cdr v))
 885               (cons `(set! ,(caar v) ,(caddr (car v)))
 886                     (_step (cdr v))
 887                     )
 888               )
 889           )
 890       )
 891     `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
 892        (while (not ,(car test))
 893               ,@cmds
 894               ,@(_step vars)
 895               )
 896        ,@(cdr test)
 897        )
 898     )
 899   )
 900
 901 (define (eof-object? a)
 902   (equal? a 'eof)
 903   )
 904
 905 (_??_ (do ((x 1 (+ x 1))
 906            (y 0)
 907            )
 908           ((= x 10) y)
 909         (set! y (+ y x))
 910         )
 911       45)
 912
 913 (_??_ (do ((vec (make-vector 5))
 914            (i 0 (+ i 1)))
 915           ((= i 5) vec)
 916         (vector-set! vec i i)) #(0 1 2 3 4))