1
0
mirror of synced 2026-01-27 04:41:54 +00:00

So far, it looks like every file with through tr '\r\n' '\n\r' swapping cr and lf.

This commit is contained in:
Larry Masinter
2020-12-01 17:56:50 -08:00
parent 5584b38276
commit ec4f57461c
3134 changed files with 183421 additions and 9878 deletions

Binary file not shown.

Binary file not shown.

Binary file not shown.

File diff suppressed because one or more lines are too long

Binary file not shown.

File diff suppressed because one or more lines are too long

Binary file not shown.

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

File diff suppressed because one or more lines are too long

View File

@@ -1 +1,29 @@
;;; Maiko Garbage Collector Tests
;;; Maiko Garbage Collector Tests
;; Start a clean Maiko Full.Sysout.
;; Open an Interlisp EXEC.
LOAD(GCHAX.LCOM)
LOAD({ERIS}<TEST>GC>HAND>MAIKO-GC-TESTS.LCOM)
(STORAGE)
;; note the counts for types starting with SEDIT::.
DV DIRECTORIES
DV DISPLAYFONTDIRECTORIES
DV INTERPRESSFONTDIRECTORIES
;; close the SEdit windows
(FRPTQ 100 (RECLAIM))
(STORAGE)
;; make sure that all the SEDIT:: types got reclaimed.
SHH(MAIN-GC-TEST 5) ; or any number
;; look at the dribble to make sure that things get
;; reclaimed. Specifically, look at:
;; FLOATPs
;; FIXPs
;; BIGNUMs
;; STREAMs
;; PIECEs
;; TEXTOBJs
;; VMEMPAGEPs
;; COMPILED-CLOSUREs
;; The final 2 things MAIN-GC-TEST does are to exhaust atom
;; space artificially (and restore it to its pre-existing state),
;; and exhaust storage for real. Both of these should cause errors
;; from which you can ^ to continue the test.

Binary file not shown.

View File

@@ -1 +1,77 @@
(FILECREATED "17-Jun-86 15:55:40" {ERIS}<SANNELLA>LISP>FDEVTEST.;3 3034
(FILECREATED "17-Jun-86 15:55:40" {ERIS}<SANNELLA>LISP>FDEVTEST.;3 3034
changes to: (FNS TEST.PEEKBIN)
(VARS FDEVTESTCOMS)
previous date: "17-Jun-86 14:29:21" {ERIS}<SANNELLA>LISP>FDEVTEST.;1)
(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT FDEVTESTCOMS)
(RPAQQ FDEVTESTCOMS ((FNS TEST.PEEKBIN)))
(DEFINEQ
(TEST.PEEKBIN
[LAMBDA (FILE DONT.TRY.HARD.FLG) (* mjs "17-Jun-86 15:54")
(PROG ((STRM (OPENSTREAM FILE (QUOTE INPUT)
(QUOTE OLD)))
STRMLEN)
(RESETLST (RESETSAVE NIL (LIST (QUOTE CLOSEF)
STRM))
(SETQ STRMLEN (GETEOFPTR STRM))
(for PTR in (APPEND (LIST 0 STRMLEN (IMAX (SUB1 STRMLEN)
0)
(ADD1 STRMLEN)
(IPLUS (RAND 1 10)
(ITIMES (RAND 2 5)
STRMLEN)))
(for X from -1 to STRMLEN by 512
when (IGREATERP X 0) collect X)
(for X from 0 to STRMLEN by 512
collect X)
(for X from 1 to STRMLEN by 512
collect X)
(for X from 1 to 5 collect (RAND 0
STRMLEN)))
bind C.PEEK.NIL C.PEEK.T C.BIN PTR2 PTR3
do (SETFILEPTR STRM PTR)
(SETQ C.PEEK.NIL (NLSETQ (\PEEKBIN STRM)))
(SETQ PTR2 (GETFILEPTR STRM))
(if (NOT DONT.TRY.HARD.FLG)
then (if (NOT (EQUAL PTR PTR2))
then (ERROR "\PEEKBIN moving file ptr!")))
(SETQ C.PEEK.T (NLSETQ (\PEEKBIN STRM T)))
(SETQ PTR3 (GETFILEPTR STRM))
(if (NOT DONT.TRY.HARD.FLG)
then (if (NOT (EQUAL PTR PTR3))
then (ERROR "\PEEKBIN moving file ptr!")))
(SETQ C.BIN (NLSETQ (BIN STRM)))
(if (IGEQ PTR STRMLEN)
then (* at EOS)
(if (NOT DONT.TRY.HARD.FLG)
then (if (NOT (AND (EQUAL C.PEEK.NIL NIL)
(EQUAL C.PEEK.T
(QUOTE (NIL)))
(EQUAL C.BIN NIL)))
then (ERROR
"\PEEKBIN or BIN not working correctly at EOS")))
(if (NOT DONT.TRY.HARD.FLG)
then (if (NOT (EQUAL (GETFILEPTR STRM)
PTR))
then (ERROR "BIN moving fileptr at eos")
))
else (* before EOS)
(if (NOT (AND (EQUAL C.PEEK.NIL C.PEEK.T)
(EQUAL C.PEEK.T C.BIN)))
then (ERROR
"\PEEKBIN and BIN not returning same value!"))
(if (NOT (EQUAL (GETFILEPTR STRM)
(ADD1 PTR)))
then (ERROR "BIN not moving ptr correctly!"])
)
(PUTPROPS FDEVTEST COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (368 2955 (TEST.PEEKBIN 378 . 2953)))))
STOP

View File

@@ -1 +1,3 @@
This file obsolete, see:
This file obsolete, see:
{ERIS}<TEST>.read-me-first

View File

@@ -1 +1,3 @@
This file obsolete, see:
This file obsolete, see:
{ERIS}<TEST>.read-me-first

View File

@@ -1 +1,58 @@
;; Function To Be Tested: get-properties
;; Function To Be Tested: get-properties
;;
;; Source: CLtL p. 167
;; Chapter 10: Symbols Section 1: The Property List
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 24 June 86
;;
;; Last Update: 15 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-1-get-properties.test
;;
;;
;; Syntax: get-properties place indicator-list
;;
;; Function Description: Search the property list stored in place for any of the indicators in indicator-list until the it finds the first property in the property list whose indicator is one of the elements of indicator-list .
;;
;; Argument(s): place: a property list;
;; indicator-list: a list of property indicators
;;
;; Returns multiple values:
;; If one of the elements of indicator-list is one of the properties in the list stored at place: the first indicator found, its value, and the tail of the property list.
;; If not: nil
;;
(do-test-group get-properties-group
:before
(progn
(test-setq alpha-list '(a b c d e f g H))
(setf (get 'alpha-list 'length) 7 (get 'alpha-list 'languages) '(english german spanish etc.))
) ; progn
;;
(do-test "get-properties test"
(AND
;; The simplest cases:
;; First value is a property.
(EQ 'a (car (multiple-value-list (get-properties alpha-list '(a 3 "Alexis is a bitch.")))))
(EQ 'a (car (multiple-value-list (get-properties '(a b c d e f g H) '(a "Krystle is dipppy.")))))
;; Second value is the property's value.
(eq 'b (cadr (multiple-value-list (get-properties alpha-list '(a 3 "Alexis is a bitch.")))))
(eq 'b (cadr (multiple-value-list (get-properties '(a b c d e f g H) '(a "Alexis is a bitch." 3 )))))
;; Third value is the list's tail, starting at the indicator found.
(tailp (caddr (multiple-value-list (get-properties alpha-list '(a e)))) alpha-list)
;;
(tailp (caddr (multiple-value-list (get-properties alpha-list '(C D)))) alpha-list)
(equal (nthcdr 2 (multiple-value-list (get-properties '(a b c d e f g H) '(C D)))) (list (nthcdr 2 alpha-list)))
;; Should return NIL if it doesn't find any property from indicator-list.
(null (get-properties alpha-list '(7)))
(null (get-properties alpha-list '(weight price)))
(null (get-properties (list (gensym) (gensym)) '(languages weight)))
;; See if it can work on itself:
(equal 'etc. (cadr (multiple-value-list (get-properties (cadr (multiple-value-list (get-properties (symbol-plist 'alpha-list) '(languages)))) '(hebrew spanish)))))
) ; AND
) ; do-test
) ; do-test-group
STOP

View File

@@ -1 +1,102 @@
;; Function To Be Tested: get
;; Function To Be Tested: get
;;
;; Source: CLtL p. 164
;; Chapter 10: Symbols Section 1: The Property List
;; Page: 164
;;
;; Created By: Peter Reidy
;;
;; Creation Date: June 13 86
;;
;; Last Update: 16 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-1-get.test
;;
;;
;; Syntax: get symbol indicator &optional default
;;
;; Function Description: Get the value of indicator from the property list of symbol. Return default if specified and the value of indicator isn't found. default defaults to nil. Note that the function returns the same value (nil) if nil is the value of the indicated property or if symbol does not have the indicated property.
;;
;; Argument(s): symbol - a valid CML symbol;
;; indicator - any valid CML expression
;; Returns: value of a property - if symbol has a
;; property eq to indicator's;
;; default - if specified and the property's
;; value is not found;
;; nil - if not found and no default
;; specified.
;;
(do-test-group get-group
;; First, create some property lists.
:before (progn
(test-setq carre 2 four 4 five 5 cinq 'five) ;; The symbol FIVE, not the number which is FIVE's value
;; Start with clean property lists.
(setf (symbol-plist 'four) nil)
(setf (symbol-plist 'five) nil)
(setf (symbol-plist 'cinq) nil)
(setf (get 'four 'square) (* 4 4))
(setf (get 'five 'square) (* 5 5))
(setf (get 'four 'sqrt) (sqrt four))
(setf (get 'four 'odd) nil)
(setf (get 'five'sqrt) (sqrt five))
(setf (get 'four 'spelling) "four")
(setf (get 'five 'spelling) "five")
)
;; Try some ordinary gets.
(do-test "regular-get-test"
(AND
(get 'four 'square)
(eq (get 'five 'square) 25.)
(eql (get 'five 'sqrt) (sqrt 5))
(eql (get 'four 'sqrt) (cadr '(1.0 2.0 3.0)))
(get 'four 'spelling)
(string= (get 'five 'spelling) "five")
)
)
;; Try the default feature
(do-test "default get test"
(AND
(null (get 'four 'prime))
(get 'four 'prime (car '(10 20 30)))
(setq epimenides t)
(eq t (get 'four 'prime epimenides))
)
)
;; Test the equivalence between get of a nonexistent property and get of a property defined to be nil.
(do-test "nil get test"
(AND
(setf (get 'five 'odd) t)
(member 'odd (symbol-plist 'four))
(member 'odd (symbol-plist 'five))
(not (member 'perfect-square-p (symbol-plist 'five)))
(null (get 'four 'odd))
(null (get 'five 'perfect-square-p))
(eq (get 'four 'odd) (get 'five 'cube))
)
)
;; Test the function's ability to distinguish between names and values. With acknowledgements to Ron Fischer.
(do-test "use-mention get test"
(AND
;; cinq is bound to the symbol 'five, not to the symbol's value.
;; A property of 'cinq...
(not (equalp (get cinq 'sqrt) (get 'cinq 'sqrt)))
(setf (get 'cinq 'carre) "vingt-cinq")
(member 'carre (symbol-plist 'cinq))
;; ...not of the symbol which is its value
(not(member 'carre (symbol-plist cinq)))
;; A property of the value of 'cinq - i.e. of the symbol 'five
(setf (get cinq 'carre) "vingt-cinq")
(member 'carre (symbol-plist cinq))
;; The symbol 'carre is on the plist, not carre's value.
(not(member carre (symbol-plist cinq)))
(setf (get cinq 'carre) 2)
;; The value of the symbol 'carre - i.e. 2 - should be part of the property list now.
(member carre (symbol-plist cinq))
)
)
)
STOP

View File

@@ -1 +1,85 @@
;; Function To Be Tested: getf
;; Function To Be Tested: getf
;;
;; Source: CLtL p. 166
;; Chapter 10: Symbols Section 1: The Property List
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 20 June 86
;;
;; Last Update: 16 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-1-getf.test
;;
;;
;; Syntax: getf place indicator &optional default
;;
;; Function Description: Get the value of indicator from the property list stored in place. Return default if specified and the value of indicator isn't found. default defaults to nil. Note that the function returns the same value (nil) if nil is the value of the indicated property or if symbol does not have the indicated property.
;; getf differs from get in that place may be any form whose value is a symbol, whereas get requires a symbol.
;;
;; Argument(s): place - a form whose value is a symbol;
;; indicator - a list (anything for which listp returns t)
;; Returns: value of a property - if symbol has a property eq to indicator's;
;; default - if specified and the property's value is not found;
;; nil - if not found and no default specified.
;;
(do-test-group getf-group
;; First, create some property lists. Whether or not the symbol is bound shouldn't matter.
:before (progn
(setf (symbol-plist 'hundred) nil (symbol-plist 'thousand) nil)
(setf (get 'hundred 'power) 2
(get 'hundred 'factors) '(2 5 2 5)
(get 'thousand 'power) 3
(get 'thousand 'factors) '(2 5 2 5 2 5)
)
(test-setq list1000 (symbol-plist 'thousand))
(mapcar #'(lambda (symbol) (setf (symbol-plist symbol) nil)) '(trunk branch twig leaf))
(setf
(get 'trunk 'offshoot) 'branch
(get 'branch 'offshoot) 'twig
(get 'twig 'offshoot) 'leaf
)
) ; progn
;;
;; Try some ordinary getfs.
(do-test "regular getf test"
(AND
(getf '(0 1 2 3 4 5) 4)
;; NIL because 5 isn't in a property-name position
(null (getf '(0 1 2 3 4 5) 5))
;; NIL becase 6 isn't there at all
(null (getf '(0 1 2 3 4 5) 6))
(= (getf list1000 'power) 3)
;; Nested getfs - the property is itself a list.
(eq (getf (getf (symbol-plist 'thousand) 'factors) 2) 5)
)
)
;;
;; Try the default feature
(do-test "default getf test"
(AND
(= 10000 (getf (symbol-plist 'hundred) 'square 10000))
;; Default should not override specified properties.
(not (eql 50 (getf (symbol-plist 'hundred) 'power 50)))
(getf '(Ennis concrete Hollyhock stucco Martin brick) 'Hollyhock nil)
)
)
;;
;; Show that getf works several layers deep.
(do-test "recursive getf test"
(setf
(get 'leaf 'color)
'orange
(getf (symbol-plist 'leaf) 'color)
'vermillion
(getf (symbol-plist (getf (symbol-plist 'twig) 'offshoot)) 'color)
'blue
(getf (symbol-plist (getf (symbol-plist (getf (symbol-plist 'branch) 'offshoot)) 'offshoot)) 'color)
'black
(getf (symbol-plist (getf (symbol-plist (getf (symbol-plist (getf (symbol-plist 'trunk) 'offshoot)) 'offshoot)) 'offshoot)) 'color)
'green
) ; setf
(equal (getf (symbol-plist 'leaf) 'color) 'green)
)
)
STOP

View File

@@ -1 +1,60 @@
;; Function To Be Tested: remf
;; Function To Be Tested: remf
;;
;; Source: CLtL p. 167
;; Chapter 10: Symbols Section 1: The Property List
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 23 June 86
;;
;; Last Update: 1/28/87 Jim Blum - removed tests which evaluated to (REMF NIL)
;;
;; Filed As: {eris}<lispcore>cml>test>10-1-remf.test
;;
;;
;; Syntax: remf place indicator
;;
;; Function Description: remove the property whose indicator is eq to indicator from the property list at place.
;;
;; Argument(s): place is any generalized variable acceptable to setf.
;; indicator is any valid cml expression.
;;
;; Returns: T if indicator was found on the property list at place, else nil.
;;
(do-test-group remf-group
:before
(progn
;; Create a property list
(test-setq thread "twine")
(setf
(symbol-plist 'thread) nil
(get 'thread 'material) 'cotton
(get 'thread 'length) 30
(get 'thread 'brand) 'Pennys
)
)
;;
(do-test "remf test"
;; Some ordinary examples
(AND
(remf (symbol-plist 'thread) 'material)
(null (get 'thread 'material))
(remf (symbol-plist 'thread) 'length)
(null (getf (symbol-plist 'thread) 'material))
(remf (symbol-plist 'thread) 'brand)
(null (get 'thread 'brand))
;; By now the plist should be empty
(null (symbol-plist 'thread))
)
)
;;
(do-test "remf returns non-nil if it found the property"
(setf (get 'tarski 'nil) 300)
(and
(evenp (search '(nil) (symbol-plist 'tarski))) ; Show that it's there and in property position.
(remf (symbol-plist 'tarski) 'nil)
)
)
)
STOP

View File

@@ -1 +1,69 @@
;; Function To Be Tested: remprop
;; Function To Be Tested: remprop
;;
;; Source: CLtL p. 166
;; Chapter 10: Symbols Section 1: The Property List
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 20 June 86
;;
;; Last Update: 16 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-1-remprop.test
;;
;; Syntax: remprop symbol indicator
;;
;; Function Description: remove from symbol's property list the property eq to indicator.
;;
;; Argument(s): symbol - a valid CML symbol;
;; indicator - any valid CML expression
;; Returns: property indicator if found (i.e. if symbol has a property with an indicator eq to indicator;
;; nil - if not found
;;
(do-test-group remprop-group
;; First, create a property list.
:before (progn
(test-setq twenty-five 25)
(setf (symbol-plist 'twenty-five) nil)
(setf (symbol-plist 'minus25) nil)
(setf (get 'twenty-five 'sqrt) 5)
(setf (get 'twenty-five 30) 35)
(setf (get 'twenty-five 'inverse) 'minus25)
(setf (get 'minus25 'sign) 'negative)
)
(do-test "remprop test"
(AND
;; First, show that the properties are there.
(get 'twenty-five 'inverse)
(get 'twenty-five 'sqrt)
(get 'twenty-five 30)
;; Now get rid of one.
(remprop 'twenty-five 'sqrt)
(null (get 'twenty-five 'sqrt))
;; Show that something eq to indicator will do.
(remprop 'twenty-five (+ 15 15))
(null (getf (symbol-plist 'twenty-five) 30))
;; What evaluates to a symbol ought to be acceptable as symbol.
(symbol-plist 'minus25)
(remprop (get 'twenty-five 'inverse) 'sign)
(null (symbol-plist 'minus25))
;; One property should be left; get rid of it and the list should be empty.
(remprop 'twenty-five 'inverse)
(null (symbol-plist 'twenty-five))
;; Remprop should work on arbitrary symbols and properties.
(null (remprop (gensym) 'eyecolor))
)
)
;;
;; Remprop must return non-nil if it found the property
(do-test "remprop returns non-nil if it found the property"
;; NOTE: not working in 6 December sysout; see AR 5973.
(setf (get 'tarski 'nil) t)
(and
(evenp (search '(nil) (symbol-plist 'tarski))) ; show that it's in property position
(remprop 'tarski nil)
)
)
)
STOP

View File

@@ -1 +1,72 @@
;; Function To Be Tested: SYMBOL-PLIST
;; Function To Be Tested: SYMBOL-PLIST
;;
;; Source: CLtL p. 166
;; Chapter 10: Symbols Section 1: The Property List
;; Page: 164
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 16 June 86
;;
;; Last Update: 14 August 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-1-symbol-plist.test
;;
;;
;; Syntax: symbol-plist symbol
;;
;; Function Description: Return symbol's property list; return nil if no property list is found, whether because symbol is undefined or because it has no properties.
;;
;; Argument(s): symbol - a valid CML symbol
;; Returns: symbol's property list or nil.
;;
;;
(do-test-group symbol-plist-group
:before (progn
;; create some symbols
(test-setq
nothing nil
unbound (gentemp)
props '(true fixed ratio float complex character semistd linediv symbol list dot vector string bitvector hashtable readtable package pathname stream random)
vals (list t 100 -3/5 3.14 #c(3 -5) #\Q #\return #\newline nothing '(a b c) '(33 . 50) '#(5 10 15) "twine" (make-array 7 :element-type 'bit :initial-contents '(1 0 0 0 1 0 1)) (make-hash-table) (copy-readtable) (car (list-all-packages)) (pathname T) *standard-input* (random 4761))
) ; test-setq
(setf (symbol-plist 'nothing) nil)
(setf (symbol-plist 'unbound) nil)
) ; progn
;;
(do-test "symbol-plist empty property lists test"
(AND
(null (symbol-plist 'nothing))
;; Get an unbound symbol.
(not(boundp (gensym)))
(null (symbol-plist (gensym)))
)
)
;;
(do-test "symbol-plist property types test"
(AND
(= 0 (list-length (symbol-plist 'nothing)))
;; Give nothing a property of each type.
(not(setf (get 'nothing 'false) nil))
;; acknowldegments to Karin Sye
(mapcar #'(lambda (property value) (setf (get 'nothing property) value)) props vals)
(= (+ 2 (* 2 (list-length props)))(list-length (symbol-plist 'nothing)))
)
)
;;
(do-test "symbol-plist unbound symbol test"
;; Show that unbound symbols have property lists
(AND
(= 0 (list-length (symbol-plist 'unbound)))
;; Give unbound a property of each type.
(not(setf (get 'unbound 'false) nil))
;; acknowldegments to Karin Sye
(mapcar #'(lambda (property value) (setf (get 'unbound property) value)) props vals)
(= (+ 2 (* 2 (list-length props)))(list-length (symbol-plist 'unbound)))
)
) ; do-test "symbol-plist unbound symbol test"
)
STOP

View File

@@ -1 +1,50 @@
;; Function To Be Tested: symbol-name
;; Function To Be Tested: symbol-name
;;
;; Source: CLtL p. 168
;; Chapter 10: Symbols Section 2: The Print Name
;;
;; Created By: Peter Reidy
;;
;; Creation Date: June 28 86
;;
;; Last Update: 16 December 1986
;;
;; Filed As: {eris}<lispcore>cml>test>10-2-symbol-name.test
;;
;; Syntax: symbol-name symbol
;;
;; Function Description: returns the print name of symbol.
;;
;; Argument(s): symbol - any expression whose value is a symbol.
;;
;; Returns: symbol's print name.
;;
(do-test-group symbol-name-group
:before
(progn
;; Create a some symbols and a property.
(test-setq five 5 fivename 'five)
(setf (get 'five 'symbol) 'sqrt25)
)
;;
(do-test "symbol name test"
(AND
;; For a defined symbol
(string= (symbol-name 'five) "FIVE")
(not (string= (symbol-name 'five) "five"))
(string-equal "five" (symbol-name 'five))
;; NIL has a non-nil print name.
(symbol-name nil)
;; For an undefined symbol
(symbol-name (gensym))
;; Indirectly
(string= (symbol-name fivename) "FIVE")
;; For a property
(string= (symbol-name (get 'five 'symbol)) "SQRT25")
;; With escape characters
(string= (symbol-name '\f\i\v\e) "five")
(string= (symbol-name (get '\F\I\V\E '\S\Y\M\B\O\L)) "SQRT25")
)
)
)
STOP

View File

@@ -1 +1,62 @@
;; Function To Be Tested: copy-symbol
;; Function To Be Tested: copy-symbol
;;
;; Source: CLtL p. 169
;; Chapter 10: Symbols Section 3: Creating Symbols
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 30 June 86
;;
;; Last Update: 15 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-3-copy-symbol.test
;;
;; Syntax: copy-symbol sym &optional copy-props
;;
;; Function Description: returns a new uninterned symbol with the same print name as sym. If copy-props is non-nil, the initial value and function definition will be the same as those of sym, and the property list of the new symbol will be a copy of sym's. If copy-props is nil (the default), then the new symbol will be unbound and undefined, and its property list will be empty.
;;
;; Argument(s): sym: an object whose value is a symbol
;; copy-props: an object whose value is nil or non-nil
;;
;; Returns: sym
;;
(do-test-group copy-symbol-group
:before
(progn
(test-setq forty 40)
(setf (symbol-plist 'forty) nil (get 'forty 'square) 1600)
(test-defun forty nil 4040)
(test-setq fortyname (copy-symbol 'forty))
)
;;
(do-test "copy-symbol nil test"
(AND
;; The print names should be the same.
(string= (symbol-name 'forty) (symbol-name fortyname))
;; Since we didn't copy props, the new symbol should be unbound and without property list or function definition.
(every 'null
(list
(boundp fortyname)
(symbol-plist 'fortyname)
(fboundp fortyname)
)
)
;; but 'forty is
forty
(symbol-plist 'forty)
(forty)
)
)
;; Now try it with copy-props; it should bring everything with it.
(do-test "copy-symbol copy-props test"
(and
;; Returns nil 9 October; AR 6540
(setq fortyname (copy-symbol 'forty 40))
(eq (eval fortyname) forty)
(eq (get 'forty 'square) (getf (symbol-plist fortyname) 'square))
(eq (forty) (funcall (symbol-function fortyname)))
)
)
)
STOP

View File

@@ -1 +1,142 @@
;; Function To Be Tested: gentemp
;; Function To Be Tested: gentemp
;;
;; Source: CLtL p. 169
;;
;; Chapter 10: Symbols Section 3: Creating Symbols
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 10 July 86
;;
;; Last Update: 17 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-3-gentemp.test
;;
;; Syntax: gentemp &optional prefix package
;;
;; Function Description: invents a print name consisting of prefix (default: T) and a number, creates a new symbol with that print name and interns in package (default: the current package); returns the new symbol. prefix is in effect for only one call, unlike gensym's, which becomes the new default.
;;
;; Argument(s): prefix: a string
;; package: a package
;;
;; Returns: the new symbol
;;
(do-test-group gentemp-group
:before
(progn
(test-setq
digits '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
prefix "T"
nondefprefix "Fallingwater"
iter (make-list 10)
pack1 (make-package (gensym))
pack2 (make-package (gensym))
)
;; Acknowledgements to R. Fischer
(test-defun integerpart (&optional (charpart prefix) (symbol (gentemp (string charpart))))
"Extract the integers from a symbol in gentemp form.
Default symbol is a new gentemp; default non-integer part is #\T,
the standard gentemp prefix."
(car
(multiple-value-list
(parse-integer
(string-trim (string charpart)
(symbol-name symbol)
)
)
)
)
)
(test-defun maketemps (base limit prefix)
"Generate a succession of symbols of form prefix/integer.
Base is the first integer, limit is the number of iterations.
The integer part will range from base to base+counter-1.
E.g. (maketemps 100 10 #\Q) will generate Q100 - Q109."
(do ((cnt 0 (1+ cnt)))
((= cnt limit))
;; Since gentemp creates symbols new IN THE PACKAGE, phony symbols have to be in the package as well; thus the import.
(import
(make-symbol
(concatenate 'simple-string
prefix
(prin1-to-string (+ base cnt))
)
)
)
)
) ; test-defun
) ; progn
;;
(do-test "default prefix should be T"
(char= (character prefix) (char (symbol-name (gentemp)) 0))
)
(do-test "after prefix should be an integer"
(integerp (integerpart))
)
(do-test "nothing after integer part"
(string=
prefix
(string-trim digits (symbol-name (gentemp)))
)
)
(do-test "integers should be in sequence; 10 tries"
;; Acknowledgements to Karin Sye.
;; Might skip over a previously-used symbol; hence the <=.
(dolist
(dummy iter
(<= -1
(- (integerpart) (integerpart))
)
)
)
)
(do-test "result should be interned"
(symbol-package (gentemp))
)
(do-test "interned in *package*"
(equal *package* (symbol-package (gentemp)))
)
(do-test "created in specified package"
(AND
(equal pack1 (symbol-package (gentemp prefix pack1)))
(equal pack2 (symbol-package (gentemp "pack2" pack2)))
) ; and
)
(do-test "prefix should reset once, then go back to default"
(AND
(string=
nondefprefix
(string-trim digits (symbol-name (gentemp nondefprefix)))
)
(gentemp nondefprefix)
(string=
prefix
(string-trim digits (symbol-name (gentemp)))
)
)
)
(do-test "w/default prefix, skip used suffixes"
(let ((base (1+ (integerpart))) (limit (1+ (random 100))))
(maketemps base limit prefix)
(or
;; maketemps will have used up limit consecutive symbols; gentemp will skip at least that many
(> (integerpart) (+ (1- limit) base))
;; In case of wraparound
(<= (integerpart) (1+ base))
)
)
)
(do-test "w/non-default prefix, skip used suffixes"
(let ((base (1+ (integerpart))) (limit (1+ (random 100))))
(maketemps base limit prefix)
(or
;; maketemps will have used up limit consecutive symbols; gentemp will skip at least that many.
(> (integerpart) (+ (1- limit) base))
;; In case of wraparound
(<= (integerpart) (1+ base))
)
)
)
)
STOP

View File

@@ -1 +1,42 @@
;; Function To Be Tested: keywordp
;; Function To Be Tested: keywordp
;;
;; Source: CLtL p. 170
;;
;; Chapter 10: Symbols Section 3: Creating Symbols
;;
;; Created By: Peter Reidy
;;
;; Creation Date: 12 July 86
;;
;; Last Update: 26 August 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-3-keywordp.test
;;
;; Syntax: keywordp object
;;
;; Function Description: returns T iff the argument is a symbol and the symbol belongs to the keyword package.
;;
;; Argument(s): object - any lisp object.
;;
;; Returns: T or nil
;;
(do-test-group (keywordp-group
:before
(test-setq *package* *package*)
) ; keywordp-group
(do-test "keyword is any symbol starting with a colon"
(keywordp :nothing)
)
(do-test "all keywords are in the keyword package"
(equal (symbol-package :nothing) (find-package 'keyword))
)
(do-test "A keyword is its own value"
(and
(keywordp ':nothing)
(eq :nothing ':nothing)
(equal (symbol-package ':nothing) (symbol-package :nothing))
)
)
)
STOP

View File

@@ -1 +1,39 @@
;; Function To Be Tested: make-symbol
;; Function To Be Tested: make-symbol
;;
;; Source: CLtL p. 168
;; Chapter 10: Symbols Section 3: Creating Symbols
;;
;; Creation Date: 28 June 86 Peter Reidy
;;
;; Last Update: 15 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-3-make-symbol.test
;;
;; Syntax: make-symbol print-name
;;
;; Function Description: creates a new uninterned symbol, whose print name is the string print-name. The value and function bindings will be unbound, and the property list will be empty.
;;
;; Argument(s): print-name - any object whose value is a print name.
;;
;; Returns: the symbol whose print name was the input.
;;
(do-test-group make-symbol-group
:before (test-setq test-symbol (make-symbol "emblem"))
(do-test "should be unbound, without a property list or function, and uninterned"
(AND
(symbolp test-symbol)
(every 'null
(list
(boundp test-symbol)
(symbol-plist test-symbol)
(fboundp test-symbol)
(symbol-package test-symbol)
)
)
)
)
(do-test "symbol-name/make-symbol reciprocity test"
(string= "sirnoel" (symbol-name (make-symbol "sirnoel")))
)
)
STOP

View File

@@ -1 +1,41 @@
;; Function To Be Tested: symbol-package
;; Function To Be Tested: symbol-package
;;
;; Source: CLtL p. 170
;; Chapter 10: Symbols Section 3: Creating Symbols
;;
;; Creation Date: 30 Oct 86 Ron Fischer (rewritten from Peter Reidy's version)
;;
;; Last Update: 17 December 86
;;
;; Filed As: {eris}<lispcore>cml>test>10-3-symbol-package.test
;;
;;
;; Syntax: symbol-package sym
;;
;; Function Description: returns the contents of sym's package cell, either a package object or nil.
;;
;; Argument(s): sym - a symbol.
;;
;; Returns: a package if sym is interned, nil otherwise.
;;
(do-test-group (symbol-package-group
:before (test-setq test-symbol (make-symbol "Frivolity"))
)
(do-test "fresh symbols have package NIL"
(null (symbol-package test-symbol))
)
(do-test "set symbol-package to a package"
(progn
(setf (symbol-package test-symbol) (find-package 'xcl-test))
(eq (find-package 'xcl-test) (symbol-package test-symbol))
)
)
(do-test "set symbol-package to NIL"
(progn
(setf (symbol-package test-symbol) nil)
(null (symbol-package test-symbol))
)
)
)
STOP

View File

@@ -1 +1,49 @@
;; Function To Be Tested: import
;; Function To Be Tested: import
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.6 Package System Functions and Variables
;; Page: 186
;;
;; Created By: Ron Fischer (original file by John Park)
;;
;; Creation Date: Oct 30, 1986
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-6-import.test
;;
;;
;; Syntax: (import symbols &optional package)
;;
;; Function Description: The argument should be a list of symbols, or possibly
;; a single symbol. These symbols become internal symbols in package and can
;; therefore be referred to without having to use qualified-name (colon) syntax.
;; import signals a correctable error if any of the imported symbols has the same
;; name as some distinct symbol already accessible in the package. Import returns T.
;;
;; Argument(s): Symbol(s)
;; Package (optional)
;;
;; Returns: T
;;
;; Constraints/Limitations: none
(do-test-group (import-group
:before (setq im-foo (make-package "IM-BAR" :use nil))
)
(do-test "import returns T"
(eq (import '(lisp:rational lisp:plusp) 'im-bar) T)
)
(do-test "symbols imported from LISP"
(and
(eq 'lisp:rational (find-symbol "RATIONAL" 'im-bar))
(eq 'lisp:plusp (find-symbol "PLUSP" 'im-bar))
)
)
(do-test "imported symbols :internal"
(and
(eq :internal (second (multiple-value-list (find-symbol "RATIONAL" 'im-bar))))
(eq :internal (second (multiple-value-list (find-symbol "PLUSP" 'im-bar))))
)
)
)
STOP

View File

@@ -1 +1,53 @@
;; Function To Be Tested: do-all-symbols
;; Function To Be Tested: do-all-symbols
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 188
;;
;; Created By: John Park
;;
;; Creation Date: Oct 28, 1986
;;
;; Last Update: Mar 24, 1987
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-do-all-symbols.test
;;
;;
;; Syntax: (do-all-symbols (var [result-form]) {declaration}*
;; {tag| statement}*
;;
;; Function Description: This is similar to do-symbols but executes the body once
;; for every symbol contained in every package. (This will not process every
;; symbol whatsoever, because a symbol not accessible in any package.) It is not
;; in general the case that each symbol is processed only once, because a symbol
;; may appear in many packages.
;;
;;
;; Argument(s): var (bound to the symbol)
;; package
;; result-form (a single form)
;;
;; Returns: value of the do-all-symbols form
;;
;; Constraints/Limitations: Since do-all-symbols will executes the body for every
;; symbol contained in every package, this test may take unreasonably a long time.
;; In order to execute this test within a reasonable amount of time (i.e. 5 min)
;; do-all-symbols-test package will stop at the third package of package list.
(do-test "do-all-symbols-test"
(let ((p3 (third (list-all-packages))))
(catch 'stop-at-third-package
(do-all-symbols (s (null s))
(when (and (symbolp s)
(eq (symbol-package s) p3))
(throw 'stop-at-third-package t)
)
)
)
)
)
STOP

View File

@@ -1 +1,64 @@
;; Function To Be Tested: do-external-symbols
;; Function To Be Tested: do-external-symbols
;;
;; Source: Guy L Steele's CLtL
;; Section: 11.7 Package System Functions and Variables
;; Page: 187
;;
;; ReCreated By: Ron Fischer
;;
;; Creation Date: Mar 23, 1987
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-do-external-symbols.test
;;
;;
;; Syntax: (do-external-symbols (var [package [result-form]]) {declaration}*
;; {tag| statement}*
;;
;; Function Description: do-external-symbols is just like do-symbols, except that
;; only the external symbols of the specified package are scanned.
;;
;;
;; Argument(s): var (bound to the symbol)
;; package
;; result-form (a single form)
;;
;; Returns: value of the do-external-symbols form
;;
;; Constraints/Limitations: none
(do-test "do-external-symbols"
(let* ((package (make-package "DO-EXTERNAL-PACKAGE" :use NIL))
(external-names '("EXTERNAL-FOO" "EXTERNAL-BAR" "EXTERNAL-BAZ"))
(internal-names '("FOO" "BAR" "BAZ"))
(external-symbols)
)
(dolist (name (append external-names internal-names))
(intern name package)
)
(dolist (name external-names)
(let ((symbol (intern name package)))
(export symbol package)
(push symbol external-symbols)
)
)
(and
(let ((checking external-symbols))
(do-external-symbols (s package (and (null s) (null checking)))
(if (and (symbolp s) (member s checking :test #'string=))
(setq checking (remove s checking :test #'string=))
(return nil)
)
)
)
(delete-package "DO-EXTERNAL-PACKAGE")
)
)
)
STOP

View File

@@ -1 +1,81 @@
;; Function To Be Tested: do-symbols
;; Function To Be Tested: do-symbols
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 185
;;
;; ReCreated By: Ron Fischer
;;
;; Creation Date: March 24, 1987
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-do-symbols.test
;;
;;
;; Syntax: (do-symbols (var [package [result-form]]) {declaration}*
;; {tag| statement}*
;;
;; Function Description: do-symbols provides straightforward iteration over the
;; symbols of a package. The body is performed once for each symbol accessible
;; in the package, in no particular order, with the variable var bound to the
;; symbol. Then result-form (a single form, not an implicit progn) is evaluated,
;; and the result is the value of the do-symbols form. (When the result-form is
;; evaluated, the control variable var is still bound and has the value of nil.)
;; If the result-form is omitted, the result is nil. return may be used to terminate
;; the iteration prematurely. If execution of the body affects which symbols are
;; contained in the package, other than possibly to remove the symbol currently
;; the value of var by using unintern, the effects are unpredictable.
;;
;;
;; Argument(s): var (bound to the symbol)
;; package
;; result-form (a single form)
;;
;; Returns: value of the do-symbols form
;;
;; Constraints/Limitations: none
;;
;; Test description: creates two packages, one inherited by the other. Interns a
;; small number of known symbols in both packages. For each package we remember the
;; list of symbols expected to be found there and then do-symbols over the package.
;; At each iteration we remove the name we found there. NIL is returned if either
;; an unknown symbol is found in the package or not all the symbols are found.
(do-test "do-symbols"
(let* ((inherited-package (make-package "INHERITED-PACKAGE" :use NIL))
(direct-package (make-package "DIRECT-PACKAGE" :use "INHERITED-PACKAGE"))
(direct-symbols '("FOO" "BAR" "BAZ" "GLORP"))
(inherited-symbols '("IFOO" "IBAR" "IBAZ" "IGLORP"))
)
(dolist (name direct-symbols) (intern name direct-package))
(dolist (name inherited-symbols)
(export (intern name inherited-package) inherited-package)
)
(and
(let ((checking inherited-symbols))
(do-symbols (s inherited-package (and (null s) (null checking)))
(if (and (symbolp s) (member s checking :test #'string=))
(setq checking (remove s checking :test #'string=))
(return nil)
)
)
)
(let ((checking (append inherited-symbols direct-symbols)))
(do-symbols (s direct-package (and (null s) (null checking)))
(if (and (symbolp s) (member s checking :test #'string=))
(setq checking (remove s checking :test #'string=))
(return nil)
)
)
)
(delete-package "INHERITED-PACKAGE")
(delete-package "DIRECT-PACKAGE")
)
)
)
STOP

View File

@@ -1 +1,67 @@
;; Function To Be Tested: export
;; Function To Be Tested: export
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 186
;;
;; Created By: John Park
;;
;; Creation Date: Nov 6, 1986
;;
;; Last Update: Oct 21, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-export.test
;;
;;
;; Syntax: (export symbols &optional package)
;;
;; Function Description: The function export takes a symbol that is accessible in some
;; specified package (directly or by inheritance) and makes it an external symbol of
;; that package. If the symbol is already accessible as an external symbol in the
;; package, export has no effect. If the symbol is directly present in the package as
;; an internal symbol via use-package, the symbol is first imported into the package,
;; then exported. (The symbol is then present in the specified package whether or not
;; the package continues to use the package through which the symbol was originally
;; inherited.) If the symbol is not accessible at all in the specified package,
;; a correctable error is signalled that, upon continuing, asks the user whether the
;; symbol should be imported. By convention, a call to export listing all exported
;; symbols is placed near the start of a file to advertise which of the symbols
;; mentioned
;; in the file are intended to be used by other programs.
;;
;;
;; Argument(s): symbols (list or a single symbol)
;; package (optional)
;;
;; Returns: T
;;
;; Constraints/Limitations: none
;;
(do-test "export-test"
(and (import '(lisp:machine-type) 'USER)
(let ((SYM1 (intern "MACHINE-TYPE" 'USER)))
(and (eq SYM1 'USER::MACHINE-TYPE)
(eq :internal
(second (multiple-value-list
(find-symbol "MACHINE-TYPE" 'USER))))
)
)
(eq (export '(USER::MACHINE-TYPE) 'USER) T)
(let ((SYM2 (intern "MACHINE-TYPE" 'USER)))
(and (eq SYM2 'USER::MACHINE-TYPE)
(eq :external
(second (multiple-value-list
(find-symbol "MACHINE-TYPE" 'USER))))
)
)
)
)
STOP

View File

@@ -1 +1,38 @@
;; Function To Be Tested: find-all-sym\bols
;; Function To Be Tested: find-all-sym\bols
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 187
;;
;; Created By: John Park
;;
;; Creation Date: Oct 22, 1986
;;
;; Last Update: Nov 6, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-find-all-symbols.test
;;
;;
;; Syntax: (find-all-symbols string-or-symbol)
;;
;; Function Description: This function searches every package in the LISP system
;; for symbols whose print-name is the specified string, and returns a list of
;; such symbols. If a symbol is specified, its print name is used.
;;
;; Argument(s): Symbol(s)
;; Package (optional)
;;
;; Returns: list of symbols
;;
;; Constraints/Limitations: none
(do-test "find-all-symbols"
(and (member 'SETQ (find-all-symbols "SETQ"))
(member 'MAP (find-all-symbols 'MAP))
)
)
STOP

View File

@@ -1 +1,41 @@
;; Function To Be Tested: find-package
;; Function To Be Tested: find-package
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 183
;;
;; Created By: John Park
;;
;; Creation Date: Sep 16,1986
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-find-package.test
;;
;;
;; Syntax: (find-package name)
;;
;; Function Description: This function returns the package with specified name or
;; nickname.
;;
;; Argument(s): The name must be a string that is the name or nickname for a package.
;; This argument may also be a symbol, in which case the symbol's print name is used.
;;
;; Returns: package-name
;;
;; Constraints/limitations: None
(do-test-group (find-package-test-setup
:before (progn
(setq test-package1 (make-package "test-1"))
(setq test-package2 (make-package "test-2"
:nicknames '("system" "module")))))
(do-test "make-package"
(and (eq (find-package "test-1") test-package1)
(eq (find-package "test-2") test-package2)
(eq (find-package "system") test-package2)
(eq (find-package "module") test-package2))))
STOP

View File

@@ -1 +1,61 @@
;; Function To Be Tested: find-symbol
;; Function To Be Tested: find-symbol
;;
;; Source: Guy L Steele's CLTL Package System
;; Section: 11.8 Package System and Variables
;; Page: 185
;;
;; Created By: John Park
;;
;; Creation Date: Oct 10, 1986
;;
;; Last Update: Nov 6, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-find-symbol.test
;;
;;
;; Syntax: (find-symbol string &optional package)
;;
;; Function Description: This is identical to intern, but it never creates a new
;; symbol. If a symbol with the specified name is found in the specified package,
;; directly or by inheritance, the symbol found is returned as the first value and
;; the second value is as specified for intern. If the symbol is not accessible
;; in the specified package, both values are nil.
;;
;;
;;
;; Argument(s): string
;; package (&optional)
;;
;;
;; Returns: Two values (symbol and symbol status) if symbol if found.
;; or NIL if symbol is not found.
;;
;; Constraints/Limitations: None
;;
(do-test "find-symbol-test"
(and (let ((find-sym-list
(multiple-value-list (find-symbol "COS" (FIND-PACKAGE 'USER)))))
(and (eq (first find-sym-list) 'COS)
(eq :INHERITED (second find-sym-list))
)
)
(intern "XYZ" 'USER)
(let ((find-sym-list-1
(multiple-value-list (find-symbol "XYZ" (FIND-PACKAGE 'USER)))))
(and (eq (first find-sym-list-1) 'USER::XYZ)
(eq :INTERNAL (second find-sym-list-1))
)
)
(eq (find-symbol "JUNK" (find-package 'KEYWORD)) NIL)
)
)
STOP

View File

@@ -1 +1,51 @@
;; Function To Be Tested: import
;; Function To Be Tested: import
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 186
;;
;; Created By: Ron Fischer (original file by John Park)
;;
;; Creation Date: Oct 30, 1986
;;
;; Last Update: March 24, 1987
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-import.test
;;
;;
;; Syntax: (import symbols &optional package)
;;
;; Function Description: The argument should be a list of symbols, or possibly
;; a single symbol. These symbols become internal symbols in package and can
;; therefore be referred to without having to use qualified-name (colon) syntax.
;; import signals a correctable error if any of the imported symbols has the same
;; name as some distinct symbol already accessible in the package. Import returns T.
;;
;; Argument(s): Symbol(s)
;; Package (optional)
;;
;; Returns: T
;;
;; Constraints/Limitations: none
(do-test-group
(import-group
:before (setq im-foo (make-package "IMPORT-BAR" :use nil))
:after (delete-package "IMPORT-BAR")
)
(do-test "import returns T"
(eq (import '(lisp:rational lisp:plusp) 'IMPORT-bar) T)
)
(do-test "symbols imported from LISP"
(and
(eq 'lisp:rational (find-symbol "RATIONAL" 'IMPORT-bar))
(eq 'lisp:plusp (find-symbol "PLUSP" 'IMPORT-bar))
)
)
(do-test "imported symbols :internal"
(and
(eq :internal (second (multiple-value-list (find-symbol "RATIONAL" 'IMPORT-bar))))
(eq :internal (second (multiple-value-list (find-symbol "PLUSP" 'IMPORT-bar))))
)
)
)
STOP

View File

@@ -1 +1,57 @@
;; Function To Be Tested: in-package
;; Function To Be Tested: in-package
;;
;; Source: Guy L Steele's CLTL Package System
;; Section: 11.7 Package System and Variables
;; Page: 187
;;
;; Created By: John Park
;;
;; Creation Date: Oct 7, 1986
;;
;; Last Update: Oct 16, 86
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-in-package.test
;;
;;
;; Syntax: (in-package package-name &key :nicknames :use)
;;
;; Function Description: This function is intended to be placed at the start of a
;; file containing a subsystem that is to be loaded into some package other than
;; USER. If there is not already a package with the specified name, one is created
;; as with make-package. If there is an existing package, it is augumented to
;; reflect any new nicknames or used packages.
;;
;;
;; Argument(s): package-name: string or symbol
;; nicknames (key): list of string(s)
;; use: list of string(s) or symbol(s)
;;
;;
;; Returns: package-name or nil
;;
;; Constraints/Limitations: This file may be similar to other files that test
;; package functions as a file may use the following or combinations of the
;; following forms:
;; (provide ...)
;; (in-package...)
;; (shadow...)
;; (export...)
;; (require...)
;; (use-package...)
;; (import...)
;;
(do-test "in-package"
(and (boundp '*package*)
(in-package 'foo0 :use 'user)
(eq *package* (find-package 'foo0))
(in-package 'lisp)
(eq *package* (find-package 'lisp))
(in-package 'user)
(eq *package* (find-package 'user))))
STOP

View File

@@ -1 +1,69 @@
;; Function To Be Tested: intern
;; Function To Be Tested: intern
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Created By: John Park
;;
;; Creation Date: Oct 17, 1986
;;
;; Last Update: JAN 14, 1987
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-intern.test
;;
;;
;; Syntax: (intern string &optional package)
;;
;; Function Description: The package, which defaults to the current package, is
;; searched for a symbol with the name specified by the string argument. This search
;; will include inherited symbols, as described in section 11.4. If a symbol with
;; the specified name is found, it is returned. If no such symbol is found, one is
;; created and is installed in the specified package as an internal symbol
;; (as an external symbol if the package is the keyword package)- the specified
;; package becomes the home package of the created symbol.
;;
;; Argument(s): package
;;
;; Returns: Two values: The first is the symbol that was found or created.
;; The second value is nil if no pre-existing symbol was found, and takes on one of
;; three values if a symbol was found:
;;
;; :internal - The symbol was directly present in the package as an internal symbol.
;; :external - The symbol was directly present as an external symbol.
;; :inherited - The symbol was inherited via use-package (which implies that the
;; symbol is internal.
;;
;; Constraints/Limitations: none
(do-test "intern-test-internal"
;; Also test import function.
(and (eq :inherited (second (multiple-value-list
(find-symbol "SOFTWARE-TYPE" 'USER))))
(import '(lisp:software-type) 'USER)
(let ((SYM (intern "SOFTWARE-TYPE" 'USER)))
(and (eq SYM 'USER::SOFTWARE-TYPE)
(eq :internal
(second (multiple-value-list
(find-symbol "SOFTWARE-TYPE" 'USER))))
)
)
)
)
(do-test "intern-test-external"
;; Also test export function.
(and (export '(USER::SOFTWARE-TYPE) 'USER)
(eq :external
(second (multiple-value-list (find-symbol "SOFTWARE-TYPE" 'USER))))
(unintern 'SOFTWARE-TYPE 'USER)
)
)
STOP

View File

@@ -1 +1,45 @@
;; Function To Be Tested: list-all-packages
;; Function To Be Tested: list-all-packages
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Created By: John Park
;;
;; Creation Date: Aug 15, 1986
;;
;; Last Update: Oct 21, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-list-all-packages.test
;;
;;
;; Syntax: (list-all-packages)
;;
;; Function Description: A list of other packages that currently exist in
;; the lisp system.
;;
;; Argument(s): none
;;
;;
;; Returns: List of packages
;;
;; Constraints/Limitations: none
(do-test "list-all-packages-test"
(and (member (find-package 'LISP) (list-all-packages))
(member (find-package 'SYSTEM) (list-all-packages))
(member (find-package 'KEYWORD) (list-all-packages))
(member (find-package 'USER) (list-all-packages))
(make-package "FOO-PACK")
(member (find-package 'FOO-PACK) (list-all-packages))
(notany #'null (mapcar #'packagep (list-all-packages)))
)
)
STOP

View File

@@ -1 +1,80 @@
;; Function To Be Tested: make-package
;; Function To Be Tested: make-package
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 183
;;
;; Created By: John Park
;;
;; Creation Date: Aug 13,1986
;;
;; Last Update: Oct 17, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-make-package.test
;;
;;
;; Syntax: (make-package package-name &key :nicknames :use)
;;
;; Function Description: This function creates and returns a new package with the
;; specified package name.
;;
;; Argument(s): package-name: string or symbol
;; nicknames: list of strings to be used as alternative names
;; for the package
;; use: list of packages or the names (strings or symbols) of
;; packages whose external symbols are to be inherited by
;; the new package.
;;
;; Returns: package-name
;;
(do-test "*package*-exists?"
(and (boundp '*package*)
(packagep *package*)
)
)
(do-test "make-package-test1"
(and (make-package "PACK-EX")
(make-package "PACK-WY")
(make-package 'PACK-ZEE)
(not(eq (member (find-package 'PACK-EX)(list-all-packages))
NIL))
(not (eq (member (find-package 'PACK-WY)(list-all-packages))
NIL))
(not (eq (member (find-package 'PACK-ZEE)(list-all-packages))
NIL))
(if (fboundp 'delete-package)
(progn (delete-package (find-package 'PACK-EX))
(delete-package (find-package 'PACK-WY))
(delete-package (find-package 'PACK-ZEE))
(identity T) ; T is returned when a package is deleted
)
T)
)
)
(do-test "make-package-test2"
(and (make-package "NEW-PACK"
:nicknames '("NP1" "NP2")
:use 'LISP)
(member (find-package 'lisp)
(package-use-list (find-package 'new-pack)))
(or (equal (package-nicknames (find-package 'new-pack))
'("NP2" "NP1"))
(equal (reverse (package-nicknames (find-package 'new-pack)))
'("NP2" "NP1"))
)
(if (fboundp 'delete-package) ; delete the package
(progn (delete-package (find-package 'new-pack))
(identity T)
)
T)
)
)
STOP

View File

@@ -1 +1,49 @@
;; Function To Be Tested: package-name
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Created By: John Park
;;
;; Creation Date: Aug 13,1986
;;
;; Last Update: Dec 15, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-package-name.test
;;
;;
;; Syntax: (package-name package)
;;
;; Function Description: This function returns the string that names that
;; package.
;;
;; Argument(s): package-name
;;
;; Returns: string that names that package
;;
;; Constraints/Limitations: none
(do-test "package-name-test"
(and (setq PACKAGE-A (make-package "FIRST-PACK"))
(setq PACKAGE-B (make-package "SECOND-PACK"))
(equal (package-name PACKAGE-A) "FIRST-PACK")
(equal (package-name PACKAGE-B) "SECOND-PACK")
(equal (package-name (find-package 'USER)) "USER")
(equal (package-name (find-package 'LISP)) "LISP")
(stringp (package-name *package*))
(if (fboundp 'delete-package)
(progn (delete-package package-a)
(delete-package package-b)
(identity T)
)
T)
)
)
STOP

View File

@@ -1 +1,46 @@
;; Function To Be Tested: package-nicknames
;; Function To Be Tested: package-nicknames
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Creation Date: Aug 13,1986 John Park
;;
;; Last Update: March 24, 1987 Ron Fischer
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-package-nicknames.test
;;
;;
;; Syntax: (package-nicknames package)
;;
;; Function Description: This function returns the list of nickname strings for
;; that package.
;;
;; Argument(s): package
;;
;; Returns: nicknames for the package
;;
;; Constraints/Limitations: Checks to be sure that the SYSTEM package has nickname SYS.
;; Does generic check that nicknames are on the nickname list and also makes sure that
;; any prefix-name becomes a nickname.
(do-test "package-nicknames-test"
(and (some
#'(lambda (name) (string= name "SYS"))
(package-nicknames 'system)
)
(make-package "ALCHEMY" :prefix-name "ALCHEM" :nicknames '("METALS" "GOLD"))
(every
#'(lambda (name) (member name '("GOLD" "METALS" "ALCHEM") :test #'string=))
(package-nicknames 'alchemy)
)
(delete-package 'alchemy)
)
)
STOP

View File

@@ -1 +1,48 @@
;; Function To Be Tested: package-shadowing-symbols
;; Function To Be Tested: package-shadowing-symbols
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 183
;;
;; Created By: John Park
;;
;; Creation Date: Oct 23, 1986
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-package-shadowing-symbols.test
;;
;;
;; Syntax: (package-shadowing-symbols package)
;;
;; Function Description: A list is returned of symbols that have been declared as
;; shadowing symbols in this package by shadow or shadowing-import. All symbols
;; on this list are present in the specified package.
;;
;; Argument(s): package
;;
;; Returns: A list of symbols declared as shadowing symbols
;;
;; Constraints/Limitations: none
(do-test "package-shadowing-symbols-test"
(and (setq barr2 (in-package "BAZ2"))
(lisp:in-package 'lisp)
(member (find-package 'LISP) (package-use-list barr2))
(setq blap2 (in-package "FRUMBLE2" :use NIL))
(lisp:in-package 'lisp)
(use-package blap2 barr2)
(intern "HURM" blap2)
(intern "OK" blap2)
(shadow '(HURM OK) barr2)
(equal (mapcar #'string
(package-shadowing-symbols (find-package 'baz2)))
'("OK" "HURM"))
)
)
STOP

View File

@@ -1 +1,46 @@
;; Function To Be Tested: package-use-list
;; Function To Be Tested: package-use-list
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Created By: John Park
;;
;; Creation Date: Aug 14,1986
;;
;; Last Update: Oct 22, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-package-use-list.test
;;
;;
;; Syntax: (package-use-list package)
;;
;; Function Description: A list of other packages used by thae argument package
;; is returned.
;;
;; Argument(s): package
;;
;; Returns: package(s)
;;
;; Constraints/Limitations: none
(do-test "package-use-test"
(and (setq use-package-1 (make-package "USE-PACK-1"))
(member (find-package 'lisp) (package-use-list use-package-1))
(setq use-package-2 (make-package "USE-PACK-2" :use 'SYSTEM))
(member (find-package 'system) (package-use-list use-package-2))
(setq foo-package-1 (make-package "FOO-PACK-1" :use NIL))
(eq (package-use-list foo-package-1) nil)
(setq foo-package-2 (make-package "FOO-PACK-2"))
(use-package '(use-pack-1 use-pack-2) 'FOO-PACK-2)
(member (find-package 'use-pack-1) (package-use-list foo-package-2))
(member (find-package 'use-pack-2) (package-use-list foo-package-2))
(member (find-package 'lisp) (package-use-list foo-package-2))
)
)
STOP

View File

@@ -1 +1,53 @@
;; Function To Be Tested: package-used-by-list
;; Function To Be Tested: package-used-by-list
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Created By: John Park
;;
;; Creation Date: Aug 15, 1986
;;
;; Last Update: Dec 22, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-package-used-by-list.test
;;
;;
;; Syntax: (package-used-by-list package )
;;
;; Function Description: A list of other packages that use the argument package
;; is returned.
;;
;; Argument(s): package
;;
;;
;; Returns: List of packages
;;
;; Constraints/Limitations: none
(do-test "package-used-by-list"
(and (member (find-package 'USER)
(package-used-by-list (find-package 'LISP)))
(eq (package-used-by-list (find-package 'KEYWORD)) NIL)
(make-package 'XYZ :use '("USER" "SYSTEM"))
(member (find-package 'XYZ)
(package-used-by-list (find-package 'USER)))
(member (find-package 'XYZ)
(package-used-by-list (find-package 'SYSTEM)))
(if (fboundp 'delete-package)
(progn (delete-package (find-package 'XYZ))
(identity T)
)
T)
)
)
STOP

View File

@@ -1 +1,58 @@
;; Function To Be Tested: rename-package
;; Function To Be Tested: rename-package
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 184
;;
;; Created By: John Park
;;
;; Creation Date: Aug 14,1986
;;
;; Last Update: Dec 16, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-rename-package.test
;;
;;
;; Syntax: (rename-package package new-name &optional new-nicknames)
;;
;; Function Description: The old name and all of the old nicknames of package
;; are eliminated and are replaced by new-name and new-nicknames.
;;
;; Argument(s): package
;; new-name: string or symbol
;; new-nicknames: list of strings or symbols
;;
;; Returns: nicknames for the package
;;
;; Constraints/Limitations: none
(do-test "rename-package"
(let ((test-package-1 (make-package 'old-package-1))
(test-package-2 (make-package 'old-package-2
:nicknames '("OLD-FOO" "OLD-BAR"))))
(and (rename-package test-package-1 "NEW-PACKAGE-1")
(rename-package test-package-2 "NEW-PACKAGE-2"
'("NEW-FOO" "NEW-BAR"))
(equal (package-name test-package-1) "NEW-PACKAGE-1")
(equal (package-name test-package-2) "NEW-PACKAGE-2")
(or (equal (package-nicknames test-package-2)
'("NEW-BAR" "NEW-FOO"))
(equal (reverse (package-nicknames test-package-2))
'("NEW-BAR" "NEW-FOO"))
)
(not (member (find-package 'old-package-1) (list-all-packages)))
(not (member (find-package 'old-package-2) (list-all-packages)))
(if (fboundp 'delete-package)
(progn (delete-package (find-package 'new-package-1))
(delete-package (find-package 'new-package-2))
(identity T)
)
T)
)
)
)
STOP

View File

@@ -1 +1,47 @@
;; Function To Be Tested: shadow
;; Function To Be Tested: shadow
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 185
;;
;; Created By: John Park
;;
;; Creation Date: Oct 22, 1986
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-shadow.test
;;
;;
;; Syntax: (shadow symbols &optional package)
;;
;; Function Description: This function extracts the print name of each symbol and
;; searches the package (defaulting to the current package) for a symbol with that
;; name. If such a symbol is directly present in the package, then nothing is done.
;; Otherwise, a new symbol is created with the print name, and it is inserted in the
;; package as an internal symbol. The symbol is also placed on the shadowing symbols
;; list of the package.
;;
;;
;; Argument(s): symbol(s) package (optional)
;;
;; Returns: T
;;
;; Constraints/Limitations: none
(do-test "unintern"
(and (setq barr1 (make-package "BAZ1"))
(member (find-package 'LISP) (package-use-list barr1))
(setq blap1 (make-package "FRUMBLE1" :use NIL))
(use-package blap1 barr1)
(set (intern "HURM1" blap1) 52)
(shadow 'HURM1 barr1)
(not (boundp (intern "HURM1" barr1)))
)
)
STOP

View File

@@ -1 +1,59 @@
;; Function To Be Tested: shadowing-import
;; Function To Be Tested: shadowing-import
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 186
;;
;; ReCreated By: Ron Fischer
;;
;; Creation Date: Oct 29, 1986
;;
;; Last Update: March 24, 1987
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-shadowing-import.test
;;
;;
;; Syntax: (shadowing-import symbols &optional package)
;;
;; Function Description: This is like import, but it does not signal an error even
;; if the importation of a symbol would shadow some symbol already accessible in
;; the package. In additionto being imported, the symbol is placed on the
;; shadowing-symbols list of package.
;;
;; Argument(s): Symbol(s)
;; Package (optional)
;;
;; Returns: T
;;
;; Constraints/Limitations: none
(do-test-group
(package-shadowing-symbols-group
:before (progn
(make-package 'inherited :use nil)
(make-package 'direct :use 'inherited)
(export (intern "CAR" 'inherited) 'inherited)
)
:after (progn
(delete-package 'direct)
(delete-package 'inherited)
)
)
(do-test "import causes error on conflict"
(expect-errors import-conflict
(import '(lisp:car) 'direct)
)
)
(do-test "shadowing-import doesn't cause error on conflict"
(shadowing-import '(lisp::car) 'direct)
)
(do-test "shadowing symbol on package's list"
(member 'lisp::car (package-shadowing-symbols 'direct))
)
)
STOP

View File

@@ -1 +1,68 @@
;; Function To Be Tested: unexport
;; Function To Be Tested: unexport
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 186
;;
;; Created By: John Park
;;
;; Creation Date: Oct 21, 1986
;;
;; Last Update: Dec 22, 1986
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-unexport.test
;;
;;
;; Syntax: (unexport symbols &optional package)
;;
;; Function Description: The function unexport is provided mainly as a way to undo
;; erroneous calls to export. It works only on symbols directly present in the current
;; package, switching them back to internal status. If unexport is given a symbol
;; already accessible as an internal symbol in the current package, it does nothing.
;; If it is given a symbol not accessible in the package at all, it signals an error.
;; It is also an error to unexport a symbol from the keyword package.
;;
;;
;; Argument(s): symbols (list or a single symbol)
;; package (optional)
;;
;; Returns: T
;;
;; Constraints/Limitations: none
(do-test "unexport-test-1"
(and (import 'new-symbol)
(equal :INTERNAL
(second (multiple-value-list (find-symbol "NEW-SYMBOL"))))
(export 'new-symbol)
(equal :EXTERNAL
(second (multiple-value-list (find-symbol "NEW-SYMBOL"))))
(eq (unexport '(NEW-SYMBOL)) T)
(equal :INTERNAL
(second (multiple-value-list (find-symbol "NEW-SYMBOL"))))
)
)
(do-test "unexport-test-2"
(let ((*test-package* (find-package 'lisp)))
(and (import 'new-symbol-xyz *test-package*)
(equal :INTERNAL
(second (multiple-value-list
(find-symbol "NEW-SYMBOL-XYZ" *test-package*))))
(export 'new-symbol-xyz *test-package*)
(equal :EXTERNAL
(second (multiple-value-list
(find-symbol "NEW-SYMBOL-XYZ" *test-package*))))
(eq (unexport '(NEW-SYMBOL-XYZ) *test-package*) T)
(equal :INTERNAL
(second (multiple-value-list
(find-symbol "NEW-SYMBOL-XYZ" *test-package*))))
)
)
)
STOP

View File

@@ -1 +1,61 @@
;; Function To Be Tested: unintern
;; Function To Be Tested: unintern
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 185
;;
;; ReCreated By: Ron Fischer
;;
;; Creation Date: Oct 22, 1986
;;
;; Last Update: Mar 24, 1987
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-unintern.test
;;
;;
;; Syntax: (unintern string &optional package)
;;
;; Function Description: If the specified symbol is present in the specified package,
;; it is removed from that package and also from the package's shadowing-symbols list
;; if it is present there. Moreover, if the package is the home package for the symbol,
;; the symbol is made to have no home package. Note that in some circumstances the
;; symbol may continue to be accessible in the specified package by inheritance.
;;
;;
;; Argument(s): package
;;
;; Returns: unintern returns t if it actually removed a symbol, and nil otherwise.
;;
;; Constraints/Limitations: none
(do-test-group
("unintern"
:before (progn
(make-package 'hurm :use nil)
(intern "HURM" 'hurm)
)
:after (delete-package 'hurm)
)
(do-test "symbol interned"
(and (string= "HURM" (find-symbol "HURM" 'hurm))
(eq :internal
(second (multiple-value-list (find-symbol "HURM" 'hurm)))
)
)
)
(do-test "uninterning symbol"
(unintern (find-symbol "HURM" 'hurm) 'hurm)
)
(do-test "unintern returns NIL for symbol not in package"
(null (unintern 'lisp:car 'hurm))
)
(do-test "symbol uninterned"
(null (find-symbol "HURM" 'hurm))
)
)
STOP

View File

@@ -1 +1,46 @@
;; Function To Be Tested: unuse-package
;; Function To Be Tested: unuse-package
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 187
;;
;; Created By: John Park
;;
;; Creation Date: Oct 15, 1986
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-unuse-package.test
;;
;;
;; Syntax: (unuse-package packages-to-unuse &optional package)
;;
;; Function Description: This function removes the packages-to-unuse from the
;; use-list of the specified package, which defaults to the current package.
;; The pacakges-to-unuse can be a package or package name, or a list of such.
;;
;; Argument(s): packages-to-unuse: list of packages or package names.
;; package (&optional)
;;
;;
;; Returns: T
;;
;; Constraints/Limitations: none
(do-test "unuse-package-test"
(and (setq foo2 (make-package "BAR2" :use nil))
(eq (package-use-list foo2) nil)
(eq (use-package 'lisp 'bar2) T)
(member (find-package 'lisp) (package-use-list foo2))
(eq (unuse-package 'lisp 'bar2) T)
(not (member (find-package 'lisp) (package-use-list foo2)))
)
)
STOP

View File

@@ -1 +1,45 @@
;; Function To Be Tested: use-package
;; Function To Be Tested: use-package
;;
;; Source: Guy L Steele's CLTL
;; Section: 11.7 Package System Functions and Variables
;; Page: 187
;;
;; Created By: John Park
;;
;; Creation Date: Oct 15, 1986
;;
;; Last Update:
;;
;; Filed As: {ERIS}<LISPCORE>CML>TEST>11-7-use-package.test
;;
;;
;; Syntax: (use-package packages-to-use &optional package)
;;
;; Function Description: The packages-to-use argument should be a list of packages
;; or package names, or possibly a single package or package name. These packages
;; are added to the use-list of package if they are not there already. All external
;; symbols in the packages to use become accessible in package as internal symbols.
;;
;; Argument(s): packages-to-use: list of packages or package names.
;; package (&optional)
;;
;;
;; Returns: t
;;
;; Constraints/Limitations: none
(do-test "use-package-test"
(and (setq foo1 (make-package "BAR" :use nil))
(eq (package-use-list foo1) nil)
(eq (use-package 'lisp 'bar) T)
(not (eq (member (find-package 'lisp) (package-use-list foo1)) NIL))
)
)
STOP

Some files were not shown because too many files have changed in this diff Show More