Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/schmlbrr/schem_lb.lha/unsupported/CScheme/misc.scm

Text File | 1991-08-05 | 9.4 KB | 376 lines

;;; -*- Base: 10; Mode: Scheme; Syntax: MIT Scheme; Package: USER -*-
;;
;; MISC.SCM
;;
;; July 1, 1991
;; Minghsun Liu
;;
;; Some miscellenous definitions.  (Actually, this file contains many
;; constructs that do iterations.)
;;
;;
;; The following(s) are(is) defined:
;;
;; (PUSH ITEM PLACE)
;; (MAPCAN FUNC A-LIST . MORE-LIST)
;; (WHEN TEST . FORM)
;; (LOOP . FORM)
;; (DOTIMES VAR COUNTFORM #!OPTIONAL RESULTFORM . PROGBODY)
;; (UNLESS TEST . FORM)
;; (DOLIST ITER-FORM . BODY)
;; (DO* ITERFORM ENDFORM . PROGBODY)
;; (PSETQ . ASSIGN)
;; (PROG1 . PROGBODY)
;; (PROG1-PSETQ . PROGBODY)
;; (SETQ VAR FORM)
;; (SETQQ VAR FORM)
;; (CL-STRING X)
;; (ATOM?  OBJ)
;; (SETF PLACE ITEM)
;; (SET SYM VAL)
;; (READ-LINE)
;; (CL-LENGTH OBJ)
;; (MAP-VEC VECTORS)
;; (FUNCALL FUN . ARGS)
;; (COMPILE PROC-NAME BODY)
;; (PRINT STATEMENT)
;;
(declare (usual-integrations))

;;
;; (PUSH ITEM PLACE)
;;
;; destrutively push an object onto the front of a list and returns the
;; value stored in the location specified by PLACE with ITEM consed in
;; front of it.  PLACE have to be considered a "good target" by set!.
;; (i.e. This is not an exact equivalent of PUSH in CL.)
;;
(defmacro (push item place)
  (let ((temp-var (generate-uninterned-symbol 'push)))
    `(let ((,temp-var ,place))
       (setf ,place (cons ,item ,temp-var)))))

;;
;; (MAPCAN FUNC A-LIST . MORE-LIST)
;;
;; is similar to MAPCAR but uses APPEND! instead.
;;
(defmacro (mapcan func a-list #!rest more-list)
  `(apply append! (mapcar func a-list ,@more-list)))

;;
;; (WHEN TEST . FORM)
;;
;; evaluate forms when a condition is true.
;;
(defmacro (when test #!rest form)
  `(if ,test
       (begin ,@form)
       '()))

;;
;; (LOOP . FORM)
;;
;; loop through forms repeatedly.
;;
(defmacro (loop #!rest forms)
  (let ((repeat-till-drop (generate-uninterned-symbol 'loop)))
    `(call-with-current-continuation
      (lambda (exit)
    (let ((return (lambda (#!rest opt-arg)
            (if (default-object? opt-arg)
                (exit '())
                (exit opt-arg)))))
      (define (,repeat-till-drop)
        ,@forms
        (,repeat-till-drop))
      (,repeat-till-drop))))))

;;
;; (DOTIMES VAR COUNTFORM RESULTFORM . PROGBODY)
;;
;; iterate over PROGBODY depend COUNTFORM which should produce an
;; integer.
;;
(defmacro (dotimes mainbody #!rest progbody)
  (let ((dotimes-loop (generate-uninterned-symbol 'dotimes))
    (temp-var (generate-uninterned-symbol)))
    `(call-with-current-continuation
      (lambda (exit)
    (let ((return (lambda (#!optional opt-arg)
            (if (default-object? opt-arg)
                (exit '())
                (exit opt-arg)))))
      (let ,dotimes-loop
          ((,(car mainbody) 0)
           (,temp-var ,(cadr mainbody)))
        (cond ((<= ,temp-var ,(car mainbody))
           (return ,@(cddr mainbody)))
          (else
           ,@progbody
           (,dotimes-loop (1+ ,(car mainbody)) ,temp-var)))))))))

;;
;; (UNLESS TEST . FORM)
;;
;; FORMS are evaluate only when TEST returns NIL.
;;
(defmacro (unless test #!rest forms)
  `(if ,test
       #f
       (begin ,@forms)))

;;
;; (DOLIST ITER-FORM . BODY)
;;
;; iterates over the elements of a list.
;;
(defmacro (dolist iter-form #!rest body)
  (let ((var (car iter-form))
    (list-form (cadr iter-form))
    (result (if (null? (cddr iter-form))
            '()
            (caddr iter-form))))
    `(call-with-current-continuation
      (lambda (exit)
    (let ((return (lambda (#!rest opt-args) (exit opt-args))))
      (for-each (lambda (,var)
              ,@body)
            ,list-form)
      ,result)))))

;;
;; (DO* ITERFORM ENDFORM . PROGBODY)
;;
;; iterates until test condition is met.
;;
;; P.S. Again, this is hackish and relatively expensive because of all
;; the eval that it's doing but can't think of anything else right now.
;;
(defmacro (do* iterform endform #!rest progbody)
  (let ((do-ast-loop (generate-uninterned-symbol 'do-star))
    (test (car endform))
    (result (if (null? (cdr endform))
            (list '())
            (cdr endform))))
    `(call-with-current-continuation
      (lambda (exit)
    (let ((return (lambda (#!optional opt-arg)
            (if (default-object? opt-arg)
                (exit '())
                (exit opt-arg)))))
      (let* ,(map (lambda (exp)
            (list (car exp) (cadr exp)))
              iterform)
        (define (,do-ast-loop)
          (if ,test
           (return (begin ,@result))
           (begin ,@progbody
              ,@(map
                 (lambda (exp)
                   (if (not (null? (cddr exp)))
                   `(set! ,(car exp) ,(caddr exp))))
                 iterform)
              (,do-ast-loop))))
        (,do-ast-loop)))))))

;;
;; (PSETQ . ASSIGN)
;;
;; is intended to simulate PSETQ in CL which does parralle variable
;; assignment.
;;
(defmacro (psetq #!rest assign)
  (let ((temp-var (generate-uninterned-symbol 'psetq)))
    (define (transform assignments)
      (if (null? (cddr assignments))
      (list 'setq (car assignments) (cadr assignments))
      (list 'setq
        (car assignments)
        (list 'prog1-psetq
              (cadr assignments)
              (transform (cddr assignments))))))
    (if (null? assign)
    '()
    `((lambda (,temp-var) ,(transform assign) ,temp-var) '()))))

;;
;; (PROG1 . PROGBODY)
;;
;; evalutes the PROGBODY sequentially, returning exactly one value
;; from the first.
;;
(defmacro (prog1 #!rest progbody)
  (let ((temp-var1 (generate-uninterned-symbol 'prog1)))
    `(call-with-current-continuation
      (lambda (exit)
    (let ((return (lambda (#!optional opt-arg)
            (exit (if (default-object? opt-arg)
                  '()
                  opt-arg)))))
      (let ((,temp-var1 ,(car progbody)))
        ,@(cdr progbody)
        (return ,temp-var1)))))))

;;
;; (PROG1-PSETQ . PROGBODY)
;;
;; evalutes the PROGBODY sequentially, returning exactly one value
;; from the first.  (Same as PROG1-AUX but does not provide RETURN and
;; only two statements at a time only.)
;;
(defmacro (prog1-psetq #!rest progbody)
  `(let ()
     ,(cadr progbody)
     ,(car progbody)))

;;
;; (SETQ VAR FORM) & (SETQQ VAR FORM)
;;
;; It directly manipulates the environment structure to simulate the
;; effect of SETQ in CL: to change the value of the binding of
;; a local variable or the value of the dynamic binding (or global
;; value if there is not binding) of VAR.  (SETQQ is the complete
;; implementation.)
;;
;; P.S. For all practical purposes, one assignment at a time is enough
;; so this is what is currently supported.
;;
(defmacro (setq var form)
  (let ((temp-val (generate-uninterned-symbol 'setq)))
    `(let ((,temp-val ,form))
       (set! ,var ,temp-val)
       ,temp-val)))

(defmacro (setqq var form)
  (let ((temp-val (generate-uninterned-symbol 'setq))
    (temp-sym (generate-uninterned-symbol 'setq)))
    `(let ((,temp-val ,form)
       (,temp-sym ',var))
       (if (environment-bound? (make-environment) ,temp-sym)
       (set! ,var ,temp-val)
       (local-assignment user-initial-environment ,temp-sym ,temp-val))
       ,temp-val)))

;;
;; (CL-STRING X)
;;
;; converts a symbol or string character X to a string.
;;
(define (cl-string x)
  (cond ((symbol? x) (symbol->string x))
    ((char? x) (string x))
    ((string? x) x)
    (else '())))


;;
;; (SETF PLACE ITEM) & (SETF-AUX PLACE ITEM)
;;
;; tries to implement some of the functionality of SETF of CL in MIT Scheme.
;;
(defmacro (setf place item)
  (let ((temp (generate-uninterned-symbol 'setf)))
    (cond ((atom? place)
       `(setq ,place ,item))  ;; simple case.
      (else
       `(let ((,temp ,item))
          (,(symbol-append 'set- (car place) '!) ,(cadr place) ,temp)
          ,temp)))))

;;
;; (ATOM? OBJ)
;;
;; an atom, in the CL sense, is anything that is not a pair.
;;
(define (atom? obj)
  (not (pair? obj)))

;;
;; (SET SYM VAL) & (SET-AUX SYM VAL)
;;
;; unquoted assignment statement.
;;
(defmacro (set sym val)
  `(set-aux ,sym ,val))

(define (set-aux sym val)
  (if (atom? sym)
      (local-assignment user-initial-environment sym val)  ;; when it's (car '(a b c))
      (local-assignment user-initial-environment (cadr sym) val))  ;; when it's (quote a)
  val)

;;
;; (READ-LINE)
;;
;; read characters terminated by newline.
;;
(define (read-line)
  (read-string (char-set #\newline #\linefeed #\return)))

;;
;; (CL-LENGTH OBJ)
;;
;; is the all powerful length-measuring procedure.
;;
(define (cl-length obj)
  (cond ((array? obj) (vector-length (just-the-array-maam obj)))
    ((vector? obj) (vector-length obj))
    ((list? obj) (length obj))
    ((string? obj) (string-length? obj))
    (else (error "CL-LENGTH: Not a sequence" obj))))

;;
;; (MAP-VEC FUNC VECTORS)
;;
;; extends the functionality of MAP to include not only elements of a
;; list but of vectors.  The results are returned stored in a vector
;; And for now, it can only map over one vector at a time.
;;
(define (map-vec func vectors)
  (let ((vector-leng (vector-length vectors)))
    (define (map-vec-aux func index)
      (if (> 0 index)
      '()
      (begin
        (cons (apply func (list (vector-ref vectors index)))
          (map-vec-aux func (-1+ index))))))
    (list->vector (map-vec-aux func (-1+ vector-leng)))))

;;
;; (FUNCALL FUN . ARGS)
;;
;; simulates the function FUNCALL in CL.
;;
(define (funcall fun #!rest args)
  (apply fun args))

;;
;; (CL-COMPILE PROC-NAME BODY)
;;
;; compiles BODY.  (BODY can be a procedure name or lambda list.)  If name is not '(),
;; the compiled procedure will be given the name NAME.
;;
(define (compile proc-name body debug?)
  (if (not (procedure? body))
      (set! body (eval body (the-environment))))
  (if debug?
      body
      (if proc-name
      (local-assignment user-initial-environment
                proc-name
                (compile-procedure body))
      (compile-procedure body))))

;;
;; (PRINT STATEMENT)
;;
;; simulates the PRINT in CL.
;;
(defmacro (print statement)
  (let ((print-this (generate-uninterned-symbol 'print)))
    `(let ((,print-this ,statement))
       (write-line ,print-this)
       ,print-this)))