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

   1 ;
   2 ; Copyright © 2018 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 ; Advanced syntax, including vectors and floats
  15
  16 (begin
  17   (def! equal?
  18     (lambda (a b)
  19       (cond ((eq? a b) #t)
  20             ((and (pair? a) (pair? b))
  21              (and (equal? (car a) (car b))
  22                   (equal? (cdr a) (cdr b)))
  23              )
  24             ((and (vector? a) (vector? b) (= (vector-length a) (vector-length b)))
  25              ((lambda (i l)
  26                 (while (and (< i l)
  27                             (equal? (vector-ref a i)
  28                                     (vector-ref b i)))
  29                        (set! i (+ i 1)))
  30                 (eq? i l)
  31                 )
  32               0
  33               (vector-length a)
  34               )
  35              )
  36             (else #f)
  37             )
  38       )
  39     )
  40   'equal?
  41   )
  42
  43 (_?_ (equal? '(a b c) '(a b c)) #t)
  44 (_?_ (equal? '(a b c) '(a b b)) #f)
  45 (_?_ (equal? #(1 2 3) #(1 2 3)) #t)
  46 (_?_ (equal? #(1 2 3) #(4 5 6)) #f)
  47
  48 (define (_??_ a b)
  49   (cond ((equal? a b)
  50          a
  51          )
  52         (else
  53          (exit 1)
  54          )
  55         )
  56   )
  57
  58 (define quasiquote
  59   (macro (x)
  60     (define (constant? exp)
  61                                         ; A constant value is either a pair starting with quote,
  62                                         ; or anything which is neither a pair nor a symbol
  63
  64       (cond ((pair? exp)
  65              (eq? (car exp) 'quote)
  66              )
  67             (else
  68              (not (symbol? exp))
  69              )
  70             )
  71       )
  72
  73     (define (combine-skeletons left right exp)
  74       (cond
  75        ((and (constant? left) (constant? right))
  76         (cond ((and (eqv? (eval left) (car exp))
  77                     (eqv? (eval right) (cdr exp)))
  78                (list 'quote exp)
  79                )
  80               (else
  81                (list 'quote (cons (eval left) (eval right)))
  82                )
  83               )
  84         )
  85        ((null? right)
  86         (list 'list left)
  87         )
  88        ((and (pair? right) (eq? (car right) 'list))
  89         (cons 'list (cons left (cdr right)))
  90         )
  91        (else
  92         (list 'cons left right)
  93         )
  94        )
  95       )
  96
  97     (define (expand-quasiquote exp nesting)
  98       (cond
  99
 100                                         ; non cons -- constants
 101                                         ; themselves, others are
 102                                         ; quoted
 103
 104        ((not (pair? exp))
 105         (cond ((constant? exp)
 106                exp
 107                )
 108               (else
 109                (list 'quote exp)
 110                )
 111               )
 112         )
 113
 114                                         ; check for an unquote exp and
 115                                         ; add the param unquoted
 116
 117        ((and (eq? (car exp) 'unquote) (= (length exp) 2))
 118         (cond ((= nesting 0)
 119                (car (cdr exp))
 120                )
 121               (else
 122                (combine-skeletons ''unquote
 123                                   (expand-quasiquote (cdr exp) (- nesting 1))
 124                                   exp))
 125               )
 126         )
 127
 128                                         ; nested quasi-quote --
 129                                         ; construct the right
 130                                         ; expression
 131
 132        ((and (eq? (car exp) 'quasiquote) (= (length exp) 2))
 133         (combine-skeletons ''quasiquote
 134                            (expand-quasiquote (cdr exp) (+ nesting 1))
 135                            exp))
 136
 137                                         ; check for an
 138                                         ; unquote-splicing member,
 139                                         ; compute the expansion of the
 140                                         ; value and append the rest of
 141                                         ; the quasiquote result to it
 142
 143        ((and (pair? (car exp))
 144              (eq? (car (car exp)) 'unquote-splicing)
 145              (= (length (car exp)) 2))
 146         (cond ((= nesting 0)
 147                (list 'append (car (cdr (car exp)))
 148                      (expand-quasiquote (cdr exp) nesting))
 149                )
 150               (else
 151                (combine-skeletons (expand-quasiquote (car exp) (- nesting 1))
 152                                   (expand-quasiquote (cdr exp) nesting)
 153                                   exp))
 154               )
 155         )
 156
 157                                         ; for other lists, just glue
 158                                         ; the expansion of the first
 159                                         ; element to the expansion of
 160                                         ; the rest of the list
 161
 162        (else (combine-skeletons (expand-quasiquote (car exp) nesting)
 163                                 (expand-quasiquote (cdr exp) nesting)
 164                                 exp)
 165              )
 166        )
 167       )
 168     (expand-quasiquote x 0)
 169     )
 170   )
 171
 172                                         ; `q -> (quote q)
 173                                         ; `(q) -> (append (quote (q)))
 174                                         ; `(a ,(+ 1 2)) -> (append (quote (a)) (list (+ 1 2)))
 175                                         ; `(a ,@(list 1 2 3) -> (append (quote (a)) (list 1 2 3))
 176
 177
 178 (_??_ `(hello ,(+ 1 2) ,@(list 1 2 3) `foo) '(hello 3 1 2 3 (quasiquote foo)))
 179
 180                                         ; define a set of local
 181                                         ; variables all at once and
 182                                         ; then evaluate a list of
 183                                         ; sexprs
 184                                         ;
 185                                         ; (let (var-defines) sexprs)
 186                                         ;
 187                                         ; where var-defines are either
 188                                         ;
 189                                         ; (name value)
 190                                         ;
 191                                         ; or
 192                                         ;
 193                                         ; (name)
 194                                         ;
 195                                         ; e.g.
 196                                         ;
 197                                         ; (let ((x 1) (y)) (set! y (+ x 1)) y)
 198
 199 (define let
 200   (macro (vars . exprs)
 201          (define (make-names vars)
 202            (cond ((not (null? vars))
 203                   (cons (car (car vars))
 204                         (make-names (cdr vars))))
 205                  (else ())
 206                  )
 207            )
 208
 209                                         ; the parameters to the lambda is a list
 210                                         ; of nils of the right length
 211
 212          (define (make-vals vars)
 213            (cond ((not (null? vars))
 214                   (cons (cond ((null? (cdr (car vars))) ())
 215                               (else
 216                                (car (cdr (car vars))))
 217                               )
 218                         (make-vals (cdr vars))))
 219                  (else ())
 220                  )
 221            )
 222                                         ; prepend the set operations
 223                                         ; to the expressions
 224
 225                                         ; build the lambda.
 226
 227          `((lambda ,(make-names vars) ,@exprs) ,@(make-vals vars))
 228          )
 229      )
 230
 231
 232 (_??_ (let ((x 1) (y)) (set! y 2) (+ x y)) 3)
 233
 234 (define when (macro (test . l) `(cond (,test ,@l))))
 235
 236 (_??_ (when #t (+ 1 2)) 3)
 237 (_??_ (when #f (+ 1 2)) #f)
 238
 239 (define unless (macro (test . l) `(cond ((not ,test) ,@l))))
 240
 241 (_??_ (unless #f (+ 2 3)) 5)
 242 (_??_ (unless #t (+ 2 3)) #f)
 243
 244 (define (cdar l) (cdr (car l)))
 245
 246 (_??_ (cdar '((1 2) (3 4))) '(2))
 247
 248 (define (cddr l) (cdr (cdr l)))
 249
 250 (_??_ (cddr '(1 2 3)) '(3))
 251
 252 (define (caddr l) (car (cdr (cdr l))))
 253
 254 (_??_ (caddr '(1 2 3 4)) 3)
 255
 256 (define (reverse list)
 257   (define (_r old new)
 258     (if (null? old)
 259         new
 260         (_r (cdr old) (cons (car old) new))
 261         )
 262     )
 263   (_r list ())
 264   )
 265
 266 (_??_ (reverse '(1 2 3)) '(3 2 1))
 267
 268 (define make-list
 269   (lambda (a . b)
 270     (define (_m a x)
 271       (if (zero? a)
 272           x
 273           (_m (- a 1) (cons b x))
 274           )
 275       )
 276     (if (null? b)
 277         (set! b #f)
 278         (set! b (car b))
 279         )
 280     (_m a '())
 281     )
 282   )
 283
 284 (_??_ (make-list 10 'a) '(a a a a a a a a a a))
 285
 286 (_??_ (make-list 10) '(#f #f #f #f #f #f #f #f #f #f))
 287
 288 (define for-each
 289   (lambda (proc . lists)
 290     (define (_f lists)
 291       (cond ((null? (car lists)) #t)
 292             (else
 293              (apply proc (map car lists))
 294              (_f (map cdr lists))
 295              )
 296             )
 297       )
 298     (_f lists)
 299     )
 300   )
 301
 302 (_??_ (let ((a 0))
 303         (for-each (lambda (b) (set! a (+ a b))) '(1 2 3))
 304         a
 305         )
 306       6)
 307
 308 (_??_ (call-with-current-continuation
 309        (lambda (exit)
 310          (for-each (lambda (x)
 311                      (if (negative? x)
 312                          (exit x)))
 313                    '(54 0 37 -3 245 19))
 314          #t))
 315       -3)
 316
 317 (define case
 318   (macro (test . l)
 319                                         ; construct the body of the
 320                                         ; case, dealing with the
 321                                         ; lambda version ( => lambda)
 322
 323          (define (_unarrow l)
 324            (cond ((null? l) l)
 325                  ((eq? (car l) '=>) `(( ,(cadr l) __key__)))
 326                  (else l))
 327            )
 328
 329                                         ; Build the case elements, which is
 330                                         ; simply a list of cond clauses
 331
 332          (define (_case l)
 333
 334            (cond ((null? l) ())
 335
 336                                         ; else case
 337
 338                  ((eq? (caar l) 'else)
 339                   `((else ,@(_unarrow (cdr (car l))))))
 340
 341                                         ; regular case
 342
 343                  (else
 344                   (cons
 345                    `((eqv? ,(caar l) __key__)
 346                      ,@(_unarrow (cdr (car l))))
 347                    (_case (cdr l)))
 348                   )
 349                  )
 350            )
 351
 352                                         ; now construct the overall
 353                                         ; expression, using a lambda
 354                                         ; to hold the computed value
 355                                         ; of the test expression
 356
 357          `((lambda (__key__)
 358              (cond ,@(_case l))) ,test)
 359          )
 360   )
 361
 362 (_??_ (case 1 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "one")
 363 (_??_ (case 2 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "two")
 364 (_??_ (case 3 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)) "three")) (12 "twelve") (else "else")) "three")
 365 (_??_ (case 4 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "else")
 366 (_??_ (case 12 (1 "one") (2 "two") (3 => (lambda (x) (write (list "the value is" x)))) (12 "twelve") (else "else")) "twelve")
 367
 368 (define do
 369   (macro (vars test . cmds)
 370     (define (_step v)
 371       (if (null? v)
 372           '()
 373           (if (null? (cddr (car v)))
 374               (_step (cdr v))
 375               (cons `(set! ,(caar v) ,(caddr (car v)))
 376                     (_step (cdr v))
 377                     )
 378               )
 379           )
 380       )
 381     `(let ,(map (lambda (v) (list (car v) (cadr v))) vars)
 382        (while (not ,(car test))
 383               ,@cmds
 384               ,@(_step vars)
 385               )
 386        ,@(cdr test)
 387        )
 388     )
 389   )
 390
 391 (_??_ (do ((x 1 (+ x 1))
 392            (y 0)
 393            )
 394           ((= x 10) y)
 395         (set! y (+ y x))
 396         )
 397       45)
 398
 399 (_??_ (do ((vec (make-vector 5))
 400            (i 0 (+ i 1)))
 401           ((= i 5) vec)
 402         (vector-set! vec i i)) #(0 1 2 3 4))