Enter your search terms Submit search form
	Web pdp-10.trailing-edge.com

(in-package 'clc)

(defun cg-progn-body (forms where)
  (if (atom forms)
      (cg-form nil where)		; Empty body
      (do ((f forms (cdr f)))           ; Normal progn
	  ((atom (cdr f))
	   (cg-form (car f) where))	; return value of last form
	(cg-form (car f) nil))))

(defun cg-form (form where)
  (let* (fn temp)
    (setq form (transform form))
    (cond ((atom form) (cg-atomic form where))
	  ((eq (setq fn (car form)) 'quote)
	   (cg-constant (cadr form) where))
	  ;; Is there a special code generator for this form?
	  ((setq temp (get fn 'cg))
	   (funcall temp form where))
	  ;; Known to be an expr?
	  ((eq (setq temp (get fn 'declared-function-type)) 'expr)
	   (cg-expr-call form where))
	  ;; Else, assume that it is an expr.
	  (t (assume-expr fn (length (cdr form)))
	     (cg-expr-call form where)))))

(defun fix-qrefs ()
  (setq *temps* (nreverse *temps*))
  (let ((n (length *temps*)))
    (do* ((lc lap-code (cdr lc))
	  (inst (car lc) (car lc))
	  (opcode (car inst) (car inst))
	  (reg (cadr inst) (cadr inst))
	  (loc (caddr inst) (caddr inst))
	  (offreg (cadddr inst) (cadddr inst)))
	 ((null (cdr lc)))
	 (cond ((eq opcode 'alloc)
		(setf (car lc) `(adjsp q ,(- n reg))))
	       ((eq opcode 'dealloc)
		(setf (car lc) `(adjsp q ,(- n))))
	       ((numberp offreg)
		(setf (caddr inst) (- offreg (position loc *temps*)))
		(setf (cadddr inst) 'q))
	       ((and loc (symbolp loc) (stakp loc))
		(error "missing qref in ~S" inst))))))

(defun compile-one-lambda (form)
  (let* ((lap-code (list '(code-start)))
	 (entry-points nil)
	 (constants-list nil)
	 (nconstants 0)
	 (*restp* nil)
	 (*label-counter* 0)
	 (closed-var-count-list (cons 0 closed-var-count-list))
	 (closure-vector-home nil)
	 (old-error-count error-count)
	 (vars-griped-about nil)
	 (arglist (cadr form))
	 (*temps* (list (gensym "TEMP")))
	 (*free-temps* *temps*)
	 (*xstemps* nil)
	 (max-args 0)
	 (min-args 0)
	 (*nargs-on-stack* 0)
	 (body (parse-body1 (cddr form)))
	 (decls (car body))
	 (doc (cadr body)))
    (setq body (caddr body))
    (if (and (= function-level 0)
	     (not (and (eq (car body) 'block) (eq (cadr body) function-name))))
	(setq body `(block ,function-name ,@body))
	(setq body `(progn ,@body)))
    (when doc
      (process-random `(%put ',function-name 'lisp::%fun-documentation ',doc)))
    (binding-contour decls
      (cg-lambda-list arglist)
      (cg-form body 'tail)
      (unless (zerop (cdr (assq 'specbind *benv*)))
	      (inst-out `(unbind ,(cdr (assq 'specbind *benv*)))))
      (inst-out `(dealloc ,(length *temps*)))
      (inst-out '(popj p))
      (setq lap-code (nreverse lap-code))
      ;; NOTE: add to plist for testing purposes.  DKS
      (setf (get function-name 'pss1)
	    (make-lap-function (copy-tree lap-code)))
      (optimize)
      (fix-qrefs)
      (setq entry-points (nreverse entry-points))
      (setq constants-list (nreverse constants-list))
      (setq unknown-functions (delq function-name unknown-functions))
      (check-used)
      (if (eq function-type 'closure)
	  (setq function-type 'expr))
      (unless (eq function-type 'one-shot)
	      (note-type function-name function-type))
      (setq lap-code (make-lap-function lap-code))
      (if *clc-lap-stream* (laprint lap-code *clc-lap-stream*))
;; [don't] output fasl-file
;     (if *clc-fasl-stream* (make-fasl lap-code))
      (if *compile-to-lisp* (eval lap-code)
	  (push lap-code *internal-functions*))
      nil)))