scaffold/boot/60-let-syntax-expanded.scm

   1 ;;; GNU Mes --- Maxwell Equations of Software
   2 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Mes.
   5 ;;;
   6 ;;; GNU Mes is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Mes is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;; boot-00.scm
  20 (define mes %version)
  21
  22 (define (defined? x)
  23   (module-variable (current-module) x))
  24
  25 (define (cond-expand-expander clauses)
  26   (if (defined? (car (car clauses)))
  27       (cdr (car clauses))
  28       (cond-expand-expander (cdr clauses))))
  29
  30 (define-macro (cond-expand . clauses)
  31   (cons 'begin (cond-expand-expander clauses)))
  32 ;; end boot-00.scm
  33
  34 ;; boot-01.scm
  35 (define <cell:character> 0)
  36 (define <cell:pair> 7)
  37 (define <cell:string> 10)
  38
  39 (define (not x) (if x #f #t))
  40
  41 (define (display x . rest)
  42   (if (null? rest) (core:display x)
  43       (core:display-port x (car rest))))
  44
  45 (define (write x . rest)
  46   (if (null? rest) (core:write x)
  47       (core:write-port x (car rest))))
  48
  49 (define (integer->char x)
  50   (core:make-cell <cell:character> 0 x))
  51
  52 (define (newline . rest)
  53   (core:display (list->string (list (integer->char 10)))))
  54
  55 (define (string->list s)
  56   (core:car s))
  57
  58 (define (cadr x) (car (cdr x)))
  59
  60 (define (map1 f lst)
  61   (if (null? lst) (list)
  62       (cons (f (car lst)) (map1 f (cdr lst)))))
  63
  64 (define map map1)
  65
  66 (define (cons* . rest)
  67   (if (null? (cdr rest)) (car rest)
  68       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
  69
  70 (define (apply f h . t)
  71   (if (null? t) (core:apply f h (current-module))
  72       (apply f (apply cons* (cons h t)))))
  73
  74 (define (append . rest)
  75   (if (null? rest) '()
  76       (if (null? (cdr rest)) (car rest)
  77           (append2 (car rest) (apply append (cdr rest))))))
  78 ;; end boot-01.scm
  79
  80 ;;((lambda (*program*) *program*) (primitive-load 0))
  81 ;;(primitive-load 0)
  82
  83
  84 ;;; GNU Mes --- Maxwell Equations of Software
  85 ;;; Copyright © 2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
  86 ;;;
  87 ;;; This file is part of GNU Mes.
  88 ;;;
  89 ;;; GNU Mes is free software; you can redistribute it and/or modify it
  90 ;;; under the terms of the GNU General Public License as published by
  91 ;;; the Free Software Foundation; either version 3 of the License, or (at
  92 ;;; your option) any later version.
  93 ;;;
  94 ;;; GNU Mes is distributed in the hope that it will be useful, but
  95 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  96 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  97 ;;; GNU General Public License for more details.
  98 ;;;
  99 ;;; You should have received a copy of the GNU General Public License
 100 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
 101
 102 (define-macro (and . x)
 103   (if (null? x) #t
 104       (if (null? (cdr x)) (car x)
 105           (list (quote if) (car x) (cons (quote and) (cdr x))
 106                 #f))))
 107
 108 (define-macro (or . x)
 109   (if (null? x) #f
 110       (if (null? (cdr x)) (car x)
 111           (list (list (quote lambda) (list (quote r))
 112                       (list (quote if) (quote r) (quote r)
 113                             (cons (quote or) (cdr x))))
 114                 (car x)))))
 115
 116 (define else #t)
 117 (define-macro (cond . clauses)
 118   (list 'if (pair? clauses)
 119         (list (cons
 120                'lambda
 121                (cons
 122                 '(test)
 123                 (list (list 'if 'test
 124                             (if (pair? (cdr (car clauses)))
 125                                 (if (eq? (car (cdr (car clauses))) '=>)
 126                                     (append2 (cdr (cdr (car clauses))) '(test))
 127                                     (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
 128                                 (list (cons 'lambda (cons '() (cons 'test (cdr (car clauses)))))))
 129                             (if (pair? (cdr clauses))
 130                                 (cons 'cond (cdr clauses)))))))
 131               (car (car clauses)))))
 132
 133 (define (memq x lst)
 134   (if (null? lst) #f
 135       (if (eq? x (car lst)) lst
 136           (memq x (cdr lst)))))
 137
 138   (define <cell:symbol> 11)
 139   (define (symbol? x)
 140     (eq? (core:type x) <cell:symbol>))
 141
 142   (define <cell:string> 10)
 143   (define (string? x)
 144     (eq? (core:type x) <cell:string>))
 145
 146   (define <cell:vector> 14)
 147   (define (vector? x)
 148     (eq? (core:type x) <cell:vector>))
 149
 150 (define (cons* . rest)
 151   (if (null? (cdr rest)) (car rest)
 152       (cons (car rest) (core:apply cons* (cdr rest) (current-module)))))
 153
 154 (define (apply f h . t)
 155   (if (null? t) (core:apply f h (current-module))
 156       (apply f (apply cons* (cons h t)))))
 157
 158 (define (append . rest)
 159   (if (null? rest) '()
 160       (if (null? (cdr rest)) (car rest)
 161           (append2 (car rest) (apply append (cdr rest))))))
 162
 163 (define-macro (quasiquote x)
 164   (define (loop x)
 165     (if (vector? x) (list 'list->vector (loop (vector->list x)))
 166         (if (not (pair? x)) (cons 'quote (cons x '()))
 167             (if (eq? (car x) 'quasiquote) (loop (loop (cadr x)))
 168                 (if (eq? (car x) 'unquote) (cadr x)
 169                     (if (and (pair? (car x)) (eq? (caar x) 'unquote-splicing))
 170                         ((lambda (d)
 171                            (list 'append (car (cdr (car x))) d))
 172                          (loop (cdr x)))
 173                         ((lambda (a d)
 174                            (if (pair? d)
 175                                (if (eq? (car d) 'quote)
 176                                    (if (and (pair? a) (eq? (car a) 'quote))
 177                                        (list 'quote (cons (cadr a) (cadr d)))
 178                                        (if (null? (cadr d))
 179                                            (list 'list a)
 180                                            (list 'cons* a d)))
 181                                    (if (memq (car d) '(list cons*))
 182                                        (cons (car d) (cons a (cdr d)))
 183                                        (list 'cons* a d)))
 184                                (list 'cons* a d)))
 185                          (loop (car x))
 186                          (loop (cdr x)))))))))
 187   (loop x))
 188
 189 (define (caar x) (car (car x)))
 190 (define (cadr x) (car (cdr x)))
 191 (define (cdar x) (cdr (car x)))
 192 (define (cddr x) (cdr (cdr x)))
 193
 194 (define-macro (simple-let bindings . rest)
 195   (cons (cons 'lambda (cons (map car bindings) rest))
 196         (map cadr bindings)))
 197
 198 (define-macro (xsimple-let bindings rest)
 199   `(,`(lambda ,(map car bindings) ,@rest)
 200     ,@(map cadr bindings)))
 201
 202 (define-macro (xnamed-let name bindings rest)
 203   `(simple-let ((,name *unspecified*))
 204      (set! ,name (lambda ,(map car bindings) ,@rest))
 205      (,name ,@(map cadr bindings))))
 206
 207 (define-macro (let bindings-or-name . rest)
 208   (if (symbol? bindings-or-name) ;; IF
 209       `(xnamed-let ,bindings-or-name ,(car rest) ,(cdr rest))
 210       `(xsimple-let ,bindings-or-name ,rest)))
 211
 212 (define (expand-let* bindings body)
 213   (if (null? bindings)
 214       `((lambda () ,@body))
 215       `((lambda (,(caar bindings))
 216           ,(expand-let* (cdr bindings) body))
 217         ,@(cdar bindings))))
 218
 219 (define-macro (let* bindings . body)
 220   (expand-let* bindings body))
 221
 222 (define (equal2? a b)
 223   (if (and (null? a) (null? b)) #t
 224       (if (and (pair? a) (pair? b))
 225           (and (equal2? (car a) (car b))
 226                (equal2? (cdr a) (cdr b)))
 227           (if (and (string? a) (string? b))
 228               (string=? a b)
 229               (if (and (vector? a) (vector? b))
 230                   (equal2? (vector->list a) (vector->list b))
 231                   (eq? a b))))))
 232
 233 (define equal? equal2?)
 234 (define (member x lst)
 235   (if (null? lst) #f
 236       (if (equal2? x (car lst)) lst
 237           (member x (cdr lst)))))
 238
 239 (define (<= . rest)
 240   (or (apply < rest)
 241       (apply = rest)))
 242
 243 (define (>= . rest)
 244   (or (apply > rest)
 245       (apply = rest)))
 246
 247 (define (list? x)
 248   (or (null? x)
 249       (and (pair? x) (list? (cdr x)))))
 250
 251 (cond-expand
 252  (guile)
 253  (mes
 254   (define (boolean? x)
 255     (or (eq? x #f) (eq? x #t)))
 256   (define (char? x)
 257     (and (eq? (core:type x) <cell:char>)
 258          (> (char->integer x) -1)))))
 259
 260 ;; -*-scheme-*-
 261
 262 ;;; GNU Mes --- Maxwell Equations of Software
 263 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
 264 ;;; Copyright © 2016 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 265 ;;;
 266 ;;; This file is part of GNU Mes.
 267 ;;;
 268 ;;; GNU Mes is free software; you can redistribute it and/or modify it
 269 ;;; under the terms of the GNU General Public License as published by
 270 ;;; the Free Software Foundation; either version 3 of the License, or (at
 271 ;;; your option) any later version.
 272 ;;;
 273 ;;; GNU Mes is distributed in the hope that it will be useful, but
 274 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
 275 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 276 ;;; GNU General Public License for more details.
 277 ;;;
 278 ;;; You should have received a copy of the GNU General Public License
 279 ;;; along with GNU Mes.  If not, see <http://www.gnu.org/licenses/>.
 280
 281 ;;; Commentary:
 282
 283 ;;; syntax.mes is loaded after scm.mes.  It provides the R5RS hygienic
 284 ;;; macros define-syntax, syntax-rules and define-syntax-rule.
 285 ;;; syntax-rules is adapted from scheme48-1.1/scheme/alt/syntax.scm
 286
 287 ;;; Code:
 288
 289 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
 290
 291 ;;; scheme48-1.1/COPYING
 292
 293 ;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
 294 ;; All rights reserved.
 295
 296 ;; Redistribution and use in source and binary forms, with or without
 297 ;; modification, are permitted provided that the following conditions
 298 ;; are met:
 299 ;; 1. Redistributions of source code must retain the above copyright
 300 ;;    notice, this list of conditions and the following disclaimer.
 301 ;; 2. Redistributions in binary form must reproduce the above copyright
 302 ;;    notice, this list of conditions and the following disclaimer in the
 303 ;;    documentation and/or other materials provided with the distribution.
 304 ;; 3. The name of the authors may not be used to endorse or promote products
 305 ;;    derived from this software without specific prior written permission.
 306
 307 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
 308 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
 309 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
 310 ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
 311 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
 312 ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
 313 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 314 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
 315 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
 316 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 317
 318
 319 (cond-expand
 320  (guile)
 321  (mes
 322   (define-macro (define-syntax macro-name transformer . stuff)
 323     `(define-macro (,macro-name . args)
 324        (,transformer (cons ',macro-name args)
 325                      (lambda (x0) x0)
 326                      eq?)))))
 327
 328 ;; Rewrite-rule compiler (a.k.a. "extend-syntax")
 329
 330 ;; Example:
 331 ;;
 332 ;; (define-syntax or
 333 ;;   (syntax-rules ()
 334 ;;     ((or) #f)
 335 ;;     ((or e) e)
 336 ;;     ((or e1 e ...) (let ((temp e1))
 337 ;;                     (if temp temp (or e ...))))))
 338
 339 (cond-expand
 340  (guile)
 341  (mes
 342   (define-syntax syntax-rules
 343     (let ()
 344       (define name? symbol?)
 345
 346       (define (segment-pattern? pattern)
 347         (and (segment-template? pattern)
 348              (or (null? (cddr pattern))
 349                  (syntax-error0 "segment matching not implemented" pattern))))
 350
 351       (define (segment-template? pattern)
 352         (and (pair? pattern)
 353              (pair? (cdr pattern))
 354              (memq (cadr pattern) indicators-for-zero-or-more)))
 355
 356       (define indicators-for-zero-or-more (list (string->symbol "...") '---))
 357
 358       (lambda (exp r c)
 359
 360         (define %input (r '%input))     ;Gensym these, if you like.
 361         (define %compare (r '%compare))
 362         (define %rename (r '%rename))
 363         (define %tail (r '%tail))
 364         (define %temp (r '%temp))
 365
 366         (define rules (cddr exp))
 367         (define subkeywords (cadr exp))
 368
 369         (define (make-transformer rules)
 370           ;;(core:display-error "make-transformer:") (core:write-error rules) (core:display-error "\n")
 371           `(lambda (,%input ,%rename ,%compare)
 372              (let ((,%tail (cdr ,%input)))
 373                (cond ,@(map process-rule rules)
 374                      (else
 375                       (syntax-error1
 376                        "use of macro doesn't match definition"
 377                        ,%input))))))
 378
 379         (define (process-rule rule)
 380           ;;(core:display-error "process-rule:") (core:write-error rule) (core:display-error "\n")
 381           (if (and (pair? rule)
 382                    (pair? (cdr rule))
 383                    (null? (cddr rule)))
 384               (let ((pattern (cdar rule))
 385                     (template (cadr rule)))
 386                 `((and ,@(process-match %tail pattern))
 387                   (let* ,(process-pattern pattern
 388                                           %tail
 389                                           (lambda (x) x))
 390                     ,(process-template template
 391                                        0
 392                                        (meta-variables pattern 0 '())))))
 393               (syntax-error2 "ill-formed syntax rule" rule)))
 394
 395         ;; Generate code to test whether input expression matches pattern
 396
 397         (define (process-match input pattern)
 398           ;;(core:display-error "process-match:") (core:write-error input) (core:display-error "\n")
 399           ;;(core:display-error "      pattern:") (core:write-error pattern) (core:display-error "\n")
 400           (cond ((name? pattern)
 401                  (if (member pattern subkeywords)
 402                      `((,%compare ,input (,%rename ',pattern)))
 403                      `()))
 404                 ((segment-pattern? pattern)
 405                  (process-segment-match input (car pattern)))
 406                 ((pair? pattern)
 407                  `((let ((,%temp ,input))
 408                      (and (pair? ,%temp)
 409                           ,@(process-match `(car ,%temp) (car pattern))
 410                           ,@(process-match `(cdr ,%temp) (cdr pattern))))))
 411                 ((or (null? pattern) (boolean? pattern) (char? pattern))
 412                  `((eq? ,input ',pattern)))
 413                 (else
 414                  `((equal? ,input ',pattern)))))
 415
 416         (define (process-segment-match input pattern)
 417           ;;(core:display-error "process-segment-match:") (core:write-error input) (core:display-error "\n")
 418           ;;(core:display-error "              pattern:") (core:write-error pattern) (core:display-error "\n")
 419           (let ((conjuncts (process-match '(car l) pattern)))
 420             (if (null? conjuncts)
 421                 `((list? ,input))       ;+++
 422                 `((let loop ((l ,input))
 423                     (or (null? l)
 424                         (and (pair? l)
 425                              ,@conjuncts
 426                              (loop (cdr l)))))))))
 427
 428         ;; Generate code to take apart the input expression
 429         ;; This is pretty bad, but it seems to work (can't say why).
 430
 431         (define (process-pattern pattern path mapit)
 432           ;;(core:display-error "process-pattern:") (core:write-error pattern) (core:display-error "\n")
 433           ;;(core:display-error "           path:") (core:write-error path) (core:display-error "\n")
 434           (cond ((name? pattern)
 435                  (if (memq pattern subkeywords)
 436                      '()
 437                      (list (list pattern (mapit path)))))
 438                 ((segment-pattern? pattern)
 439                  (process-pattern (car pattern)
 440                                   %temp
 441                                   (lambda (x) ;temp is free in x
 442                                     (mapit (if (eq? %temp x)
 443                                                path ;+++
 444                                                `(map (lambda (,%temp) ,x)
 445                                                      ,path))))))
 446                 ((pair? pattern)
 447                  (append (process-pattern (car pattern) `(car ,path) mapit)
 448                          (process-pattern (cdr pattern) `(cdr ,path) mapit)))
 449                 (else '())))
 450
 451         ;; Generate code to compose the output expression according to template
 452
 453         (define (process-template template rank env)
 454           ;;(core:display-error "process-template:") (core:write-error template) (core:display-error "\n")
 455           (cond ((name? template)
 456                  (let ((probe (assq template env)))
 457                    (if probe
 458                        (if (<= (cdr probe) rank)
 459                            template
 460                            (syntax-error3 "template rank error (too few ...'s?)"
 461                                          template))
 462                        `(,%rename ',template))))
 463                 ((segment-template? template)
 464                  (let ((vars
 465                         (free-meta-variables (car template) (+ rank 1) env '())))
 466                    (if (null? vars)
 467                        (silent-syntax-error4 "too many ...'s" template)
 468                        (let* ((x (process-template (car template)
 469                                                    (+ rank 1)
 470                                                    env))
 471                               (gen (if (equal? (list x) vars)
 472                                        x ;+++
 473                                        `(map (lambda ,vars ,x)
 474                                              ,@vars))))
 475                          (if (null? (cddr template))
 476                              gen        ;+++
 477                              `(append ,gen ,(process-template (cddr template)
 478                                                               rank env)))))))
 479                 ((pair? template)
 480                  `(cons ,(process-template (car template) rank env)
 481                         ,(process-template (cdr template) rank env)))
 482                 (else `(quote ,template))))
 483
 484         ;; Return an association list of (var . rank)
 485
 486         (define (meta-variables pattern rank vars)
 487           ;;(core:display-error "meta-variables:") (core:write-error pattern) (core:display-error "\n")
 488           (cond ((name? pattern)
 489                  (if (memq pattern subkeywords)
 490                      vars
 491                      (cons (cons pattern rank) vars)))
 492                 ((segment-pattern? pattern)
 493                  (meta-variables (car pattern) (+ rank 1) vars))
 494                 ((pair? pattern)
 495                  (meta-variables (car pattern) rank
 496                                  (meta-variables (cdr pattern) rank vars)))
 497                 (else vars)))
 498
 499         ;; Return a list of meta-variables of given higher rank
 500
 501         (define (free-meta-variables template rank env free)
 502           ;;(core:display-error "meta-variables:") (core:write-error template) (core:display-error "\n")
 503           (cond ((name? template)
 504                  (if (and (not (memq template free))
 505                           (let ((probe (assq template env)))
 506                             (and probe (>= (cdr probe) rank))))
 507                      (cons template free)
 508                      free))
 509                 ((segment-template? template)
 510                  (free-meta-variables (car template)
 511                                       rank env
 512                                       (free-meta-variables (cddr template)
 513                                                            rank env free)))
 514                 ((pair? template)
 515                  (free-meta-variables (car template)
 516                                       rank env
 517                                       (free-meta-variables (cdr template)
 518                                                            rank env free)))
 519                 (else free)))
 520
 521         c                               ;ignored
 522
 523         ;; Kludge for Scheme48 linker.
 524         ;; `(cons ,(make-transformer rules)
 525         ;;          ',(find-free-names-in-syntax-rules subkeywords rules))
 526
 527         (make-transformer rules))))))
 528
 529 (cond-expand
 530  (guile)
 531  (mes
 532   (define-macro (let-syntax bindings . rest)
 533     `((lambda ()
 534         ,@(map (lambda (binding)
 535                  `(define-macro (,(car binding) . args)
 536                     (,(cadr binding) (cons ',(car binding) args)
 537                      (lambda (x0) x0)
 538                      eq?)))
 539                bindings)
 540         ,@rest)))))
 541
 542 (core:display
 543  (let-syntax ((xwhen (syntax-rules ()
 544                        ((xwhen condition exp ...)
 545                         (if (not condition)
 546                             (begin exp ...))))))
 547    (xwhen #f 42)))