init.krn

   1 ;;;_ Prolog file for Klink implementation of Kernel.
   2 ;;;_. Headers
   3 ;;;_ , Credits and License
   4 ;; Copyright (C) 2011  Tom Breton (Tehom)
   5
   6 ;; Author: Tom Breton (Tehom) <tehom@panix.com>
   7
   8 ;; This file is free software; you can redistribute it and/or modify
   9 ;; it under the terms of the GNU General Public License as published by
  10 ;; the Free Software Foundation; either version 2, or (at your option)
  11 ;; any later version.
  12
  13 ;; This file is distributed in the hope that it will be useful,
  14 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 ;; GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  20 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  21 ;; Boston, MA 02111-1307, USA.
  22
  23 ;;;_. Preliminary setup
  24 ($define! env-into
  25    (eval 'into module-parameters))
  26
  27 ($define! $define-in-gnd!
  28    ($vau/3 (definiendum definition) env
  29       (eval (list $set! env-into definiendum definition) env)))
  30
  31 ($define! null?/1 (wrap null?/o1))
  32 ($define! zero?/1 (wrap zero?/o1))
  33
  34 ;;;_. Body
  35
  36 ;;;_. Operatives
  37
  38 ($define-in-gnd! $sequence
  39    ($vau/3 args env
  40       (eval
  41          (cons (listloop listloop-style-sequence args) #inert)
  42          env)))
  43
  44 ($define-in-gnd! $vau
  45    ($vau/3 (formals eformal . body) env
  46       (eval
  47          (list $vau/3 formals eformal
  48             (cons $sequence body))
  49          env)))
  50
  51 ($define-in-gnd! $lambda
  52    ($vau/3 (formals . body) env
  53       (wrap (eval (list $vau/3 formals #ignore (cons $sequence body))
  54                env))))
  55 ;;;_ , Loading modules
  56
  57 ;;;_ , get-module-from-port
  58 ($define-in-gnd! get-module
  59    ($lambda (filename . rest)
  60       (apply get-module-from-port
  61          (list*
  62             (open-input-file filename)
  63             rest))))
  64
  65 ;;;_ , c(x^N)r
  66 ($define-in-gnd! caar   ($lambda (x) (car (car x))))
  67 ($define-in-gnd! cadr   ($lambda (x) (car (cdr x))))
  68 ($define-in-gnd! cdar   ($lambda (x) (cdr (car x))))
  69 ($define-in-gnd! cddr   ($lambda (x) (cdr (cdr x))))
  70 ($define-in-gnd! caaar  ($lambda (x) (car (car (car x)))))
  71 ($define-in-gnd! caadr  ($lambda (x) (car (car (cdr x)))))
  72 ($define-in-gnd! cadar  ($lambda (x) (car (cdr (car x)))))
  73 ($define-in-gnd! caddr  ($lambda (x) (car (cdr (cdr x)))))
  74 ($define-in-gnd! cdaar  ($lambda (x) (cdr (car (car x)))))
  75 ($define-in-gnd! cdadr  ($lambda (x) (cdr (car (cdr x)))))
  76 ($define-in-gnd! cddar  ($lambda (x) (cdr (cdr (car x)))))
  77 ($define-in-gnd! cdddr  ($lambda (x) (cdr (cdr (cdr x)))))
  78 ($define-in-gnd! caaaar ($lambda (x) (car (car (car (car x))))))
  79 ($define-in-gnd! caaadr ($lambda (x) (car (car (car (cdr x))))))
  80 ($define-in-gnd! caadar ($lambda (x) (car (car (cdr (car x))))))
  81 ($define-in-gnd! caaddr ($lambda (x) (car (car (cdr (cdr x))))))
  82 ($define-in-gnd! cadaar ($lambda (x) (car (cdr (car (car x))))))
  83 ($define-in-gnd! cadadr ($lambda (x) (car (cdr (car (cdr x))))))
  84 ($define-in-gnd! caddar ($lambda (x) (car (cdr (cdr (car x))))))
  85 ($define-in-gnd! cadddr ($lambda (x) (car (cdr (cdr (cdr x))))))
  86 ($define-in-gnd! cdaaar ($lambda (x) (cdr (car (car (car x))))))
  87 ($define-in-gnd! cdaadr ($lambda (x) (cdr (car (car (cdr x))))))
  88 ($define-in-gnd! cdadar ($lambda (x) (cdr (car (cdr (car x))))))
  89 ($define-in-gnd! cdaddr ($lambda (x) (cdr (car (cdr (cdr x))))))
  90 ($define-in-gnd! cddaar ($lambda (x) (cdr (cdr (car (car x))))))
  91 ($define-in-gnd! cddadr ($lambda (x) (cdr (cdr (car (cdr x))))))
  92 ($define-in-gnd! cdddar ($lambda (x) (cdr (cdr (cdr (car x))))))
  93 ($define-in-gnd! cddddr ($lambda (x) (cdr (cdr (cdr (cdr x))))))
  94 ;;;_ , Equality
  95 ;;$$FIX ME  This is just equal?/2, have to use compare-neighbors to
  96 ;;get the real equal?
  97 ($define-in-gnd! equal?/2
  98    ($lambda (x y)
  99       ($cond
 100          ((pair? x)
 101             ($and? (pair? y)
 102                (equal?/2 (car x) (car y))
 103                (equal?/2 (cdr x) (cdr y))))
 104
 105          ;;Not enabled now.
 106 ;;       ((vector? x)
 107 ;;          ($and (vector? y) (vector-equal? x y)))
 108          (#t
 109              (equal?/2-atom-atom x y)))))
 110
 111
 112 ;;;_ , Re-dispatchers
 113
 114 ;;;_  . apply
 115 ($define-in-gnd! apply
 116    ($lambda (appv arg . opt)
 117       (eval (cons (unwrap appv) arg)
 118             ($if (null?/1 opt)
 119                  (make-environment)
 120                  (car opt)))))
 121
 122 ;;;_ , Multiple application on single list
 123 ;;;_  . apply-counted-to-1-list
 124 ($define-in-gnd! apply-counted-to-1-list
 125    ($lambda (counted-proc proc ls)
 126       ;;An unrolled $let.  Can't use real $let because $let wants to
 127       ;;be built on this.
 128       (($lambda ((num-pairs #ignore #ignore cycle-len))
 129           (($lambda (any-infinite?)
 130               ($if any-infinite?
 131                  (error "Infinite lists not yet supported")
 132                  (apply counted-proc
 133                     (list num-pairs 1 proc (list ls)))))
 134              (not? (zero?/1 cycle-len))))
 135          (get-list-metrics ls))))
 136
 137 ;;;_  . "and" family
 138 ;;;_   , counted-every?/4
 139 ;;Just initializes the accumulator.
 140 ($define-in-gnd! counted-every?/4
 141    ($lambda (count len app lol)
 142       (counted-every?/5 #t count len (unwrap app) lol)))
 143
 144 ;;;_   , and?
 145 ($define-in-gnd! and?
 146    ($lambda ls
 147       (apply-counted-proc
 148          counted-every?/4
 149          identity
 150          (list ls))))
 151 ;;;_  . "or" family
 152 ;;;_   , counted-some?/4
 153 ($define-in-gnd! counted-some?/4
 154    ($lambda (count len app lol)
 155       (counted-some?/5 #f count len (unwrap app) lol)))
 156
 157 ;;;_   , or?
 158 ($define-in-gnd! or?
 159    ($lambda ls
 160       (apply-counted-proc
 161          counted-some?/4
 162          identity
 163          (list ls))))
 164
 165 ;;;_  . "map" family
 166 ;;;_   , counted-map/4
 167 ($define-in-gnd! counted-map/4
 168    ($lambda (count len app lol)
 169       (counted-map/5 '() count len (unwrap app) lol)))
 170
 171 ;;;_   , map1
 172 ;;$$TRANSITIONAL  In ground so we can test it.
 173 ;;A case of map, spelled out because the definition of map uses it.
 174 ($define-in-gnd! map1
 175    ($lambda (proc ls)
 176       (apply-counted-to-1-list counted-map/4 proc ls)))
 177
 178 ;;;_ , Definers
 179
 180 ($define-in-gnd! $let
 181    ($vau (bindings . body) env
 182       (eval (cons (list* $lambda (map1 car bindings) body)
 183                (map1 cadr bindings))
 184          env)))
 185
 186 ;;$$IMPROVE ME Expand the null cases.
 187 ($define-in-gnd! $let*
 188    ($vau (bindings . body) env
 189       (eval ($if (null?/1 bindings)
 190                  (list* $let bindings body)
 191                  (list $let
 192                        (list (car bindings))
 193                        (list* $let* (cdr bindings) body)))
 194             env)))
 195
 196 ($define-in-gnd! $letrec
 197    ($vau (bindings . body) env
 198       (eval (list* $let ()
 199                    (list $define!
 200                          (map1 car bindings)
 201                          (list* list (map1 cadr bindings)))
 202                    body)
 203             env)))
 204
 205 ($define-in-gnd! $letrec*
 206    ($vau (bindings . body) env
 207       (eval ($if (null?/1 bindings)
 208                  (list* $letrec bindings body)
 209                  (list $letrec
 210                        (list (car bindings))
 211                        (list* $letrec* (cdr bindings) body)))
 212             env)))
 213
 214 ($define-in-gnd! $let-redirect
 215    ($vau (exp bindings . body) env
 216       (eval (list* (eval (list* $lambda (map1 car bindings) body)
 217                          (eval exp
 218                                env))
 219                    (map1 cadr bindings))
 220             env)))
 221
 222 ($define-in-gnd! $let-safe
 223    ($vau (bindings . body) env
 224       (eval (list* $let-redirect
 225                     (make-kernel-standard-environment)
 226                     bindings
 227                     body)
 228              env)))
 229
 230
 231 ($define-in-gnd! $let/cc
 232    ($vau (symbol . body) env
 233       (eval (list call/cc (list* $lambda (list symbol) body))
 234             env)))
 235
 236 ($define-in-gnd! $define/cc!
 237    ($vau (s) e
 238       ($let/cc c
 239          ((wrap $set!) e s c))))
 240
 241 ($define-in-gnd! $provide!
 242    ($vau (symbols . body) env
 243       (eval (list $define! symbols
 244                (list $let ()
 245                   (list* $sequence body)
 246                   (list* list symbols)))
 247          env)))
 248
 249 ($define-in-gnd! $import!
 250    ($vau (exp . symbols) env
 251       (eval (list $set!
 252                    env
 253                    symbols
 254                    (cons list symbols))
 255             (eval exp env))))
 256
 257 ($define-in-gnd! $binds?
 258    ($vau (exp . sym-list) dynamic
 259       ($let ((env (eval exp dynamic)))
 260          ;;$$IMPROVE ME  Make it donut-safe
 261          (every?/2-xary
 262             ($vau sym env-of-env
 263                (eval
 264                   (list $binds?/2 env sym)
 265                   env-of-env))
 266             sym-list))))
 267
 268 ($define-in-gnd! $remote-eval
 269    ($vau (o e) d
 270       (eval o (eval e d))))
 271
 272 ($define-in-gnd! $let-redirect
 273    ($vau (exp bindings . body) env
 274       (eval (list* (eval (list* $lambda (map1 car bindings) body)
 275                          (eval exp
 276                                env))
 277                    (map1 cadr bindings))
 278             env)))
 279
 280 ($define-in-gnd! $let-safe
 281    ($vau (bindings . body) env
 282       (eval (list* $let-redirect
 283                     (make-kernel-standard-environment)
 284                     bindings
 285                     body)
 286              env)))
 287
 288 ($define-in-gnd! $bindings->environment
 289    ($vau bindings denv
 290       (eval (list $let-redirect
 291                   (make-environment)
 292                   bindings
 293                   (list get-current-environment))
 294             denv)))
 295
 296 ;;;_ , Continuations
 297
 298 ($define-in-gnd! apply-continuation
 299    ($lambda (c o)
 300       (apply (continuation->applicative c) o)))
 301
 302 ;;NB, root-continuation is not available here in the prolog because
 303 ;;loading the prolog has a separate root from the REPL loop.
 304
 305 ;;;_ , Type/destructure combiners
 306
 307 ;;;_  . CAVEAT
 308 ;;NOT ready for general use; unsafe because there's a hidden
 309 ;;requirement on the args that they (a) convert to xary internally,
 310 ;;and (b) not internally call Kernel, neither of which should be
 311 ;;determinable by Kernel code.  So this is just a specialization of
 312 ;;some yet-to-be-written combiner that handles the general case.
 313
 314 ;;$$TRANSITIONAL These are exposed for testing, until we have a means
 315 ;;of exposing them for testing without exposing them in general.
 316 ;;Later we may wrap this up so that only `listtype' and
 317 ;;`destructure-list' are exposed, and possibly `combiner->trivpred'
 318 ;;and a trivpred->pred combiner are exposed in unsafe,
 319 ;;;_  . pred-trivpred-alist
 320 ($define! pred-trivpred-alist
 321    (list
 322       (list 'applicative?       applicative?/o1)
 323       (list 'boolean?           boolean?/o1)
 324       (list 'character?         character?/o1)
 325       (list 'combiner?          combiner?/o1)
 326       (list 'continuation?      continuation?/o1)
 327       (list 'countable-list?    countable-list?/o1)
 328       (list 'environment?       environment?/o1)
 329       (list 'finite-list?       finite-list?/o1)
 330       (list 'ignore?            ignore?/o1)
 331       (list 'inert?             inert?/o1)
 332       (list 'input-port?        input-port?/o1)
 333       (list 'integer?           integer?/o1)
 334       (list 'null?              null?/o1)
 335       (list 'number?            number?/o1)
 336       (list 'operative?         operative?/o1)
 337       (list 'output-port?       output-port?/o1)
 338       (list 'pair?              pair?/o1)
 339       (list 'port?              port?/o1)
 340       (list 'posint?            posint?/o1)
 341       (list 'promise?           promise?/o1)
 342       (list 'real?              real?/o1)
 343       (list 'recur-tracker?     recur-tracker?/o1)
 344       (list 'recurrence-table?  recurrence-table?/o1)
 345       (list 'string?            string?/o1)
 346       (list 'symbol?            symbol?/o1)
 347       (list 'zero?              zero?/o1)
 348
 349       ;;These don't belong in ground.
 350       (list 'trivpred?          trivpred?/o1)
 351       (list 'vector?            vector?/o1)
 352       ))
 353 ;;;_  . The environment of them
 354 ($define-in-gnd! pred-trivpred-env
 355    (eval (list* $bindings->environment pred-trivpred-alist)))
 356 ;;;_  . trivpred->pred
 357 ($define-in-gnd! trivpred->pred
 358    ($lambda (trivpred)
 359       ($lambda x
 360          (every? (wrap trivpred) x))))
 361
 362 ;;;_  . $define-pred!
 363 ($define-in-gnd! $define-pred!
 364    ($vau ((sym trivpred)) env
 365       (eval
 366          (list $define-in-gnd! sym (trivpred->pred trivpred)))))
 367
 368 ;;;_  . Define `every?' versions of each
 369 ;;$$IMPROVE ME  This should be for-each1
 370 (map1 (wrap $define-pred!) pred-trivpred-alist)
 371 ;;;_  . combiner->trivpred
 372 ;;$$TRANSITIONAL For now, this assumes `env-into' is where all
 373 ;;relevant bindings are found.  Later we may pursue a wholly different
 374 ;;strategy.
 375 ;;Returns (#t Object) or (#f Original)
 376 ($define-in-gnd! combiner->trivpred
 377    ($lambda (comb)
 378       ($if (trivpred? comb)
 379          (cons #t comb)
 380          ($sequence
 381             ($define! (found? . obj) (cons #f comb))
 382             ($if (reverse-binds?/2 comb env-into)
 383                ($define! (found? . obj)
 384                   ($let ((sym (reverse-lookup comb env-into)))
 385                      ($if (symbol? sym)
 386                         (find-binding pred-trivpred-env sym)
 387                         (cons #f comb))))
 388                #inert)
 389             ($if (and?
 390                     (not? found?)
 391                     (applicative? comb))
 392                ;;Retry it, unwrapped once.
 393                (combiner->trivpred (unwrap comb))
 394                (cons found? obj))))))
 395 ;;;_  . type-arg->low-type-arg
 396 ($define-in-gnd! type-arg->low-type-arg
 397    ($lambda (arg)
 398       ($define! (found? . obj)
 399          ($if (symbol? arg)
 400             (find-binding typecheck-special-syms arg)
 401             (combiner->trivpred arg)))
 402       obj))
 403
 404 ;;;_  . listtype
 405 ($define-in-gnd! listtype
 406    ($lambda args
 407       ;;$$IMPROVE ME Check that they were all converted.
 408       ;;$$IMPROVE ME  If they weren't, make a more general listtype checker.
 409       ($let
 410          ((real-args
 411              ;;This makes them into trivpreds OR special keys.
 412              (map1 type-arg->low-type-arg args)))
 413          (apply listtype/N-trivpred real-args))))
 414
 415 ;;;_  . destructure-list
 416 ;;NOT ready for general use, same reason.
 417 ($define-in-gnd! destructure-list
 418    ($lambda args
 419       ($let
 420          ((real-args
 421              ;;This makes them into trivpreds OR special keys.
 422              (map1 type-arg->low-type-arg args)))
 423          (apply destructure-list/N-trivpred real-args))))
 424 ;;;_  . make-encapsulation-type
 425 ($define-in-gnd! make-encapsulation-type
 426    ($lambda #ignore
 427       ($let (((e p?/o1 d) (make-encapsulation-type/raw)))
 428          (list e (trivpred->pred p?/o1) d))))
 429
 430 ;;;_ , Control
 431 ($define-in-gnd! $cond
 432    ($vau clauses env
 433       ($if (null?/1 clauses)
 434            #inert
 435            ($let ((((test . body) . clauses) clauses))
 436               ($if (eval test env)
 437                    (apply (wrap $sequence) body env)
 438                    (apply (wrap $cond) clauses env))))))
 439
 440 ;;$$TRANSITIONAL  John's tests want error-descriptor? but it's not
 441 ;;defined, so temporarily set it to always false.
 442 ($define-in-gnd! error-descriptor? ($lambda #ignore #f))
 443
 444 ;;;_ , Arithmetic initial redefines
 445
 446 ($define-in-gnd! =? equal?/2-num-num)
 447
 448 ;;;_ , List functions
 449 ;;;_  . list-tail
 450 ;;$$TRANSITIONAL This will be done in C.
 451 ($define-in-gnd! list-tail
 452    ($lambda (ls k)
 453       ($if (>?/2 k 0)
 454            (list-tail (cdr ls) (sub k 1))
 455            ls)))
 456
 457 ;;;_  . encycle!
 458 ;;$$MAKE ME SAFER  Check that there are at least k1+k2 pairs.
 459 ($define-in-gnd! encycle!
 460    ($lambda (ls k1 k2)
 461       ($if (>?/2 k2 0)
 462            (set-cdr! (list-tail ls (add k1 (add k2 -1)))
 463                      (list-tail ls k1))
 464            #inert)))
 465 ;;;_  . list-neighbors-aux
 466 ($define-in-gnd! list-neighbors-aux
 467    ($lambda (ls)
 468       ;; get n sets of neighbors from ls
 469       ($define! aux
 470          ($lambda (ls n)
 471             (reverse
 472                (eval
 473                   (cons (listloop listloop-style-neighbors ls n) '())))))
 474       ($let* (((p #ignore a c)  (get-list-metrics ls))
 475                 (len
 476                    ($if (=? c 0) (- a 1) p)))
 477          (list
 478             (aux ls len) len a c))))
 479
 480
 481 ;;;_  . list-neighbors-linear
 482 ($define-in-gnd! list-neighbors-linear
 483    ($lambda (ls)
 484       ($let
 485          (((neighbors . #ignore) (list-neighbors-aux ls)))
 486          neighbors)))
 487 ;;;_  . list-neighbors
 488 ($define-in-gnd! list-neighbors
 489    ($lambda (ls)
 490       ($let
 491          (((neighbors #ignore a c) (list-neighbors-aux ls)))
 492          (encycle! neighbors a c)
 493          neighbors)))
 494
 495 ;;;_  . compare-neighbors
 496 ($define-in-gnd! compare-neighbors
 497    ($lambda (op comparands)
 498       ($let
 499          (((neighbors len . #ignore) (list-neighbors-aux comparands)))
 500          (counted-every?/5
 501             #t len 1
 502             ;;counted-every?/5 gives these elements as the first arg,
 503             ;;so convert binary op to unary.
 504             ($vau (x) env
 505                (apply op x env))
 506             (list neighbors)))))
 507 ;;;_  . equal?
 508 ($define-in-gnd! equal?
 509    ($lambda args
 510       (apply compare-neighbors (list equal?/2 args))))
 511
 512 ;;;_  . reduce
 513
 514 ($define-in-gnd! reduce
 515    ($let ()
 516       ;;$$TRANSITIONAL This part will be done in C.
 517       ($define! reduce-acyclic
 518          ($lambda (ls bin id)
 519             ($cond ((null?/1 (force ls))         id)
 520                ((null?/1 (force (cdr ls))) (car ls))
 521                (#t
 522                   (bin (car ls)
 523                      (reduce-acyclic (cdr ls) bin id))))))
 524       ;;$$MOVE ME This counted part is the heart of it, belongs in C,
 525       ;;and should take id, which is useful.
 526       ($define! reduce-n
 527          ($lambda (ls bin n)
 528             ($if (=? n 1)
 529                (car ls)
 530                (bin (car ls)
 531                   (reduce-n (cdr ls) bin (sub n 1))))))
 532       (wrap ($vau (ls bin id . opt) env
 533                ;;Proc to fix the environment that `bin', `pre', `in',
 534                ;;and `post' run in.
 535                ($define! fixenv
 536                   ($lambda (appv)
 537                      ($lambda x (apply appv x env))))
 538                ($define! bin (fixenv bin))
 539                ($let (((p n a c) (get-list-metrics ls)))
 540                   ($if (=? c 0)
 541                      (reduce-acyclic ls bin id)
 542                      ($sequence
 543                         ($define! (pre in post) (map1 fixenv opt))
 544                         ($define! reduced-cycle
 545                            (post (reduce-n (map1 pre (list-tail ls a))
 546                                     in
 547                                     c)))
 548                         ($if (=? a 0)
 549                            reduced-cycle
 550                            (bin (reduce-n ls bin a)
 551                               reduced-cycle)))))))))
 552 ;;;_  . stream->list
 553 ($define-in-gnd! stream->list
 554    ($lambda (stream)
 555       ($let ((stream (force stream)))
 556          ($if (null?/1 stream)
 557             '()
 558             (cons (car stream) (stream->list (cdr stream)))))))
 559
 560
 561 ;;;_ , Arithmetic n-ary defines
 562 ($define-in-gnd! +
 563    ($lambda x (reduce x add 0)))
 564
 565 ($define-in-gnd! *
 566    ($lambda x (reduce x mul 1)))
 567
 568 ($define-in-gnd! -
 569    ($lambda (minuend . subtrahends)
 570       ($if
 571          (eq? subtrahends ())
 572          (error "`-' with no subtrahends is deliberately not supplied")
 573          (sub minuend (apply + subtrahends)))))
 574
 575 ($define-in-gnd! /
 576    ($lambda (dividend . divisors)
 577       ($if
 578          (eq? divisors ())
 579          (error "`/' with no divisors is deliberately not supplied")
 580          (div dividend (apply * divisors)))))
 581
 582 ;;;_  . Comparisons
 583
 584 ($define-in-gnd! >?
 585    ($lambda comparands
 586       (compare-neighbors >?/2 comparands)))
 587
 588 ($define-in-gnd! <?
 589    ($lambda comparands
 590       (compare-neighbors
 591          ($lambda (a b) (>?/2 b a))
 592          comparands)))
 593
 594 ($define-in-gnd! <=?
 595    ($lambda comparands
 596       (compare-neighbors
 597          ($lambda (a b) (not? (>?/2 a b)))
 598          comparands)))
 599
 600 ($define-in-gnd! >=?
 601    ($lambda comparands
 602       (compare-neighbors
 603          ($lambda (a b) (not? (>?/2 b a)))
 604          comparands)))
 605
 606 ;;;_  . Multiple application on multiple lists
 607 ;;;_   , apply-counted-proc
 608 ;;$$IMPROVE ME  Make `proc' execute in external dynamic environment.
 609 ($define-in-gnd! apply-counted-proc
 610    ($lambda (counted-proc proc lists)
 611       ($let*
 612          (
 613             ((pairs-in-top . #ignore) (get-list-metrics lists))
 614             ;;If `lists' is cyclic, we'll surround `proc' with
 615             ;;something that encycles what it gets.
 616             (metrics (map1 get-list-metrics lists))
 617             (all-cycles
 618                (map1
 619                   ($lambda ((#ignore #ignore #ignore cycle)) cycle)
 620                   metrics))
 621             (any-infinite?
 622                (not?
 623                   (counted-every?/4
 624                      pairs-in-top 1 zero?/1 (list all-cycles))))
 625             ;;Test for same-length.
 626             (num-pairs-list
 627                (map1
 628                   ($lambda ((pairs . #ignore)) pairs)
 629                   metrics)))
 630          ($if any-infinite?
 631             (error "Infinite lists not yet supported")
 632             ($if (apply equal? num-pairs-list)
 633                ;;$$IMPROVE ME  Do this in a given environment.
 634                (counted-proc
 635                   (car num-pairs-list)
 636                   pairs-in-top
 637                   proc
 638                   lists)
 639                (error "Lists are mixed-length"))))))
 640
 641 ;;;_   , "and" family
 642 ;;;_    . every?
 643 ($define-in-gnd! every?
 644    ($lambda (proc . lists)
 645       (apply-counted-proc
 646          counted-every?/4
 647          proc
 648          lists)))
 649 ;;;_   , "or" family
 650 ;;;_    . some?
 651 ($define-in-gnd! some?
 652    ($lambda (proc . lists)
 653       (apply-counted-proc
 654          counted-some?/4
 655          proc
 656          lists)))
 657
 658 ;;;_   , "map" family
 659 ;;;_    . map
 660 ($define-in-gnd! map
 661    ($lambda (proc . lists)
 662       (apply-counted-proc counted-map/4 proc lists)))
 663 ;;;_   , "each" family
 664 ;;;_    . for-each
 665 ($define-in-gnd! for-each
 666    (wrap ($vau x env
 667             (apply map x env)
 668             #inert)))
 669
 670
 671 ;;;_. Footers
 672 ;;Local variables:
 673 ;;mode: scheme
 674 ;;mode: allout
 675 ;;End:
 676