;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: TSDB -*-

;;;
;;; [incr tsdb()] --- Competence and Performance Profiling Environment
;;; This file Copyright (c) 2020 John Carroll
;;;
;;; This program 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.
;;;
;;; This program 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.
;;; 

;;; compatibility.lisp
;;;
;;; Emulate Allegro CL extensions to ANSI standard to ease porting to other CLs.

(in-package :tsdb)

#-:allegro
(eval-when (:compile-toplevel :load-toplevel :execute)
  (shadow '(intern make-pathname directory make-array adjust-array)))


#-:allegro
(defun tsdb::intern (string &optional (package *package*))
  ;; ANSI CL requires the first argument to be a string, whereas Allegro CL also
  ;; allows a symbol when excl:*intern-allows-symbol* is true (the default). Code in
  ;; tsdb/lisp/ takes extensive advantage of this extra, non-standard freedom.
  ;; Work around it in other CLs.
  ;;
  (cl:intern
    (if (symbolp string) (symbol-name string) string)
    package))


#-:allegro
(defun tsdb::make-pathname (&rest rest &key (directory nil dirp) &allow-other-keys)
  ;; In the ANSI standard, a "valid pathname directory" passed to make-pathname is
  ;; one of the following:
  ;;   "a string, a list of strings, nil, :wild, :unspecific, or some other object
  ;;    defined by the implementation...".
  ;; Allegro CL seems to allow an arbitrary symbol or even a character; perhaps these
  ;; fall into the "some other object" category, but this is not documented.
  ;; Furthermore, the ANSI description for make-pathname says:
  ;;   "If the directory is a string, it should be the name of a top level directory,
  ;;    and should not contain any punctuation characters".
  ;; However, Allegro does not enforce this restriction. Code in tsdb/lisp/ often
  ;; relies on these non-standard features. Simulate this laxness in other CLs, since
  ;; there are too many calls to make-pathname to check and fix each one.
  ;;
  (if dirp
      (progn
        (unless (or (stringp directory) (listp directory)
                    (member directory '(:wild :unspecific) :test #'eq))
          (setq directory (string directory))) ; extends ANSI standard: try to coerce
        (apply #'cl:make-pathname
          :directory
          (if (and (stringp directory)
                   (or (find #\/ directory) ; outside ANSI standard?
                       #-:unix (find #\\ directory)))
              (pathname-directory (cl-fad:pathname-as-directory directory))
              directory)
          rest))
      (apply #'cl:make-pathname rest)))


#-:allegro
(defun tsdb::directory (path &rest rest
                        &key (directories-are-files t dfp) &allow-other-keys)
  ;; Allegro CL extends the ANSI standard with a :directories-are-files argument - fair
  ;; enough, but weirdly this defaults to true (so directories are returned with their
  ;; final component in the pathname-name) - reproduce this odd behaviour in other CLs.
  ;;
  (when dfp (remf rest :directories-are-files))
  (let ((res (apply #'cl:directory path rest)))
    (if directories-are-files
        (mapcar #'cl-fad:pathname-as-file res)
        res)))


#-:allegro
(defun tsdb::make-array (dims &rest rest &key (element-type t)
                         (initial-element nil iep) (initial-contents nil icp)
                         (displaced-to nil dtp) &allow-other-keys)
  ;; Code in tsdb/lisp/ often does not supply an :initial-element, assuming that
  ;; elements in a general array are initialized to nil. In practice, this strategy
  ;; works in Allegro - but some other CL implementations do _not_ initialize to nil.
  ;; The ANSI standard says that the initial contents of an array are undefined
  ;; unless :initial-element, :initial-contents or :displaced-to are supplied. To
  ;; sustain this incorrect assumption in other CLs, insert :initial-element nil when
  ;; applicable.
  ;;
  (declare (ignore initial-element initial-contents displaced-to))
  (if (and (not iep) (not icp) (not dtp)
           (or (eq element-type t)
               (eq (upgraded-array-element-type element-type) t)))
      (apply #'cl:make-array dims :initial-element nil rest)
      (apply #'cl:make-array dims rest)))

#-:allegro
(defun tsdb::adjust-array (array dims &rest rest &key (element-type t)
                           (initial-element nil iep) (initial-contents nil icp)
                           (displaced-to nil dtp) &allow-other-keys)
  ;; As make-array
  ;;
  (declare (ignore initial-element initial-contents displaced-to))
  (if (and (not iep) (not icp) (not dtp)
           (or (eq element-type t)
               (eq (upgraded-array-element-type element-type) t)))
      (apply #'cl:adjust-array array dims :initial-element nil rest)
      (apply #'cl:adjust-array array dims rest)))