module/system/il/macros.scm

   1 ;;; GHIL macros
   2
   3 ;; Copyright (C) 2001 Free Software Foundation, Inc.
   4
   5 ;; This program is free software; you can redistribute it and/or modify
   6 ;; it under the terms of the GNU General Public License as published by
   7 ;; the Free Software Foundation; either version 2, or (at your option)
   8 ;; any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 ;; GNU General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this program; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  18 ;; Boston, MA 02111-1307, USA.
  19
  20 ;;; Code:
  21
  22 (define-module (system il macros)
  23   :use-module (ice-9 match))
  24
  25 (define (make-label) (gensym ":L"))
  26 (define (make-sym) (gensym "_"))
  27
  28 ;;;
  29 ;;; Module macros
  30 ;;;
  31
  32 (define (@import identifier)
  33   `((@ System::Base::module::do-import) (@quote ,identifier)))
  34
  35 \f
  36 ;;;
  37 ;;; Syntax
  38 ;;;
  39
  40 ;; (@and X Y...) =>
  41 ;;
  42 ;; (@if X (@and Y...) #f)
  43 (define @and
  44   (match-lambda*
  45     (() #t)
  46     ((x) x)
  47     ((x . rest) `(@if ,x (@and ,@rest) #f))))
  48
  49 ;; (@or X Y...) =>
  50 ;;
  51 ;; (@let ((@_ X)) (@if @_ @_ (@or Y...)))
  52 (define @or
  53   (match-lambda*
  54     (() #f)
  55     ((x) x)
  56     ((x . rest)
  57      (let ((sym (make-sym)))
  58        `(@let ((,sym ,x)) (@if ,sym ,sym (@or ,@rest)))))))
  59
  60 ;; (@while TEST BODY...) =>
  61 ;;
  62 ;;     (@goto L1)
  63 ;; L0: BODY...
  64 ;; L1: (@if TEST (@goto L0) (@void))
  65 ;;; non-R5RS
  66 (define (@while test . body)
  67   (let ((L0 (make-label)) (L1 (make-label)))
  68     `(@begin
  69        (@goto ,L1)
  70        (@label ,L0) ,@body
  71        (@label ,L1) (@if ,test (@goto ,L0) (@void)))))
  72
  73 ;; (@cond (TEST BODY...) ...) =>
  74 ;;
  75 ;;   (@if TEST
  76 ;;        (@begin BODY...)
  77 ;;        (@cond ...))
  78 (define (@cond . clauses)
  79   (cond ((null? clauses) (error "missing clauses"))
  80         ((pair? (car clauses))
  81          (let ((c (car clauses)) (l (cdr clauses)))
  82            (let ((rest (if (null? l) '(@void) `(@cond ,@l))))
  83              (cond ((eq? (car c) '@else) `(@begin (@void) ,@(cdr c)))
  84                    ((null? (cdr c)) `(@or ,(car c) ,rest))
  85                    (else `(@if ,(car c) (@begin ,@(cdr c)) ,rest))))))
  86         (else (error "bad clause:" (car clauses)))))
  87
  88 (define (@let* binds . body)
  89   (if (null? binds)
  90       `(@begin ,@body)
  91       `(@let (,(car binds)) (@let* ,(cdr binds) ,@body))))
  92
  93 \f
  94 ;;;
  95 ;;; R5RS Procedures
  96 ;;;
  97
  98 ;; 6. Standard procedures
  99
 100 ;;; 6.1 Equivalence predicates
 101
 102 (define (@eq? x y)     `(@@ eq? ,x ,y))
 103 (define (@eqv? x y)    `(@@ eqv? ,x ,y))
 104 (define (@equal? x y)  `(@@ equal? ,x ,y))
 105
 106 ;;; 6.2 Numbers
 107
 108 (define (@number? x)   `(@@ number? ,x))
 109 (define (@complex? x)  `(@@ complex? ,x))
 110 (define (@real? x)     `(@@ real? ,x))
 111 (define (@rational? x) `(@@ rational? ,x))
 112 (define (@integer? x)  `(@@ integer? ,x))
 113
 114 (define (@exact? x)    `(@@ exact? ,x))
 115 (define (@inexact? x)  `(@@ inexact? ,x))
 116
 117 (define (@= x y)       `(@@ ee? ,x ,y))
 118 (define (@< x y)       `(@@ lt? ,x ,y))
 119 (define (@> x y)       `(@@ gt? ,x ,y))
 120 (define (@<= x y)      `(@@ le? ,x ,y))
 121 (define (@>= x y)      `(@@ ge? ,x ,y))
 122
 123 (define (@zero? x)     `(@= ,x 0))
 124 (define (@positive? x) `(@> ,x 0))
 125 (define (@negative? x) `(@< ,x 0))
 126 (define (@odd? x)      `(@= (@modulo ,x 2) 1))
 127 (define (@even? x)     `(@= (@modulo ,x 2) 0))
 128
 129 (define (@max . args)  `(@@ max ,@args))
 130 (define (@min . args)  `(@@ min ,@args))
 131
 132 (define @+
 133   (match-lambda*
 134     (() 0)
 135     ((x) x)
 136     ((x y) `(@@ add ,x ,y))
 137     ((x y . rest) `(@@ add ,x (@+ ,y ,@rest)))))
 138
 139 (define @*
 140   (match-lambda*
 141     (() 1)
 142     ((x) x)
 143     ((x y) `(@@ mul ,x ,y))
 144     ((x y . rest) `(@@ mul ,x (@* ,y ,@rest)))))
 145
 146 (define @-
 147   (match-lambda*
 148     ((x) `(@@ neg ,x))
 149     ((x y) `(@@ sub ,x ,y))
 150     ((x y . rest) `(@@ sub ,x (@+ ,y ,@rest)))))
 151
 152 (define @/
 153   (match-lambda*
 154     ((x) `(@@ rec ,x))
 155     ((x y) `(@@ div ,x ,y))
 156     ((x y . rest) `(@@ div ,x (@* ,y ,@rest)))))
 157
 158 ;;; abs
 159 ;;;
 160 ;;; quotient
 161 (define (@remainder x y) `(@@ remainder ,x ,y))
 162 ;;; modulo
 163 ;;;
 164 ;;; gcd
 165 ;;; lcm
 166 ;;;
 167 ;;; numerator
 168 ;;; denominator
 169 ;;;
 170 ;;; floor
 171 ;;; ceiling
 172 ;;; truncate
 173 ;;; round
 174 ;;;
 175 ;;; rationalize
 176 ;;;
 177 ;;; exp
 178 ;;; log
 179 ;;; sin
 180 ;;; cos
 181 ;;; tan
 182 ;;; asin
 183 ;;; acos
 184 ;;; atan
 185 ;;;
 186 ;;; sqrt
 187 ;;; expt
 188 ;;;
 189 ;;; make-rectangular
 190 ;;; make-polar
 191 ;;; real-part
 192 ;;; imag-part
 193 ;;; magnitude
 194 ;;; angle
 195 ;;;
 196 ;;; exact->inexact
 197 ;;; inexact->exact
 198 ;;;
 199 ;;; number->string
 200 ;;; string->number
 201
 202 ;;; 6.3 Other data types
 203
 204 ;;;; 6.3.1 Booleans
 205
 206 (define (@not x) `(@@ not ,x))
 207 (define (@boolean? x) `(@@ boolean? ,x))
 208
 209 ;;;; 6.3.2 Pairs and lists
 210
 211 (define (@pair? x) `(@@ pair? ,x))
 212 (define (@cons x y) `(@@ cons ,x ,y))
 213
 214 (define (@car x) `(@@ car ,x))
 215 (define (@cdr x) `(@@ cdr ,x))
 216 (define (@set-car! x) `(@@ set-car! ,x))
 217 (define (@set-cdr! x) `(@@ set-cdr! ,x))
 218
 219 (define (@caar x) `(@@ car (@@ car ,x)))
 220 (define (@cadr x) `(@@ car (@@ cdr ,x)))
 221 (define (@cdar x) `(@@ cdr (@@ car ,x)))
 222 (define (@cddr x) `(@@ cdr (@@ cdr ,x)))
 223 (define (@caaar x) `(@@ car (@@ car (@@ car ,x))))
 224 (define (@caadr x) `(@@ car (@@ car (@@ cdr ,x))))
 225 (define (@cadar x) `(@@ car (@@ cdr (@@ car ,x))))
 226 (define (@caddr x) `(@@ car (@@ cdr (@@ cdr ,x))))
 227 (define (@cdaar x) `(@@ cdr (@@ car (@@ car ,x))))
 228 (define (@cdadr x) `(@@ cdr (@@ car (@@ cdr ,x))))
 229 (define (@cddar x) `(@@ cdr (@@ cdr (@@ car ,x))))
 230 (define (@cdddr x) `(@@ cdr (@@ cdr (@@ cdr ,x))))
 231 (define (@caaaar x) `(@@ car (@@ car (@@ car (@@ car ,x)))))
 232 (define (@caaadr x) `(@@ car (@@ car (@@ car (@@ cdr ,x)))))
 233 (define (@caadar x) `(@@ car (@@ car (@@ cdr (@@ car ,x)))))
 234 (define (@caaddr x) `(@@ car (@@ car (@@ cdr (@@ cdr ,x)))))
 235 (define (@cadaar x) `(@@ car (@@ cdr (@@ car (@@ car ,x)))))
 236 (define (@cadadr x) `(@@ car (@@ cdr (@@ car (@@ cdr ,x)))))
 237 (define (@caddar x) `(@@ car (@@ cdr (@@ cdr (@@ car ,x)))))
 238 (define (@cadddr x) `(@@ car (@@ cdr (@@ cdr (@@ cdr ,x)))))
 239 (define (@cdaaar x) `(@@ cdr (@@ car (@@ car (@@ car ,x)))))
 240 (define (@cdaadr x) `(@@ cdr (@@ car (@@ car (@@ cdr ,x)))))
 241 (define (@cdadar x) `(@@ cdr (@@ car (@@ cdr (@@ car ,x)))))
 242 (define (@cdaddr x) `(@@ cdr (@@ car (@@ cdr (@@ cdr ,x)))))
 243 (define (@cddaar x) `(@@ cdr (@@ cdr (@@ car (@@ car ,x)))))
 244 (define (@cddadr x) `(@@ cdr (@@ cdr (@@ car (@@ cdr ,x)))))
 245 (define (@cdddar x) `(@@ cdr (@@ cdr (@@ cdr (@@ car ,x)))))
 246 (define (@cddddr x) `(@@ cdr (@@ cdr (@@ cdr (@@ cdr ,x)))))
 247
 248 (define (@null? x) `(@@ null? ,x))
 249 (define (@list? x) `(@@ list? ,x))
 250 (define (@list . args) `(@@ list ,@args))
 251
 252 ;;; length
 253 ;;; append
 254 ;;; reverse
 255 ;;; list-tail
 256 ;;; list-ref
 257 ;;;
 258 ;;; memq
 259 ;;; memv
 260 ;;; member
 261 ;;;
 262 ;;; assq
 263 ;;; assv
 264 ;;; assoc
 265
 266 ;;;; 6.3.3 Symbols
 267
 268 ;;; symbol?
 269 ;;; symbol->string
 270 ;;; string->symbol
 271
 272 ;;;; 6.3.4 Characters
 273
 274 ;;; char?
 275 ;;; char=?
 276 ;;; char<?
 277 ;;; char>?
 278 ;;; char<=?
 279 ;;; char>=?
 280 ;;; char-ci=?
 281 ;;; char-ci<?
 282 ;;; char-ci>?
 283 ;;; char-ci<=?
 284 ;;; char-ci>=?
 285 ;;; char-alphabetic?
 286 ;;; char-numeric?
 287 ;;; char-whitespace?
 288 ;;; char-upper-case?
 289 ;;; char-lower-case?
 290 ;;; char->integer
 291 ;;; integer->char
 292 ;;; char-upcase
 293 ;;; char-downcase
 294
 295 ;;;; 6.3.5 Strings
 296
 297 ;;; string?
 298 ;;; make-string
 299 ;;; string
 300 ;;; string-length
 301 ;;; string-ref
 302 ;;; string-set!
 303 ;;;
 304 ;;; string=?
 305 ;;; string-ci=?
 306 ;;; string<?
 307 ;;; string>?
 308 ;;; string<=?
 309 ;;; string>=?
 310 ;;; string-ci<?
 311 ;;; string-ci>?
 312 ;;; string-ci<=?
 313 ;;; string-ci>=?
 314 ;;;
 315 ;;; substring
 316 ;;; string-append
 317 ;;; string->list
 318 ;;; list->string
 319 ;;; string-copy
 320 ;;; string-fill!
 321
 322 ;;;; 6.3.6 Vectors
 323
 324 ;;; vector?
 325 ;;; make-vector
 326 ;;; vector
 327 ;;; vector-length
 328 ;;; vector-ref
 329 ;;; vector-set!
 330 ;;; vector->list
 331 ;;; list->vector
 332 ;;; vector-fill!
 333
 334 ;;;; 6.4 Control features
 335
 336 (define (@procedure? x) `(@@ procedure? x))
 337
 338 ;; (define (@apply proc . args) ...)
 339
 340 (define (@map f ls . more)
 341   (if (null? more)
 342       `(@let ((f ,f))
 343          (@let map1 ((ls ,ls))
 344            (@if (@null? ls)
 345                 '()
 346                 (@cons (f (car ls)) (map1 (cdr ls))))))
 347       `(@let ((f ,f))
 348          (@let map-more ((ls ,ls) (more ,more))
 349            (@if (@null? ls)
 350                 '()
 351                 (@cons (@apply f (car ls) (map car more))
 352                        (map-more (cdr ls) (map cdr more))))))))
 353
 354 (define @for-each
 355   (match-lambda*
 356     ((f l)
 357      (do ((ls ls (cdr ls)) (more more (map cdr more)))
 358          ((null? ls))
 359        (apply f (car ls) (map car more))))
 360     ((f . args)
 361      `(@apply (@~ system:il:base:for-each) args))))
 362
 363 (define (@force promise) `(@@ force promise))
 364
 365 (define (@call-with-current-continuation proc) `(@@ call/cc proc))
 366
 367 (define @call/cc @call-with-current-continuation)
 368
 369 ;;; values
 370 ;;; call-with-values
 371 ;;; dynamic-wind
 372
 373 ;;; 6.5 Eval
 374
 375 ;;; eval
 376 ;;; scheme-report-environment
 377 ;;; null-environment
 378 ;;; interaction-environment
 379
 380 ;;; 6.6 Input and output
 381
 382 ;;;; 6.6.1 Ports
 383
 384 ;;; call-with-input-file
 385 ;;; call-with-output-file
 386 ;;;
 387 ;;; input-port?
 388 ;;; output-port?
 389 ;;; current-input-port
 390 ;;; current-output-port
 391 ;;;
 392 ;;; with-input-from-file
 393 ;;; with-output-to-file
 394 ;;;
 395 ;;; open-input-file
 396 ;;; open-output-file
 397 ;;; close-input-port
 398 ;;; close-output-port
 399
 400 ;;;; 6.6.2 Input
 401
 402 ;;; read
 403 ;;; read-char
 404 ;;; peek-char
 405 ;;; eof-object?
 406 ;;; char-ready?
 407
 408 ;;;; 6.6.3 Output
 409
 410 ;;; write
 411 ;;; display
 412 ;;; newline
 413 ;;; write-char
 414
 415 ;;;; 6.6.4 System interface
 416
 417 ;;; load
 418 ;;; transcript-on
 419 ;;; transcript-off
 420
 421 \f
 422 ;;;
 423 ;;; Non-R5RS Procedures
 424 ;;;
 425
 426 (define @cons*
 427   (match-lambda*
 428     ((x) x)
 429     ((x y) `(@cons ,x ,y))
 430     ((x y . rest) `(@cons ,x (@cons* ,y ,@rest)))))
 431
 432 (define (@error . args) `(@@ display ,@args))
 433
 434 (define (@current-module)
 435   `((@ System::Base::module::current-module)))