home *** CD-ROM | disk | FTP | other *** search
/ Fresh Fish 8 / FreshFishVol8-CD2.bin / bbs / dev / umbscheme-2.12.lha / UMBScheme / prelude.scheme < prev    next >
Text File  |  1993-11-29  |  16KB  |  658 lines
  1. ;  prelude.scheme -- UMB Scheme, standard primitives in Scheme.
  2. ;
  3. ;  Copyright 1988, 1991 University of Massachusetts 
  4. ;
  5. ;  Author: William R Campbell, University of Massachusetts at Boston,
  6. ;
  7. ;  $Revision: 2.12 $
  8.  
  9. (gc-messages #f)
  10.  
  11. ; PRIMITIVE  PROCEDURES
  12.  
  13. ; Pairs and lists.
  14.  
  15. ; car - cdr compositions  (caar pair) ... (cddddr pair)
  16.  
  17. (define (caar x) (car (car x)))
  18. (define (cadr x) (car (cdr x)))
  19. (define (cdar x) (cdr (car x)))
  20. (define (cddr x) (cdr (cdr x)))
  21.  
  22. (define (caaar x) (car (car (car x))))
  23. (define (caadr x) (car (car (cdr x))))
  24. (define (cadar x) (car (cdr (car x))))
  25. (define (caddr x) (car (cdr (cdr x))))
  26. (define (cdaar x) (cdr (car (car x))))
  27. (define (cdadr x) (cdr (car (cdr x))))
  28. (define (cddar x) (cdr (cdr (car x))))
  29. (define (cdddr x) (cdr (cdr (cdr x))))
  30.  
  31. (define (caaaar x) (car (car (car (car x)))))
  32. (define (caaadr x) (car (car (car (cdr x)))))
  33. (define (caadar x) (car (car (cdr (car x)))))
  34. (define (caaddr x) (car (car (cdr (cdr x)))))
  35. (define (cadaar x) (car (cdr (car (car x)))))
  36. (define (cadadr x) (car (cdr (car (cdr x)))))
  37. (define (caddar x) (car (cdr (cdr (car x)))))
  38. (define (cadddr x) (car (cdr (cdr (cdr x)))))
  39. (define (cdaaar x) (cdr (car (car (car x)))))
  40. (define (cdaadr x) (cdr (car (car (cdr x)))))
  41. (define (cdadar x) (cdr (car (cdr (car x)))))
  42. (define (cdaddr x) (cdr (car (cdr (cdr x)))))
  43. (define (cddaar x) (cdr (cdr (car (car x)))))
  44. (define (cddadr x) (cdr (cdr (car (cdr x)))))
  45. (define (cdddar x) (cdr (cdr (cdr (car x)))))
  46. (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
  47.  
  48. ; (list obj ...)
  49.  
  50. (define (list . elems) elems)
  51.  
  52. ; (list? obj)  -- Defined below (after named lets are introduced).
  53.  
  54. ; (memq   obj list)
  55. ; (memv   obj list)
  56. ; (member obj list)
  57.  
  58.  
  59. (define (memq obj list)
  60.     (if (null? list) #f
  61.     (if (not (pair? list))
  62.         (error "2nd arg to memq not a list: " list)
  63.         (if (eq?  obj (car list)) list
  64.         (memq  obj (cdr list)) ))))
  65.  
  66.  
  67. (define (memv obj list)
  68.     (if (null? list) #f
  69.     (if (not (pair? list))
  70.         (error "2nd arg to memv not a list: " list)
  71.         (if (eqv?  obj (car list)) list
  72.         (memv  obj (cdr list)) ))))
  73.  
  74.  
  75. (define (member obj list)
  76.     (if (null? list) #f
  77.     (if (not (pair? list))
  78.         (error "2nd arg to member not a list: " list)
  79.         (if (equal?  obj (car list)) list
  80.         (member  obj (cdr list)) ))))
  81.  
  82.  
  83. ; (assq  obj alist)
  84. ; (assv  obj alist)
  85. ; (assoc obj alist)
  86.  
  87. (define (assq obj alist)
  88.     (if (null? alist) #f
  89.     (if (not (pair? alist))
  90.         (error "2nd argument to assq not a list: " alist)
  91.         (if (eq? (caar alist) obj) (car alist)
  92.         (assq obj (cdr alist))))))
  93.  
  94.  
  95. (define (assv obj alist)
  96.     (if (null? alist) #f
  97.     (if (not (pair? alist))
  98.         (error "2nd argument to assv not a list: " alist)
  99.         (if (eqv? (caar alist) obj) (car alist)
  100.         (assv obj (cdr alist))))))
  101.  
  102.  
  103. (define (assoc obj alist)
  104.     (if (null? alist) #f
  105.     (if (not (pair? alist))
  106.         (error "2nd argument to assoc not a list: " alist)
  107.         (if (equal? (caar alist) obj) (car alist)
  108.         (assoc obj (cdr alist))))))
  109.  
  110. ; Numbers
  111.  
  112. (define (number->string num . radix )
  113.     (#_number->string num (if (null? radix) 10 (car radix)) ))
  114.  
  115. (define (string->number str . radix )
  116.     (#_string->number str (if (null? radix) 0 (car radix)) ))
  117.  
  118. ; Strings
  119.  
  120. ; (make-string k)
  121. ; (make-string k char)
  122.  
  123. (define (make-string length . fill-char)
  124.         (if (null? fill-char)
  125.         (#_make-string length #\space)
  126.         (#_make-string length (car fill-char)) ) )
  127.  
  128. ; (string char ...)
  129.  
  130. (define (string . characters) (list->string characters))
  131.  
  132. ; Vectors
  133.  
  134. ; (make-vector k)
  135. ; (make-vector k fill)
  136.  
  137. (define (make-vector length . fill)    ; and extend it to handle default fill
  138.     (#_make-vector length (if (null? fill) (the-undefined-symbol) (car fill)) ))
  139.  
  140. ; (vector obj ...)
  141.  
  142. (define (vector . elems) (list->vector elems))
  143.  
  144.  
  145. ; Control Features 
  146.  
  147. ; (apply proc args)
  148. ; (apply proc arg1 ... args)
  149.  
  150. (define (#_collect args)
  151.    (if (null? (cdr args)) (car args) (cons (car args) (#_collect (cdr args)))))
  152.  
  153. (define (apply proc arg1 . args)
  154.    (#_apply proc (if (null? args) arg1 (#_collect (cons arg1 args)))))
  155.             
  156.  
  157. ; (map proc list1 list2 ...)
  158.  
  159. (define (map fn list . lists)
  160.     (if (null? lists) (#_map1 fn list)
  161.     (#_mapn fn (cons list lists))))
  162.  
  163. (define (#_map1 fn list)
  164.     (if (null? list) '()
  165.     (cons (fn (car list)) (#_map1 fn (cdr list)))))
  166.  
  167. (define (#_mapn fn lists)
  168.     (if (null? (car lists)) '()
  169.     (cons (#_apply fn (#_map1 car lists))
  170.           (#_mapn fn (#_map1 cdr lists)) )))
  171.  
  172. ; (for-each proc list1 list2 ...)
  173.  
  174. (define (for-each proc list . lists)
  175.     (if (null? lists) (#_for-each1 proc list)
  176.     (#_for-eachn proc (cons list lists))))
  177.  
  178. (define (#_for-each1 proc list)
  179.     (if (null? list) '()
  180.     (begin (proc (car list)) 
  181.            (#_for-each1 proc (cdr list)))))
  182.  
  183. (define (#_for-eachn proc lists)
  184.     (if (null? (car lists)) '()
  185.     (begin (#_apply proc (#_map1 car lists))
  186.            (#_for-eachn proc (#_map1 cdr lists)) )))
  187.  
  188.  
  189. ; Input and output (Ports)
  190.  
  191. ; (call-with-input-file string proc)  DEFINED BELOW
  192. ; (call-with-output-file string proc) DEFINED BELOW
  193.  
  194. ; (read)
  195. ; (read port)
  196. ; (read-char)
  197. ; (read-char port)
  198. ; (peek-char)
  199. ; (peek-char port)
  200. ; (char-ready?)
  201. ; (char-ready? port)
  202.  
  203. (define (read . port)
  204.     (#_read (if (null? port) (current-input-port) (car port))))
  205.  
  206. (define (read-char . port)
  207.     (#_read-char (if (null? port) (current-input-port) (car port))))
  208.  
  209. (define (peek-char . port)
  210.     (#_peek-char (if (null? port) (current-input-port) (car port))))
  211.  
  212. (define (char-ready? . port)
  213.     (#_char-ready? (if (null? port) (current-input-port) (car port))))
  214.  
  215. ; (write)
  216. ; (write port)
  217. ; (newline)
  218. ; (newline port)
  219. ; (write-char)
  220. ; (write-char port)
  221.  
  222. (define (write obj . port)    ; and extend them to have default ports
  223.     (#_write obj (if (null? port) (current-output-port) (car port))))
  224.  
  225. (define (display obj . port)
  226.     (#_display obj (if (null? port) (current-output-port) (car port))))
  227.  
  228. (define (newline . port)
  229.     (if (null? port) (write-char #\newline (current-output-port))
  230.     (write-char #\newline (car port)) ))
  231.  
  232. (define (write-char obj . port)
  233.     (#_write-char obj (if (null? port) (current-output-port) (car port))))
  234.  
  235.  
  236. ; (with-input-from-file string thunk)     DEFINED BELOW
  237. ; (with-output-to-file string thunk)    DEFINED BELOW
  238.  
  239. ; DERIVED EXPRESSION TYPES
  240.  
  241. ; (quasi-quote <template>)
  242. ; `<template>  ==>  (quasiquote <template>) in (read)
  243.  
  244. (macro quasiquote
  245.     (lambda (form)
  246.     (#_quasiquote (cadr form))))
  247.  
  248. (define (#_quasiquote skel)
  249.    (if (vector? skel) (list 'list->vector (#_quasiquote (vector->list skel)))
  250.        (if (null? skel) ''()
  251.        (if (symbol? skel) (list 'quote skel)
  252.            (if (not (pair? skel)) skel
  253.            (if (eq? (car skel) 'unquote) (cadr skel)
  254.                (if (eq? (car skel) 'quasiquote)
  255.                (#_quasiquote (#_quasiquote (cadr skel)))
  256.                (if (if (pair? (car skel))
  257.                    (eq? (caar skel) 'unquote-splicing) #f)
  258.                 (list 'append (cadar skel)
  259.                               (#_quasiquote (cdr skel)))
  260.                         (#_combine-skels (#_quasiquote (car skel))
  261.                          (if (null? (cdr skel)) '()
  262.                              (#_quasiquote (cdr skel)))
  263.                          skel)
  264.                ))))))))
  265.  
  266.  
  267. (define (#_combine-skels lft rgt skel)
  268.     (if (if (#_isconst? lft) (#_isconst? rgt) #f) (list 'quote skel)
  269.         (if (null? rgt) (list 'list lft)
  270.         (if (if (pair? rgt) (eq? (car rgt) 'list) #f)
  271.         (cons 'list (cons lft (cdr rgt)))
  272.         (list 'cons lft rgt)
  273.         ))))
  274.  
  275.     
  276. (define (#_isconst? obj)
  277.     (if (pair? obj) (eq? (car obj) 'quote) #f))
  278.  
  279.  
  280. ; (defmacro (key name) ...) => (macro key (lambda (name) ...))
  281.  
  282. (macro defmacro 
  283.     (lambda (x)
  284.     `(macro ,(caadr x) (lambda (,(cadadr x)) ,@(cddr x))) ))
  285.  
  286. (defmacro (let form)
  287.     (if (symbol? (cadr form))
  288.  
  289.     ; a named let
  290.     ; (let v0 ((v1 e1) ...) . body)
  291.     ;   =>
  292.     ; ((letrec ((v0 (lambda (v1 ...) . body)))
  293.     ;    v0)
  294.     ;  e1 ...)
  295.  
  296.     `((letrec ((,(cadr form) (lambda ,(#_map1 car (caddr form)) 
  297.                             ,@(cdddr form) )))
  298.         ,(cadr form))
  299.         ,@(#_map1 cadr (caddr form)) )
  300.  
  301.     ; a regular let
  302.     ; (let ((v1 e1) ...) . body)
  303.     ;   =>
  304.     ; ((lambda (v1 ...) . body) e1 ...)
  305.  
  306.     `(  (lambda ,(#_map1 car (cadr form)) ,@(cddr form))
  307.         ,@(#_map1 cadr (cadr form))) ))
  308.  
  309.  
  310. ; (and)       => #t
  311. ; (and e1)       => e1
  312. ; (and e1 e2 ...) =>
  313. ;     (let ((x e1)
  314. ;               (thunk (lambda()(and e2...))))
  315. ;        (if x (thunk) x))
  316.  
  317. (defmacro (and form)     
  318.     (if (null? (cdr