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