DataMuseum.dk

top - download

    Length: 4292 (0x10c4)
    Types: TextFile
    Names: »adapt.scm.4«

└─⟦a0efdde77⟧ Bits:30001252 EUUGD11 Tape, 1987 Spring Conference Helsinki
    └─ ⟦this⟧ »EUUGD11/gnu-31mar87/scheme/scm/adapt.scm.4« 

TextFile

;;; -*-Scheme-*-
;;;
;;;	Copyright (c) 1984 Massachusetts Institute of Technology
;;;
;;;	This material was developed by the Scheme project at the
;;;	Massachusetts Institute of Technology, Department of
;;;	Electrical Engineering and Computer Science.  Permission to
;;;	copy this software, to redistribute it, and to use it for any
;;;	purpose is granted, subject to the following restrictions and
;;;	understandings.
;;;
;;;	1. Any copy made of this software must include this copyright
;;;	notice in full.
;;;
;;;	2. Users of this software agree to make their best efforts (a)
;;;	to return to the MIT Scheme project any improvements or
;;;	extensions that they make, so that these may be included in
;;;	future releases; and (b) to inform MIT of noteworthy uses of
;;;	this software.
;;;
;;;	3.  All materials developed as a consequence of the use of
;;;	this software shall duly acknowledge such use, in accordance
;;;	with the usual standards of acknowledging credit in academic
;;;	research.
;;;
;;;	4. MIT has made no warrantee or representation that the
;;;	operation of this software will be error-free, and MIT is
;;;	under no obligation to provide any services, by way of
;;;	maintenance, update, or otherwise.
;;;
;;;	5.  In conjunction with products arising from the use of this
;;;	material, there shall be no use of the name of the
;;;	Massachusetts Institute of Technology nor of any adaptation
;;;	thereof in any advertising, promotional, or sales literature
;;;	without prior written consent from MIT in each case.
;;;

;;;; Some compatibility definitions

(declare (usual-integrations))
\f


(define false #!FALSE)
(define true #!TRUE)
(define nil '())
(define t #!TRUE)
(define last last-pair)
(define (last-car x) (car (last-pair x)))
(define (last-cdr x) (cdr (last-pair x)))
(define (nth n l) (list-ref l n))
(define (nthcdr n l) (list-tail l n))
(define list* cons*)
(define list-to-vector list->vector)
(define string-to-list string->list)
(define vector-to-list vector->list)
(define copy-vector vector-copy)
(define copy-list list-copy)
(define string-length string-size)
(define hunk3-cons (make-primitive-procedure 'HUNK3-CONS))
(define hunk3-cxr (make-primitive-procedure 'HUNK3-CXR))
(define hunk3-set-cxr! (make-primitive-procedure 'HUNK3-SET-CXR!))
(define user-memq (member-procedure eq?))
(define user-assq (association-procedure eq? car))

(define (print-depth #!optional amount)
  (cond ((unassigned? amount)
	 *unparser-list-depth-limit*)
	((disjunction (not amount)
		      (conjunction (integer? amount)
				   (> amount 0)))
	 (set! *unparser-list-depth-limit* amount))
	(else
	 (error "Bad argument" 'PRINT-DEPTH amount))))

(define (print-breadth #!optional amount)
  (cond ((unassigned? amount)
	 *unparser-list-breadth-limit*)
	((disjunction (not amount)
		      (conjunction (integer? amount)
				   (> amount 0)))
	 (set! *unparser-list-breadth-limit* amount))
	(else
	 (error "Bad argument" 'PRINT-BREADTH amount))))
\f


(define (atom? x)
  (not (pair? x)))

(define (applicable? x)
  (disjunction (procedure? x)
	       (continuation? x)))

;; Fuck this shit.
(define system-properties '())

(define first-tail cdr)
(define (second-tail  x) (general-car-cdr x #b111))
(define (third-tail   x) (general-car-cdr x #b1111))
(define (fourth-tail  x) (general-car-cdr x #b11111))
(define (fifth-tail   x) (general-car-cdr x #b111111))
(define (sixth-tail   x) (general-car-cdr x #b1111111))
(define (seventh-tail x) (general-car-cdr x #b11111111))
(define (eighth-tail  x) (general-car-cdr x #b111111111))

(define lambda-name)
(define lambda-required)
(define lambda-optional)
(define lambda-rest)
(define lambda-auxiliary)
(define lambda-body)

(let ((lambda-component
       (lambda ((selector) x)
	 (lambda-components x selector))))
  (set! lambda-name
	(lambda-component (lambda (name req opt rest aux body) name)))
  (set! lambda-required
	(lambda-component (lambda (name req opt rest aux body) req)))
  (set! lambda-optional
	(lambda-component (lambda (name req opt rest aux body) opt)))
  (set! lambda-rest
	(lambda-component (lambda (name req opt rest aux body) rest)))
  (set! lambda-auxiliary
	(lambda-component (lambda (name req opt rest aux body) aux)))
  (set! lambda-body
	(lambda-component (lambda (name req opt rest aux body) body))))