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