;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   This file is part of Opensourced MCL.
;;;
;;;   Opensourced MCL is free software; you can redistribute it and/or
;;;   modify it under the terms of the GNU Lesser General Public
;;;   License as published by the Free Software Foundation; either
;;;   version 2.1 of the License, or (at your option) any later version.
;;;
;;;   Opensourced MCL is distributed in the hope that it will be useful,
;;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;   Lesser General Public License for more details.
;;;
;;;   You should have received a copy of the GNU Lesser General Public
;;;   License along with this library; if not, write to the Free Software
;;;   Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
;;;


(in-package :ccl)


;;; Compiler functions needed elsewhere

; used-by: backtrace, fred-additions
(defun function-symbol-map (fn)
  (getf (%lfun-info fn) 'function-symbol-map))

; used-by: backtrace, disasm, lap
; This is supposed to return the number of words in all maps attached to the lfun vector.
; It doesn't typecheck its argument, 'cause I'm too lazy.


(defun %lfun-info (fn)
  (and (compiled-function-p fn)
       (let ((bits (lfun-bits fn)))
         (declare (fixnum bits))
         (and (logbitp $lfbits-symmap-bit bits)
              (%svref fn (%i- (uvsize fn)
                              (if (logbitp $lfbits-noname-bit bits) 2 3)))))))

(defun uncompile-function (fn)
  (getf (%lfun-info fn) 'function-lambda-expression ))


;;; Lambda-list utilities

; We should handle/encode (&allow-other-keys) w/o keywords - might tell the compiler
; or user something.
; We should think harder before writing bogus & misleading comments.
; Tar is not a plaything.

(defun encode-lambda-list (l &optional return-keys?)
  (multiple-value-bind (ok req opttail resttail keytail auxtail)
                       (verify-lambda-list l)
    (when ok
      (let* ((bits 0)
             (temp nil)
             (nreq (length req))
             (num-opt 0)
             (rest nil)
             (lexpr nil)
             (keyp nil)
             (key-list nil)
             (aokp nil)
             (hardopt nil))
        (when (> nreq #.(ldb $lfbits-numreq $lfbits-numreq))
          (return-from encode-lambda-list nil))
        (when (eq (pop opttail) '&optional)
          (until (eq opttail resttail)
            (when (and (consp (setq temp (pop opttail)))
                       (%cadr temp))
              (setq hardopt t))
            (setq num-opt (%i+ num-opt 1))))
        (when (eq (%car resttail) '&rest)
          (setq rest t))
        (when (eq (%car resttail) '&lexpr)
          (setq lexpr t))
        (when (eq (pop keytail) '&key)
          (setq keyp t)
          (labels ((ensure-symbol (x)
                     (if (symbolp x) x (return-from encode-lambda-list nil)))
                   (ensure-keyword (x)
                     (make-keyword (ensure-symbol x))))
            (declare (dynamic-extent #'ensure-symbol #'ensure-keyword))
            (until (eq keytail auxtail)
              (setq temp (pop keytail))
              (if (eq temp '&allow-other-keys)
                (progn
                  (setq aokp t)
                  (unless (eq keytail auxtail)
                    (return-from encode-lambda-list nil)))
                (when return-keys?
                  (push (if (consp temp)
                          (if (consp (setq temp (%car temp))) 
                            (ensure-symbol (%car temp))
                            (ensure-keyword temp))
                          (ensure-keyword temp))
                        key-list))))))
        (when (%i> nreq (ldb $lfbits-numreq -1))
          (setq nreq (ldb $lfbits-numreq -1)))
        (setq bits (dpb nreq $lfbits-numreq bits))
        (when (%i> num-opt (ldb $lfbits-numopt -1))
          (setq num-opt (ldb $lfbits-numopt -1)))
        (setq bits (dpb num-opt $lfbits-numopt bits))
        (when hardopt (setq bits (%ilogior (%ilsl $lfbits-optinit-bit 1) bits)))
        (when rest (setq bits (%ilogior (%ilsl $lfbits-rest-bit 1) bits)))
        (when lexpr (setq bits (%ilogior (%ilsl $lfbits-restv-bit 1) bits)))
        (when keyp (setq bits (%ilogior (%ilsl $lfbits-keys-bit 1) bits)))
        (when aokp (setq bits (%ilogior (%ilsl $lfbits-aok-bit 1) bits)))
        (if return-keys?
          (values bits (apply #'vector (nreverse key-list)))
          bits)))))

;;; Lambda-list verification:

; these things MUST be compiled.
(eval-when (load)

(defvar *structured-lambda-list* nil)

(defun pair-arg-p (thing &optional lambda-list-ok supplied-p-ok keyword-nesting-ok)
  (or (symbol-arg-p thing lambda-list-ok) ; nil ok in destructuring case
      (and (consp thing)
           (or (null (%cdr thing))
               (and (consp (%cdr thing))
                    (or (null (%cddr thing))
                        (and supplied-p-ok
                             (consp (%cddr thing))
                             (null (%cdddr thing))))))
           (if (not keyword-nesting-ok)
             (req-arg-p (%car thing) lambda-list-ok)
             (or (symbol-arg-p (%car thing) lambda-list-ok)
                 (and (consp (setq thing (%car thing)))
                      (consp (%cdr thing))
                      (null (%cddr thing))
                      (%car thing)
                      (symbolp (%car thing))
                      (req-arg-p (%cadr thing) lambda-list-ok)))))))

(defun opt-arg-p (thing &optional lambda-ok)
  (pair-arg-p thing lambda-ok t nil))

(defun key-arg-p (thing &optional lambda-ok)
  (pair-arg-p thing lambda-ok t t))

(defun proclaimed-ignore-p (sym)
  (cdr (assq sym *nx-proclaimed-ignore*)))

(defun req-arg-p (thing &optional lambda-list-ok)
 (or
  (symbol-arg-p thing lambda-list-ok)
  (lambda-list-arg-p thing lambda-list-ok)))

(defun symbol-arg-p (thing nil-ok)
  (and
   (symbolp thing)
   (or thing nil-ok)
   (not (memq thing lambda-list-keywords))))

(defun lambda-list-arg-p (thing lambda-list-ok)
  (and 
   lambda-list-ok
   (listp thing)
   (if (verify-lambda-list thing t t)
     (setq *structured-lambda-list* t))))

(defun verify-lambda-list (l &optional destructure-p whole-p env-p)
  (let* ((the-keys lambda-list-keywords)
         opttail
         resttail
         keytail
         allowothertail
         auxtail
         safecopy
         whole
         m
         n
         req
         sym
         (*structured-lambda-list* nil))
  (prog ()
    (multiple-value-setq (safecopy whole)
                         (normalize-lambda-list l whole-p env-p))
    (unless (or destructure-p (eq l safecopy) (go LOSE)))
    (setq l safecopy)
    (unless (dolist (key the-keys t)
              (when (setq m (cdr (memq key l)))
                (if (memq key m) (return))))
      (go LOSE))
    (if (null l) (go WIN))
    (setq opttail (memq '&optional l))
    (setq m (or (memq '&rest l)
                (unless destructure-p (memq '&lexpr l))))
    (setq n (if destructure-p (memq '&body l)))
    (if (and m n) (go LOSE) (setq resttail (or m n)))
    (setq keytail (memq '&key l))
    (if (and (setq allowothertail (memq '&allow-other-keys l))
             (not keytail))
      (go LOSE))
    (if (and (eq (car resttail) '&lexpr)
             (or keytail opttail))
      (go lose))
    (setq auxtail (memq '&aux l))
    (loop
      (when (null l) (go WIN))
      (when (or (eq l opttail)
                (eq l resttail)
                (eq l keytail)
                (eq l allowothertail)
                (eq l auxtail))
        (return))
      (setq sym (pop l))
      (unless (and (req-arg-p sym destructure-p)
                   (or (proclaimed-ignore-p sym)
                       (and destructure-p (null sym))
                       (not (memq sym req))))  ; duplicate required args
        (go LOSE))
      (push sym req))
    (when (eq l opttail)
      (setq l (%cdr l))
      (loop
        (when (null l) (go WIN))
        (when (or (eq l resttail)
                  (eq l keytail)
                  (eq l allowothertail)
                  (eq l auxtail))
          (return))
        (unless (opt-arg-p (pop l) destructure-p)
          (go LOSE))))
    (when (eq l resttail)
      (setq l (%cdr l))
      (when (or (null l)
                (eq l opttail)
                (eq l keytail)
                (eq l allowothertail)
                (eq l auxtail))
        (go LOSE))
      (unless (req-arg-p (pop l) destructure-p) (go LOSE)))
    (unless (or (eq l keytail)  ; allowothertail is a sublist of keytail if present
                (eq l auxtail))
      (go LOSE))
    (when (eq l keytail)
      (pop l)
      (loop
        (when (null l) (go WIN))
        (when (or (eq l opttail)
                  (eq l resttail))
          (go LOSE))
        (when (or (eq l auxtail) (setq n (eq l allowothertail)))
          (if n (setq l (%cdr l)))
          (return))
        (unless (key-arg-p (pop l) destructure-p) (go LOSE))))
    (when (eq l auxtail)
      (setq l (%cdr l))
      (loop
        (when (null l) (go WIN))
        (when (or (eq l opttail)
                  (eq l resttail)
                  (eq l keytail))
          (go LOSE))
        (unless (pair-arg-p (pop l)) (go LOSE))))
    (when l (go LOSE))
  WIN
  (return (values
           t
           (nreverse req)
           (or opttail resttail keytail auxtail)
           (or resttail keytail auxtail)
           (or keytail auxtail)
           auxtail
           safecopy
           whole
           *structured-lambda-list*))
  LOSE
  (return (values nil nil nil nil nil nil nil nil nil nil)))))

(defun normalize-lambda-list (x &optional whole-p env-p)
  (let* ((y x) whole env envtail head)
    (setq
     x
     (loop
       (when (atom y)
         (if (or (null y) (eq x y))  (return x))
         (setq x (copy-list x) y x)
         (return
          (loop
            (when (atom (%cdr y))
              (%rplacd y (list '&rest (%cdr y)))
              (return x))
            (setq y (%cdr y)))))
       (setq y (%cdr y))))
    (when env-p
      ; Trapped in a world it never made ... 
      (when (setq y (memq '&environment x))
        (setq envtail (%cddr y)
              env (%cadr y))
        (cond ((eq y x)
               (setq x envtail))
              (t
               (dolist (v x)
                 (if (eq v '&environment)
                   (return)
                   (push v head)))
               (setq x (nconc (nreverse head) envtail) y (%car envtail))))))
    (when (and whole-p 
               (eq (%car x) '&whole)
               (%cadr x))
      (setq whole (%cadr x) x (%cddr x)))
    (values x whole env)))

(defun parse-body (body env &optional (doc-string-allowed t) &aux
   decls
   doc
   (tail body)
   form)
  (declare (ignore env))
  (loop
   (if (endp tail) (return))  ; otherwise, it has a %car and a %cdr
   (if (and (stringp (setq form (%car tail))) (%cdr tail))
    (if doc-string-allowed
     (setq doc form)
     (return))
    (if (not (and (consp form) (symbolp (%car form)))) 
     (return)
     (if (eq (%car form) 'declare)
      (push form decls)
      (return))))
   (setq tail (%cdr tail)))
  (return-from parse-body (values tail (nreverse decls) doc)))

) ; end of eval-when (load)

; End of verify-lambda-list.lisp
