diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..055c60f --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +*.*~ +*.*fasl \ No newline at end of file diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..fdddb29 --- /dev/null +++ b/LICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/README.org b/README.md similarity index 96% rename from README.org rename to README.md index 0a8c733..e66211a 100644 --- a/README.org +++ b/README.md @@ -1,4 +1,5 @@ -* SRFI 58: Array Notation +# SRFI 58 for CL: Array Notation + - Copyright (C) Aubrey Jaffer (2004, 2005). All Rights Reserved. Permission is hereby granted, free of charge, to any person obtaining diff --git a/package.lisp b/package.lisp index a14ef8e..b34a8fb 100644 --- a/package.lisp +++ b/package.lisp @@ -1,11 +1,19 @@ ;;;; package.lisp -(cl:in-package :cl-user) +(cl:in-package cl-user) -(defpackage :srfi-58 - (:use) - (:export)) -(defpackage :srfi-58.internal - (:use :srfi-58 :cl :named-readtables :fiveam)) +(defpackage "https://github.com/g000001/srfi-58" + (:use + cl + named-readtables + fiveam + "https://github.com/g000001/srfi-63") + (:shadowing-import-from + "https://github.com/g000001/srfi-63" + array-rank + array-dimensions + make-array )) + +;;; *EOF* diff --git a/readtable.lisp b/readtable.lisp index 27cb4e6..845cb48 100644 --- a/readtable.lisp +++ b/readtable.lisp @@ -1,9 +1,15 @@ ;;;; readtable.lisp -(cl:in-package :srfi-58.internal) +(cl:in-package "https://github.com/g000001/srfi-58") + + (in-readtable :common-lisp) + (defreadtable :srfi-58 (:merge :standard) (:dispatch-macro-char #\# #\a #'sharp-a) (:case :upcase)) + + +;;; *EOF* diff --git a/srfi-58.asd b/srfi-58.asd index 401348f..ca385bb 100644 --- a/srfi-58.asd +++ b/srfi-58.asd @@ -2,7 +2,14 @@ (cl:in-package :asdf) + (defsystem :srfi-58 + :version "20200314" + :description "" + :long-description " +https://srfi.schemers.org/srfi-58" + :author "Aubrey Jaffer" + :maintainer "CHIBA Masaomi" :serial t :depends-on (:fiveam :srfi-63 @@ -12,11 +19,28 @@ (:file "readtable") (:file "test"))) + +(defmethod perform :after ((o load-op) (c (eql (find-system :srfi-58)))) + (let ((name "https://github.com/g000001/srfi-58") + (nickname :srfi-58)) + (if (and (find-package nickname) + (not (eq (find-package nickname) + (find-package name)))) + (warn "~A: A package with name ~A already exists." name nickname) + (rename-package name name `(,nickname))))) + + (defmethod perform ((o test-op) (c (eql (find-system :srfi-58)))) - (load-system :srfi-58) - (or (flet ((_ (pkg sym) - (intern (symbol-name sym) (find-package pkg)))) - (let ((result (funcall (_ :fiveam :run) (_ :srfi-58.internal :srfi-58)))) - (funcall (_ :fiveam :explain!) result) - (funcall (_ :fiveam :results-status) result))) - (error "test-op failed") )) + (let ((*package* + (find-package + "https://github.com/g000001/srfi-58"))) + (eval + (read-from-string + " + (or (let ((result (run 'srfi-58))) + (explain! result) + (results-status result)) + (error \"test-op failed\") )")))) + + +;;; *EOF* diff --git a/srfi-58.lisp b/srfi-58.lisp index 12fbd9f..6707b72 100644 --- a/srfi-58.lisp +++ b/srfi-58.lisp @@ -1,15 +1,17 @@ ;;;; srfi-58.lisp -(cl:in-package :srfi-58.internal) +(cl:in-package "https://github.com/g000001/srfi-58") + (defvar *eof* (list nil)) + (defun eof-object? (c) (eq *eof* c)) ;;; Read integer up to first non-digit -(defun read..try-number (port &rest ic) +(defun read$try-number (port &rest ic) (let ((chr0 (char-code #\0))) (labels ((iter (arg) (let ((c (peek-char nil port nil *eof* T))) @@ -20,11 +22,13 @@ (:else arg))))) (iter (and (not (null ic)) (- (char-code (car ic)) chr0)))))) + (defun bomb (pc wid) (error (format nil "~@{~A~^ ~}" 'array 'syntax? "#" 'rank "A" pc wid))) + (defun read-array-type (port) (case (char-downcase (peek-char nil port nil *eof* T)) ((#\:) (read-char port) @@ -36,7 +40,7 @@ (and (not (eof-object? c)) (iter (cons (char-upcase c) arg))))))) (iter 'nil))) - (wid (and typ (not (eq 'bool typ)) (read..try-number port)))) + (wid (and typ (not (eq 'bool typ)) (read$try-number port)))) (flet ((check-suffix (chrs) ;; (print (list :chrs chrs)) (let ((chr (read-char port))) @@ -44,25 +48,25 @@ (not (member (char-downcase chr) chrs))) (error "array-type?: ~A ~A ~A" typ wid chr))))) (let ((prot (assoc typ `((floC - (128 . ,#'a:floc128b) - (64 . ,#'a:floc64b) - (32 . ,#'a:floc32b) - (16 . ,#'a:floc16b)) + (128 . ,#'a$floc128b) + (64 . ,#'a$floc64b) + (32 . ,#'a$floc32b) + (16 . ,#'a$floc16b)) (floR - (128 . ,#'a:flor128b) - (64 . ,#'a:flor64b) - (32 . ,#'a:flor32b) - (16 . ,#'a:flor16b)) + (128 . ,#'a$flor128b) + (64 . ,#'a$flor64b) + (32 . ,#'a$flor32b) + (16 . ,#'a$flor16b)) (fixZ - (64 . ,#'a:fixz64b) - (32 . ,#'a:fixz32b) - (16 . ,#'a:fixz16b) - (8 . ,#'a:fixz8b)) + (64 . ,#'a$fixz64b) + (32 . ,#'a$fixz32b) + (16 . ,#'a$fixz16b) + (8 . ,#'a$fixz8b)) (fixN - (64 . ,#'a:fixn64b) - (32 . ,#'a:fixn32b) - (16 . ,#'a:fixn16b) - (8 . ,#'a:fixn8b)) + (64 . ,#'a$fixn64b) + (32 . ,#'a$fixn32b) + (16 . ,#'a$fixn16b) + (8 . ,#'a$fixn8b)) (char . #'vector) (bool . #'vector)) :test #'equal))) @@ -79,17 +83,19 @@ prot)))) (otherwise NIL))) + #|(defun list->uniform-array (&rest args) args)|# -;;; We come into read..array with number or #f for RANK. -#|(defun read..array (rank dims port reader) + +;;; We come into read$array with number or #f for RANK. +#|(defun read$array (rank dims port reader) (let ((rank (or rank (and (char-equal reader #\a) 1)))) (labels ((iter (dims) (declare (optimize (debug 0) (space 3))) - (let ((dim (read..try-number port))) + (let ((dim (read$try-number port))) (if dim (iter (cons dim dims)) (case (peek-char nil port) @@ -101,11 +107,12 @@ (list->uniform-array rank dims nil (read port) ))))))) (iter dims) )))|# -(defun read..array (rank dims port reader) + +(defun read$array (rank dims port reader) (declare (ignore reader)) (labels ((iter (dims) (declare (optimize (debug 0) (space 3))) - (let ((dim (read..try-number port))) + (let ((dim (read$try-number port))) (if dim (iter (cons dim dims)) (case (peek-char nil port) @@ -123,29 +130,33 @@ (read port) ) )))))) (iter dims) )) + (defun list->uniform-array (rank dims type list) (let ((rank (or rank (let ((dim (length dims))) (if (zerop dim) 1 dim) ) ))) (srfi-63:list->array rank (funcall type) list) )) -(defun read..sharp (c port read) + +(defun read$sharp (c port read) (let ((rank read)) (case c - ((#\a #\A) (read..array rank '() port c)) + ((#\a #\A) (read$array rank '() port c)) ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (let* ((num (read..try-number port c)) + (let* ((num (read$try-number port c)) (chr (peek-char nil port))) (case chr ((#\a #\A) (read-char port) - (read..array num '() port c)) + (read$array num '() port c)) ((#\*) (read-char nil port) - (read..array rank (list num) port c)) + (read$array rank (list num) port c)) (:else - (read..array 1 (list num) port c))))) + (read$array 1 (list num) port c))))) (otherwise (error "unknown # object ~A" c))))) + (defun sharp-a (stream char arg) - (read..sharp char stream arg)) + (read$sharp char stream arg)) + -;;; eof +;;; *EOF* diff --git a/test.lisp b/test.lisp index a6ecbfb..1f99c1b 100644 --- a/test.lisp +++ b/test.lisp @@ -1,9 +1,11 @@ -(cl:in-package :srfi-58.internal) +(cl:in-package "https://github.com/g000001/srfi-58") + + (in-readtable :srfi-58) -(def-suite srfi-58) -(in-suite srfi-58) +(def-suite* srfi-58) + #|| array-prefix :: rank `A' [ dimensions ] [ `:' type-specifier ] | @@ -26,16 +28,19 @@ decwidth :: `32' | `64' | `128' ||# + (defun read-from-string/sharp-a (str) (let ((*readtable* (copy-readtable nil))) (set-dispatch-macro-character #\# #\A #'sharp-a) (read-from-string str))) -(test read..try-number + +(test read$try-number (is (= 888 (with-input-from-string (in "888a") - (read..try-number in)))) + (read$try-number in)))) (is (= 0 (with-input-from-string (in "0a") - (read..try-number in))))) + (read$try-number in))))) + (test 2*3 (let ((a #2A:fixN16b((0 1 2) (3 5 4)))) @@ -50,14 +55,22 @@ (is (= 2 (srfi-63:array-rank a))) (is (equal '(2 3) (srfi-63:array-dimensions a))))) -#|(read-from-string/sharp-a "#2A:fixN16b((0 1 2) (3 5 4))")|# + +#|(read$rom-string/sharp-a "#2A:fixN16b((0 1 2) (3 5 4))")|# + + ;=> (:RANK 2 :DIMS NIL :TYPE 16 ((0 1 2) (3 5 4))) ; 28 -#|(read-from-string/sharp-a "#2A2*3:fixN16b((0 1 2) (3 5 4))")|# +#|(read$rom-string/sharp-a "#2A2*3:fixN16b((0 1 2) (3 5 4))")|# + + ;=> (:RANK 2 :DIMS (3 2) :TYPE 16 ((0 1 2) (3 5 4))) ; 31 -#|(read-from-string/sharp-a "#A2*3:fixN16b((0 1 2) (3 5 4))")|# +#|(read$rom-string/sharp-a "#A2*3:fixN16b((0 1 2) (3 5 4))")|# + + +;;; *EOF* ;=> (:RANK NIL :DIMS (3 2) :TYPE 16 ((0 1 2) (3 5 4))) ; 30