;;;-*- Mode:Scheme; Package:Scheme; Base:10; Fonts:(CPTFONT HL12 HL12BI CPTFONTB) -*-

2;;;*	2Explorer Scheme functions implemented in Scheme.

1;; This file has type **".LISP"1 instead of *".SCHEME"1 so that *MAKE-SYSTEM1 will 
;; know what to do with it.  The mode line assures that it really will be 
;; compiled in Scheme mode.

;; Revision:
;;  2/12/88 DNG - Original.
;;  4/16/88 DNG - Added *%structure-predicate1 and *%make-structure1 (runtime 
;;		support for structures).*

;; ---------
;;;   Lifted from file "pchreq.s" - "Last Revision:  3-Sep-85 1500ct"

							; SUBSTRING-MOVE-LEFT! 
(define (substring-move-left! string1 start1 end1 string2 start2)
  (when (< start1 end1)
    (string-set! string2 start2
		 (string-ref string1 start1))
    (substring-move-left!
      string1 (1+ start1) end1 string2 (1+ start2))))


(define substring-move-right!			   ; SUBSTRING-MOVE-RIGHT!
  (lambda (string1 start1 end1 string2 start2)
    (letrec ((loop
	       (lambda (count1 count2)
		 (when (<= start1 count1)
		   (string-set! string2 count2
				(string-ref string1 count1))
		   (loop (-1+ count1) (-1+ count2)))))
	     (end2 (+ start2 (- end1 start1)))
	     )
      (loop (-1+ end1) (-1+ end2)))))

;; ---------
;;;  Lifted from file "pdefstr.s" - "Last Revision:  30-Aug-85 1900ct"
;;;  and modified slightly for efficiency.

;;; Global function used to generate predicates for all structures

(define %structure-predicate                            ; %STRUCTURE-PREDICATE
  (lambda (object tag)
    (and (vector? object)
         (positive? (vector-length object))
         (si:member-equal tag (vector-ref object 0))
         #!true)))

;;; %MAKE-STRUCTURE is used by all structures to create an instance

(define %make-structure                                 ; %MAKE-STRUCTURE
  (lambda (name constructor-name structure init-list)
    (let ((slot-number
	    (lambda (slot slot-values constructor-name)
	      (apply-if (assq slot slot-values)
			cadr
			(error (string-append
				 "Structure component unknown to "
				 (lisp:symbol-name constructor-name))
			       slot)))))
      (let ((slots (getprop name '%SLOT-VALUES)))
        (do ((structure structure)
             (init-msg init-list (cddr init-msg)))
            ((null? init-msg) structure)
          (vector-set! structure
                       (slot-number (car init-msg) slots constructor-name)
                       (cadr init-msg)))))))