git.gag.com Git - fw/altos/blob - src/lisp/ao_lisp_const.lisp

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