;;; -*- 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 &key (directories-are-files t)) ;; According to the ANSI standard, directory should return a list of pathnames ;; corresponding to the truenames (or `canonical' filenames) of the files matching ;; the path argument. However, Allegro CL does not return truenames for directories ;; or for Unix symbolic links: ;; ;; (1) Allegro extends the ANSI standard with a directories-are-files keyword ;; argument - fair enough, but weirdly this argument defaults to true (which means ;; that no directory gets its truename since the final component of the directory ;; name is moved to the pathname-name and/or -type). ;; ;; (2) Symbolic links are not resolved to their targets - if the path argument is a ;; symlink then none of the results are truenames, and if a contained file/directory ;; is a symlink it is not returned as a truename. Although this behaviour could be ;; justified as useful, it clearly conflicts with the standard. ;; ;; Here we attempt to imitate the non-standard Allegro behaviour in other CLs. ;; Unfortunately, case 2 requires implementation-specific fix-ups. ;; NB we don't attempt to implement Allegro's follow-symbolic-links keyword argument ;; (which despite its name is not relevant to case 2 above) ;; (let ((subs (apply #'cl:directory path #+:sbcl (list :resolve-symlinks nil) #+:ccl (list :follow-links nil) #+:lispworks (list :link-transparency nil)))) (if directories-are-files (mapcar #'cl-fad:pathname-as-file subs) subs))) #-: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)))