From ac10c4067a5401a6088ba6ba95f371e57af5714b Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 19:31:55 -0500 Subject: [PATCH 001/194] Better method for getting last digits of an integer --- extra/project-euler/032/032.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index 2baa6f8714..e03ab6f89b 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: combinators.lib hashtables kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences ; +USING: combinators.lib hashtables kernel math math.combinatorics math.functions + math.parser math.ranges project-euler.common sequences ; IN: project-euler.032 ! http://projecteuler.net/index.php?section=problems&id=32 @@ -41,7 +41,7 @@ IN: project-euler.032 dup 1and4 swap 2and3 or ; : products ( seq -- m ) - [ number>string 4 tail* 10 string>integer ] map ; + [ 10 4 ^ mod ] map ; PRIVATE> @@ -49,7 +49,7 @@ PRIVATE> source-032 [ valid? ] subset products prune sum ; ! [ euler032 ] 10 ave-time -! 27609 ms run / 2484 ms GC ave time - 10 trials +! 23922 ms run / 1505 ms GC ave time - 10 trials ! ALTERNATE SOLUTIONS From 1954114d85e75a13b2274a093af8d4f94372f024 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sat, 2 Feb 2008 19:42:47 -0500 Subject: [PATCH 002/194] Solution to Project Euler problem 48 --- extra/project-euler/048/048.factor | 25 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 ++-- 2 files changed, 27 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/048/048.factor diff --git a/extra/project-euler/048/048.factor b/extra/project-euler/048/048.factor new file mode 100644 index 0000000000..ba58792987 --- /dev/null +++ b/extra/project-euler/048/048.factor @@ -0,0 +1,25 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math math.functions ; +IN: project-euler.048 + +! http://projecteuler.net/index.php?section=problems&id=48 + +! DESCRIPTION +! ----------- + +! The series, 1^1 + 2^2 + 3^3 + ... + 10^10 = 10405071317. + +! Find the last ten digits of the series, 1^1 + 2^2 + 3^3 + ... + 1000^1000. + + +! SOLUTION +! -------- + +: euler048 ( -- answer ) + 1000 [ 1+ dup ^ ] sigma 10 10 ^ mod ; + +! [ euler048 ] 100 ave-time +! 276 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler048 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index eb9d7d1300..d89453eb14 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.067 project-euler.075 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.048 project-euler.067 project-euler.075 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 16:15:03 -0500 Subject: [PATCH 003/194] Solution to Project Euler problem 41 --- extra/project-euler/041/041.factor | 40 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +-- 2 files changed, 42 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/041/041.factor diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor new file mode 100644 index 0000000000..60017f39a1 --- /dev/null +++ b/extra/project-euler/041/041.factor @@ -0,0 +1,40 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math.combinatorics math.parser math.primes sequences ; +IN: project-euler.041 + +! http://projecteuler.net/index.php?section=problems&id=41 + +! DESCRIPTION +! ----------- + +! We shall say that an n-digit number is pandigital if it makes use of all the +! digits 1 to n exactly once. For example, 2143 is a 4-digit pandigital and is +! also prime. + +! What is the largest n-digit pandigital prime that exists? + + +! SOLUTION +! -------- + +! Check 7-digit pandigitals because if the sum of the digits in any number add +! up to a multiple of three, then it is a multiple of three and can't be prime. +! I assumed there would be a 7-digit answer, but technically a higher 4-digit +! pandigital than the one given in the description was also possible. + +! 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 + 9 = 45 +! 1 + 2 + 3 + 4 + 5 + 6 + 7 + 8 = 36 +! 1 + 2 + 3 + 4 + 5 + 6 + 7 = 28 *** not divisible by 3 *** +! 1 + 2 + 3 + 4 + 5 + 6 = 21 +! 1 + 2 + 3 + 4 + 5 = 15 +! 1 + 2 + 3 + 4 = 10 *** not divisible by 3 *** + +: euler041 ( -- answer ) + { 7 6 5 4 3 2 1 } all-permutations + [ 10 swap digits>integer ] map [ prime? ] find nip ; + +! [ euler041 ] 100 ave-time +! 107 ms run / 7 ms GC ave time - 100 trials + +MAIN: euler041 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index d89453eb14..3433fe7154 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.048 project-euler.067 project-euler.075 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.048 project-euler.067 project-euler.075 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 17:18:10 -0500 Subject: [PATCH 004/194] Fix common Project Euler word alpha-num --- extra/project-euler/022/022.factor | 10 +++------- extra/project-euler/common/common.factor | 6 +++++- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index e9b0b5fbcf..9c8866b736 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -1,7 +1,6 @@ ! Copyright (c) 2007 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: io.files kernel math math.parser namespaces sequences sorting splitting - strings system vocabs ascii ; +USING: ascii io.files kernel math project-euler.common sequences sorting splitting ; IN: project-euler.022 ! http://projecteuler.net/index.php?section=problems&id=22 @@ -31,9 +30,6 @@ IN: project-euler.022 "extra/project-euler/022/names.txt" resource-path file-contents [ quotable? ] subset "," split ; -: alpha-value ( str -- n ) - [ string>digits sum ] keep length 9 * - ; - : name-scores ( seq -- seq ) dup length [ 1+ swap alpha-value * ] 2map ; @@ -43,9 +39,9 @@ PRIVATE> source-022 natural-sort name-scores sum ; ! [ euler022 ] 100 ave-time -! 59 ms run / 1 ms GC ave time - 100 trials +! 123 ms run / 4 ms GC ave time - 100 trials ! source-022 [ natural-sort name-scores sum ] curry 100 ave-time -! 45 ms run / 1 ms GC ave time - 100 trials +! 93 ms run / 2 ms GC ave time - 100 trials MAIN: euler022 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 50adbe4953..99bb3169c4 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,6 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.miller-rabin math.matrices math.parser math.primes.factors math.ranges namespaces - sequences sorting ; + sequences sorting unicode.case ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -8,6 +8,7 @@ IN: project-euler.common ! Problems using each public word ! ------------------------------- +! alpha-value - #22, #42 ! cartesian-product - #4, #27, #29, #32, #33 ! collect-consecutive - #8, #11 ! log10 - #25, #134 @@ -52,6 +53,9 @@ IN: project-euler.common PRIVATE> +: alpha-value ( str -- n ) + >lower [ CHAR: a - 1+ ] sigma ; + : cartesian-product ( seq1 seq2 -- seq1xseq2 ) swap [ swap [ 2array ] map-with ] map-with concat ; From c64fe3d07bfe6f91d22dcc586a81a289a82c255f Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Sun, 3 Feb 2008 18:42:45 -0500 Subject: [PATCH 005/194] Solution to Project Euler problem 42 --- extra/project-euler/012/012.factor | 3 - extra/project-euler/022/022.factor | 3 - extra/project-euler/042/042.factor | 74 ++++++++++++++++++++++++ extra/project-euler/042/words.txt | 1 + extra/project-euler/067/067.factor | 3 - extra/project-euler/common/common.factor | 4 ++ extra/project-euler/project-euler.factor | 5 +- 7 files changed, 82 insertions(+), 11 deletions(-) create mode 100644 extra/project-euler/042/042.factor create mode 100644 extra/project-euler/042/words.txt diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index 3d59549e69..583bad8f72 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -33,9 +33,6 @@ IN: project-euler.012 ! SOLUTION ! -------- -: nth-triangle ( n -- n ) - dup 1+ * 2 / ; - : euler012 ( -- answer ) 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; diff --git a/extra/project-euler/022/022.factor b/extra/project-euler/022/022.factor index 9c8866b736..5bd1797272 100644 --- a/extra/project-euler/022/022.factor +++ b/extra/project-euler/022/022.factor @@ -41,7 +41,4 @@ PRIVATE> ! [ euler022 ] 100 ave-time ! 123 ms run / 4 ms GC ave time - 100 trials -! source-022 [ natural-sort name-scores sum ] curry 100 ave-time -! 93 ms run / 2 ms GC ave time - 100 trials - MAIN: euler022 diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor new file mode 100644 index 0000000000..3d5f271374 --- /dev/null +++ b/extra/project-euler/042/042.factor @@ -0,0 +1,74 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: ascii combinators.lib io.files kernel math namespaces + project-euler.common sequences splitting ; +IN: project-euler.042 + +! http://projecteuler.net/index.php?section=problems&id=42 + +! DESCRIPTION +! ----------- + +! The nth term of the sequence of triangle numbers is given by, +! tn = n * (n + 1) / 2; so the first ten triangle numbers are: + +! 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, ... + +! By converting each letter in a word to a number corresponding to its +! alphabetical position and adding these values we form a word value. For +! example, the word value for SKY is 19 + 11 + 25 = 55 = t10. If the word value +! is a triangle number then we shall call the word a triangle word. + +! Using words.txt (right click and 'Save Link/Target As...'), a 16K text file +! containing nearly two-thousand common English words, how many are triangle +! words? + + +! SOLUTION +! -------- + + [ + dup nth-triangle , 1+ (triangle-upto) + ] [ + 2drop + ] if ; + +: triangle-upto ( n -- seq ) + [ 1 (triangle-upto) ] { } make ; + +PRIVATE> + +: euler042 ( -- answer ) + source-042 [ alpha-value ] map dup supremum + triangle-upto [ member? ] curry count ; + +! [ euler042 ] 100 ave-time +! 27 ms run / 1 ms GC ave time - 100 trials + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Use the inverse function of n * (n + 1) / 2 and test if the result is an integer + + + +: euler042a ( -- answer ) + source-042 [ alpha-value ] map [ triangle? ] count ; + +! [ euler042a ] 100 ave-time +! 25 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler042a diff --git a/extra/project-euler/042/words.txt b/extra/project-euler/042/words.txt new file mode 100644 index 0000000000..7177624d41 --- /dev/null +++ b/extra/project-euler/042/words.txt @@ -0,0 +1 @@ +"A","ABILITY","ABLE","ABOUT","ABOVE","ABSENCE","ABSOLUTELY","ACADEMIC","ACCEPT","ACCESS","ACCIDENT","ACCOMPANY","ACCORDING","ACCOUNT","ACHIEVE","ACHIEVEMENT","ACID","ACQUIRE","ACROSS","ACT","ACTION","ACTIVE","ACTIVITY","ACTUAL","ACTUALLY","ADD","ADDITION","ADDITIONAL","ADDRESS","ADMINISTRATION","ADMIT","ADOPT","ADULT","ADVANCE","ADVANTAGE","ADVICE","ADVISE","AFFAIR","AFFECT","AFFORD","AFRAID","AFTER","AFTERNOON","AFTERWARDS","AGAIN","AGAINST","AGE","AGENCY","AGENT","AGO","AGREE","AGREEMENT","AHEAD","AID","AIM","AIR","AIRCRAFT","ALL","ALLOW","ALMOST","ALONE","ALONG","ALREADY","ALRIGHT","ALSO","ALTERNATIVE","ALTHOUGH","ALWAYS","AMONG","AMONGST","AMOUNT","AN","ANALYSIS","ANCIENT","AND","ANIMAL","ANNOUNCE","ANNUAL","ANOTHER","ANSWER","ANY","ANYBODY","ANYONE","ANYTHING","ANYWAY","APART","APPARENT","APPARENTLY","APPEAL","APPEAR","APPEARANCE","APPLICATION","APPLY","APPOINT","APPOINTMENT","APPROACH","APPROPRIATE","APPROVE","AREA","ARGUE","ARGUMENT","ARISE","ARM","ARMY","AROUND","ARRANGE","ARRANGEMENT","ARRIVE","ART","ARTICLE","ARTIST","AS","ASK","ASPECT","ASSEMBLY","ASSESS","ASSESSMENT","ASSET","ASSOCIATE","ASSOCIATION","ASSUME","ASSUMPTION","AT","ATMOSPHERE","ATTACH","ATTACK","ATTEMPT","ATTEND","ATTENTION","ATTITUDE","ATTRACT","ATTRACTIVE","AUDIENCE","AUTHOR","AUTHORITY","AVAILABLE","AVERAGE","AVOID","AWARD","AWARE","AWAY","AYE","BABY","BACK","BACKGROUND","BAD","BAG","BALANCE","BALL","BAND","BANK","BAR","BASE","BASIC","BASIS","BATTLE","BE","BEAR","BEAT","BEAUTIFUL","BECAUSE","BECOME","BED","BEDROOM","BEFORE","BEGIN","BEGINNING","BEHAVIOUR","BEHIND","BELIEF","BELIEVE","BELONG","BELOW","BENEATH","BENEFIT","BESIDE","BEST","BETTER","BETWEEN","BEYOND","BIG","BILL","BIND","BIRD","BIRTH","BIT","BLACK","BLOCK","BLOOD","BLOODY","BLOW","BLUE","BOARD","BOAT","BODY","BONE","BOOK","BORDER","BOTH","BOTTLE","BOTTOM","BOX","BOY","BRAIN","BRANCH","BREAK","BREATH","BRIDGE","BRIEF","BRIGHT","BRING","BROAD","BROTHER","BUDGET","BUILD","BUILDING","BURN","BUS","BUSINESS","BUSY","BUT","BUY","BY","CABINET","CALL","CAMPAIGN","CAN","CANDIDATE","CAPABLE","CAPACITY","CAPITAL","CAR","CARD","CARE","CAREER","CAREFUL","CAREFULLY","CARRY","CASE","CASH","CAT","CATCH","CATEGORY","CAUSE","CELL","CENTRAL","CENTRE","CENTURY","CERTAIN","CERTAINLY","CHAIN","CHAIR","CHAIRMAN","CHALLENGE","CHANCE","CHANGE","CHANNEL","CHAPTER","CHARACTER","CHARACTERISTIC","CHARGE","CHEAP","CHECK","CHEMICAL","CHIEF","CHILD","CHOICE","CHOOSE","CHURCH","CIRCLE","CIRCUMSTANCE","CITIZEN","CITY","CIVIL","CLAIM","CLASS","CLEAN","CLEAR","CLEARLY","CLIENT","CLIMB","CLOSE","CLOSELY","CLOTHES","CLUB","COAL","CODE","COFFEE","COLD","COLLEAGUE","COLLECT","COLLECTION","COLLEGE","COLOUR","COMBINATION","COMBINE","COME","COMMENT","COMMERCIAL","COMMISSION","COMMIT","COMMITMENT","COMMITTEE","COMMON","COMMUNICATION","COMMUNITY","COMPANY","COMPARE","COMPARISON","COMPETITION","COMPLETE","COMPLETELY","COMPLEX","COMPONENT","COMPUTER","CONCENTRATE","CONCENTRATION","CONCEPT","CONCERN","CONCERNED","CONCLUDE","CONCLUSION","CONDITION","CONDUCT","CONFERENCE","CONFIDENCE","CONFIRM","CONFLICT","CONGRESS","CONNECT","CONNECTION","CONSEQUENCE","CONSERVATIVE","CONSIDER","CONSIDERABLE","CONSIDERATION","CONSIST","CONSTANT","CONSTRUCTION","CONSUMER","CONTACT","CONTAIN","CONTENT","CONTEXT","CONTINUE","CONTRACT","CONTRAST","CONTRIBUTE","CONTRIBUTION","CONTROL","CONVENTION","CONVERSATION","COPY","CORNER","CORPORATE","CORRECT","COS","COST","COULD","COUNCIL","COUNT","COUNTRY","COUNTY","COUPLE","COURSE","COURT","COVER","CREATE","CREATION","CREDIT","CRIME","CRIMINAL","CRISIS","CRITERION","CRITICAL","CRITICISM","CROSS","CROWD","CRY","CULTURAL","CULTURE","CUP","CURRENT","CURRENTLY","CURRICULUM","CUSTOMER","CUT","DAMAGE","DANGER","DANGEROUS","DARK","DATA","DATE","DAUGHTER","DAY","DEAD","DEAL","DEATH","DEBATE","DEBT","DECADE","DECIDE","DECISION","DECLARE","DEEP","DEFENCE","DEFENDANT","DEFINE","DEFINITION","DEGREE","DELIVER","DEMAND","DEMOCRATIC","DEMONSTRATE","DENY","DEPARTMENT","DEPEND","DEPUTY","DERIVE","DESCRIBE","DESCRIPTION","DESIGN","DESIRE","DESK","DESPITE","DESTROY","DETAIL","DETAILED","DETERMINE","DEVELOP","DEVELOPMENT","DEVICE","DIE","DIFFERENCE","DIFFERENT","DIFFICULT","DIFFICULTY","DINNER","DIRECT","DIRECTION","DIRECTLY","DIRECTOR","DISAPPEAR","DISCIPLINE","DISCOVER","DISCUSS","DISCUSSION","DISEASE","DISPLAY","DISTANCE","DISTINCTION","DISTRIBUTION","DISTRICT","DIVIDE","DIVISION","DO","DOCTOR","DOCUMENT","DOG","DOMESTIC","DOOR","DOUBLE","DOUBT","DOWN","DRAW","DRAWING","DREAM","DRESS","DRINK","DRIVE","DRIVER","DROP","DRUG","DRY","DUE","DURING","DUTY","EACH","EAR","EARLY","EARN","EARTH","EASILY","EAST","EASY","EAT","ECONOMIC","ECONOMY","EDGE","EDITOR","EDUCATION","EDUCATIONAL","EFFECT","EFFECTIVE","EFFECTIVELY","EFFORT","EGG","EITHER","ELDERLY","ELECTION","ELEMENT","ELSE","ELSEWHERE","EMERGE","EMPHASIS","EMPLOY","EMPLOYEE","EMPLOYER","EMPLOYMENT","EMPTY","ENABLE","ENCOURAGE","END","ENEMY","ENERGY","ENGINE","ENGINEERING","ENJOY","ENOUGH","ENSURE","ENTER","ENTERPRISE","ENTIRE","ENTIRELY","ENTITLE","ENTRY","ENVIRONMENT","ENVIRONMENTAL","EQUAL","EQUALLY","EQUIPMENT","ERROR","ESCAPE","ESPECIALLY","ESSENTIAL","ESTABLISH","ESTABLISHMENT","ESTATE","ESTIMATE","EVEN","EVENING","EVENT","EVENTUALLY","EVER","EVERY","EVERYBODY","EVERYONE","EVERYTHING","EVIDENCE","EXACTLY","EXAMINATION","EXAMINE","EXAMPLE","EXCELLENT","EXCEPT","EXCHANGE","EXECUTIVE","EXERCISE","EXHIBITION","EXIST","EXISTENCE","EXISTING","EXPECT","EXPECTATION","EXPENDITURE","EXPENSE","EXPENSIVE","EXPERIENCE","EXPERIMENT","EXPERT","EXPLAIN","EXPLANATION","EXPLORE","EXPRESS","EXPRESSION","EXTEND","EXTENT","EXTERNAL","EXTRA","EXTREMELY","EYE","FACE","FACILITY","FACT","FACTOR","FACTORY","FAIL","FAILURE","FAIR","FAIRLY","FAITH","FALL","FAMILIAR","FAMILY","FAMOUS","FAR","FARM","FARMER","FASHION","FAST","FATHER","FAVOUR","FEAR","FEATURE","FEE","FEEL","FEELING","FEMALE","FEW","FIELD","FIGHT","FIGURE","FILE","FILL","FILM","FINAL","FINALLY","FINANCE","FINANCIAL","FIND","FINDING","FINE","FINGER","FINISH","FIRE","FIRM","FIRST","FISH","FIT","FIX","FLAT","FLIGHT","FLOOR","FLOW","FLOWER","FLY","FOCUS","FOLLOW","FOLLOWING","FOOD","FOOT","FOOTBALL","FOR","FORCE","FOREIGN","FOREST","FORGET","FORM","FORMAL","FORMER","FORWARD","FOUNDATION","FREE","FREEDOM","FREQUENTLY","FRESH","FRIEND","FROM","FRONT","FRUIT","FUEL","FULL","FULLY","FUNCTION","FUND","FUNNY","FURTHER","FUTURE","GAIN","GAME","GARDEN","GAS","GATE","GATHER","GENERAL","GENERALLY","GENERATE","GENERATION","GENTLEMAN","GET","GIRL","GIVE","GLASS","GO","GOAL","GOD","GOLD","GOOD","GOVERNMENT","GRANT","GREAT","GREEN","GREY","GROUND","GROUP","GROW","GROWING","GROWTH","GUEST","GUIDE","GUN","HAIR","HALF","HALL","HAND","HANDLE","HANG","HAPPEN","HAPPY","HARD","HARDLY","HATE","HAVE","HE","HEAD","HEALTH","HEAR","HEART","HEAT","HEAVY","HELL","HELP","HENCE","HER","HERE","HERSELF","HIDE","HIGH","HIGHLY","HILL","HIM","HIMSELF","HIS","HISTORICAL","HISTORY","HIT","HOLD","HOLE","HOLIDAY","HOME","HOPE","HORSE","HOSPITAL","HOT","HOTEL","HOUR","HOUSE","HOUSEHOLD","HOUSING","HOW","HOWEVER","HUGE","HUMAN","HURT","HUSBAND","I","IDEA","IDENTIFY","IF","IGNORE","ILLUSTRATE","IMAGE","IMAGINE","IMMEDIATE","IMMEDIATELY","IMPACT","IMPLICATION","IMPLY","IMPORTANCE","IMPORTANT","IMPOSE","IMPOSSIBLE","IMPRESSION","IMPROVE","IMPROVEMENT","IN","INCIDENT","INCLUDE","INCLUDING","INCOME","INCREASE","INCREASED","INCREASINGLY","INDEED","INDEPENDENT","INDEX","INDICATE","INDIVIDUAL","INDUSTRIAL","INDUSTRY","INFLUENCE","INFORM","INFORMATION","INITIAL","INITIATIVE","INJURY","INSIDE","INSIST","INSTANCE","INSTEAD","INSTITUTE","INSTITUTION","INSTRUCTION","INSTRUMENT","INSURANCE","INTEND","INTENTION","INTEREST","INTERESTED","INTERESTING","INTERNAL","INTERNATIONAL","INTERPRETATION","INTERVIEW","INTO","INTRODUCE","INTRODUCTION","INVESTIGATE","INVESTIGATION","INVESTMENT","INVITE","INVOLVE","IRON","IS","ISLAND","ISSUE","IT","ITEM","ITS","ITSELF","JOB","JOIN","JOINT","JOURNEY","JUDGE","JUMP","JUST","JUSTICE","KEEP","KEY","KID","KILL","KIND","KING","KITCHEN","KNEE","KNOW","KNOWLEDGE","LABOUR","LACK","LADY","LAND","LANGUAGE","LARGE","LARGELY","LAST","LATE","LATER","LATTER","LAUGH","LAUNCH","LAW","LAWYER","LAY","LEAD","LEADER","LEADERSHIP","LEADING","LEAF","LEAGUE","LEAN","LEARN","LEAST","LEAVE","LEFT","LEG","LEGAL","LEGISLATION","LENGTH","LESS","LET","LETTER","LEVEL","LIABILITY","LIBERAL","LIBRARY","LIE","LIFE","LIFT","LIGHT","LIKE","LIKELY","LIMIT","LIMITED","LINE","LINK","LIP","LIST","LISTEN","LITERATURE","LITTLE","LIVE","LIVING","LOAN","LOCAL","LOCATION","LONG","LOOK","LORD","LOSE","LOSS","LOT","LOVE","LOVELY","LOW","LUNCH","MACHINE","MAGAZINE","MAIN","MAINLY","MAINTAIN","MAJOR","MAJORITY","MAKE","MALE","MAN","MANAGE","MANAGEMENT","MANAGER","MANNER","MANY","MAP","MARK","MARKET","MARRIAGE","MARRIED","MARRY","MASS","MASTER","MATCH","MATERIAL","MATTER","MAY","MAYBE","ME","MEAL","MEAN","MEANING","MEANS","MEANWHILE","MEASURE","MECHANISM","MEDIA","MEDICAL","MEET","MEETING","MEMBER","MEMBERSHIP","MEMORY","MENTAL","MENTION","MERELY","MESSAGE","METAL","METHOD","MIDDLE","MIGHT","MILE","MILITARY","MILK","MIND","MINE","MINISTER","MINISTRY","MINUTE","MISS","MISTAKE","MODEL","MODERN","MODULE","MOMENT","MONEY","MONTH","MORE","MORNING","MOST","MOTHER","MOTION","MOTOR","MOUNTAIN","MOUTH","MOVE","MOVEMENT","MUCH","MURDER","MUSEUM","MUSIC","MUST","MY","MYSELF","NAME","NARROW","NATION","NATIONAL","NATURAL","NATURE","NEAR","NEARLY","NECESSARILY","NECESSARY","NECK","NEED","NEGOTIATION","NEIGHBOUR","NEITHER","NETWORK","NEVER","NEVERTHELESS","NEW","NEWS","NEWSPAPER","NEXT","NICE","NIGHT","NO","NOBODY","NOD","NOISE","NONE","NOR","NORMAL","NORMALLY","NORTH","NORTHERN","NOSE","NOT","NOTE","NOTHING","NOTICE","NOTION","NOW","NUCLEAR","NUMBER","NURSE","OBJECT","OBJECTIVE","OBSERVATION","OBSERVE","OBTAIN","OBVIOUS","OBVIOUSLY","OCCASION","OCCUR","ODD","OF","OFF","OFFENCE","OFFER","OFFICE","OFFICER","OFFICIAL","OFTEN","OIL","OKAY","OLD","ON","ONCE","ONE","ONLY","ONTO","OPEN","OPERATE","OPERATION","OPINION","OPPORTUNITY","OPPOSITION","OPTION","OR","ORDER","ORDINARY","ORGANISATION","ORGANISE","ORGANIZATION","ORIGIN","ORIGINAL","OTHER","OTHERWISE","OUGHT","OUR","OURSELVES","OUT","OUTCOME","OUTPUT","OUTSIDE","OVER","OVERALL","OWN","OWNER","PACKAGE","PAGE","PAIN","PAINT","PAINTING","PAIR","PANEL","PAPER","PARENT","PARK","PARLIAMENT","PART","PARTICULAR","PARTICULARLY","PARTLY","PARTNER","PARTY","PASS","PASSAGE","PAST","PATH","PATIENT","PATTERN","PAY","PAYMENT","PEACE","PENSION","PEOPLE","PER","PERCENT","PERFECT","PERFORM","PERFORMANCE","PERHAPS","PERIOD","PERMANENT","PERSON","PERSONAL","PERSUADE","PHASE","PHONE","PHOTOGRAPH","PHYSICAL","PICK","PICTURE","PIECE","PLACE","PLAN","PLANNING","PLANT","PLASTIC","PLATE","PLAY","PLAYER","PLEASE","PLEASURE","PLENTY","PLUS","POCKET","POINT","POLICE","POLICY","POLITICAL","POLITICS","POOL","POOR","POPULAR","POPULATION","POSITION","POSITIVE","POSSIBILITY","POSSIBLE","POSSIBLY","POST","POTENTIAL","POUND","POWER","POWERFUL","PRACTICAL","PRACTICE","PREFER","PREPARE","PRESENCE","PRESENT","PRESIDENT","PRESS","PRESSURE","PRETTY","PREVENT","PREVIOUS","PREVIOUSLY","PRICE","PRIMARY","PRIME","PRINCIPLE","PRIORITY","PRISON","PRISONER","PRIVATE","PROBABLY","PROBLEM","PROCEDURE","PROCESS","PRODUCE","PRODUCT","PRODUCTION","PROFESSIONAL","PROFIT","PROGRAM","PROGRAMME","PROGRESS","PROJECT","PROMISE","PROMOTE","PROPER","PROPERLY","PROPERTY","PROPORTION","PROPOSE","PROPOSAL","PROSPECT","PROTECT","PROTECTION","PROVE","PROVIDE","PROVIDED","PROVISION","PUB","PUBLIC","PUBLICATION","PUBLISH","PULL","PUPIL","PURPOSE","PUSH","PUT","QUALITY","QUARTER","QUESTION","QUICK","QUICKLY","QUIET","QUITE","RACE","RADIO","RAILWAY","RAIN","RAISE","RANGE","RAPIDLY","RARE","RATE","RATHER","REACH","REACTION","READ","READER","READING","READY","REAL","REALISE","REALITY","REALIZE","REALLY","REASON","REASONABLE","RECALL","RECEIVE","RECENT","RECENTLY","RECOGNISE","RECOGNITION","RECOGNIZE","RECOMMEND","RECORD","RECOVER","RED","REDUCE","REDUCTION","REFER","REFERENCE","REFLECT","REFORM","REFUSE","REGARD","REGION","REGIONAL","REGULAR","REGULATION","REJECT","RELATE","RELATION","RELATIONSHIP","RELATIVE","RELATIVELY","RELEASE","RELEVANT","RELIEF","RELIGION","RELIGIOUS","RELY","REMAIN","REMEMBER","REMIND","REMOVE","REPEAT","REPLACE","REPLY","REPORT","REPRESENT","REPRESENTATION","REPRESENTATIVE","REQUEST","REQUIRE","REQUIREMENT","RESEARCH","RESOURCE","RESPECT","RESPOND","RESPONSE","RESPONSIBILITY","RESPONSIBLE","REST","RESTAURANT","RESULT","RETAIN","RETURN","REVEAL","REVENUE","REVIEW","REVOLUTION","RICH","RIDE","RIGHT","RING","RISE","RISK","RIVER","ROAD","ROCK","ROLE","ROLL","ROOF","ROOM","ROUND","ROUTE","ROW","ROYAL","RULE","RUN","RURAL","SAFE","SAFETY","SALE","SAME","SAMPLE","SATISFY","SAVE","SAY","SCALE","SCENE","SCHEME","SCHOOL","SCIENCE","SCIENTIFIC","SCIENTIST","SCORE","SCREEN","SEA","SEARCH","SEASON","SEAT","SECOND","SECONDARY","SECRETARY","SECTION","SECTOR","SECURE","SECURITY","SEE","SEEK","SEEM","SELECT","SELECTION","SELL","SEND","SENIOR","SENSE","SENTENCE","SEPARATE","SEQUENCE","SERIES","SERIOUS","SERIOUSLY","SERVANT","SERVE","SERVICE","SESSION","SET","SETTLE","SETTLEMENT","SEVERAL","SEVERE","SEX","SEXUAL","SHAKE","SHALL","SHAPE","SHARE","SHE","SHEET","SHIP","SHOE","SHOOT","SHOP","SHORT","SHOT","SHOULD","SHOULDER","SHOUT","SHOW","SHUT","SIDE","SIGHT","SIGN","SIGNAL","SIGNIFICANCE","SIGNIFICANT","SILENCE","SIMILAR","SIMPLE","SIMPLY","SINCE","SING","SINGLE","SIR","SISTER","SIT","SITE","SITUATION","SIZE","SKILL","SKIN","SKY","SLEEP","SLIGHTLY","SLIP","SLOW","SLOWLY","SMALL","SMILE","SO","SOCIAL","SOCIETY","SOFT","SOFTWARE","SOIL","SOLDIER","SOLICITOR","SOLUTION","SOME","SOMEBODY","SOMEONE","SOMETHING","SOMETIMES","SOMEWHAT","SOMEWHERE","SON","SONG","SOON","SORRY","SORT","SOUND","SOURCE","SOUTH","SOUTHERN","SPACE","SPEAK","SPEAKER","SPECIAL","SPECIES","SPECIFIC","SPEECH","SPEED","SPEND","SPIRIT","SPORT","SPOT","SPREAD","SPRING","STAFF","STAGE","STAND","STANDARD","STAR","START","STATE","STATEMENT","STATION","STATUS","STAY","STEAL","STEP","STICK","STILL","STOCK","STONE","STOP","STORE","STORY","STRAIGHT","STRANGE","STRATEGY","STREET","STRENGTH","STRIKE","STRONG","STRONGLY","STRUCTURE","STUDENT","STUDIO","STUDY","STUFF","STYLE","SUBJECT","SUBSTANTIAL","SUCCEED","SUCCESS","SUCCESSFUL","SUCH","SUDDENLY","SUFFER","SUFFICIENT","SUGGEST","SUGGESTION","SUITABLE","SUM","SUMMER","SUN","SUPPLY","SUPPORT","SUPPOSE","SURE","SURELY","SURFACE","SURPRISE","SURROUND","SURVEY","SURVIVE","SWITCH","SYSTEM","TABLE","TAKE","TALK","TALL","TAPE","TARGET","TASK","TAX","TEA","TEACH","TEACHER","TEACHING","TEAM","TEAR","TECHNICAL","TECHNIQUE","TECHNOLOGY","TELEPHONE","TELEVISION","TELL","TEMPERATURE","TEND","TERM","TERMS","TERRIBLE","TEST","TEXT","THAN","THANK","THANKS","THAT","THE","THEATRE","THEIR","THEM","THEME","THEMSELVES","THEN","THEORY","THERE","THEREFORE","THESE","THEY","THIN","THING","THINK","THIS","THOSE","THOUGH","THOUGHT","THREAT","THREATEN","THROUGH","THROUGHOUT","THROW","THUS","TICKET","TIME","TINY","TITLE","TO","TODAY","TOGETHER","TOMORROW","TONE","TONIGHT","TOO","TOOL","TOOTH","TOP","TOTAL","TOTALLY","TOUCH","TOUR","TOWARDS","TOWN","TRACK","TRADE","TRADITION","TRADITIONAL","TRAFFIC","TRAIN","TRAINING","TRANSFER","TRANSPORT","TRAVEL","TREAT","TREATMENT","TREATY","TREE","TREND","TRIAL","TRIP","TROOP","TROUBLE","TRUE","TRUST","TRUTH","TRY","TURN","TWICE","TYPE","TYPICAL","UNABLE","UNDER","UNDERSTAND","UNDERSTANDING","UNDERTAKE","UNEMPLOYMENT","UNFORTUNATELY","UNION","UNIT","UNITED","UNIVERSITY","UNLESS","UNLIKELY","UNTIL","UP","UPON","UPPER","URBAN","US","USE","USED","USEFUL","USER","USUAL","USUALLY","VALUE","VARIATION","VARIETY","VARIOUS","VARY","VAST","VEHICLE","VERSION","VERY","VIA","VICTIM","VICTORY","VIDEO","VIEW","VILLAGE","VIOLENCE","VISION","VISIT","VISITOR","VITAL","VOICE","VOLUME","VOTE","WAGE","WAIT","WALK","WALL","WANT","WAR","WARM","WARN","WASH","WATCH","WATER","WAVE","WAY","WE","WEAK","WEAPON","WEAR","WEATHER","WEEK","WEEKEND","WEIGHT","WELCOME","WELFARE","WELL","WEST","WESTERN","WHAT","WHATEVER","WHEN","WHERE","WHEREAS","WHETHER","WHICH","WHILE","WHILST","WHITE","WHO","WHOLE","WHOM","WHOSE","WHY","WIDE","WIDELY","WIFE","WILD","WILL","WIN","WIND","WINDOW","WINE","WING","WINNER","WINTER","WISH","WITH","WITHDRAW","WITHIN","WITHOUT","WOMAN","WONDER","WONDERFUL","WOOD","WORD","WORK","WORKER","WORKING","WORKS","WORLD","WORRY","WORTH","WOULD","WRITE","WRITER","WRITING","WRONG","YARD","YEAH","YEAR","YES","YESTERDAY","YET","YOU","YOUNG","YOUR","YOURSELF","YOUTH" \ No newline at end of file diff --git a/extra/project-euler/067/067.factor b/extra/project-euler/067/067.factor index 5df516f2f4..f206f59472 100644 --- a/extra/project-euler/067/067.factor +++ b/extra/project-euler/067/067.factor @@ -58,7 +58,4 @@ PRIVATE> ! [ euler067a ] 100 ave-time ! 14 ms run / 0 ms GC ave time - 100 trials -! source-067 [ max-path ] curry 100 ave-time -! 3 ms run / 0 ms GC ave time - 100 trials - MAIN: euler067a diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 99bb3169c4..0910cbcb7b 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -13,6 +13,7 @@ IN: project-euler.common ! collect-consecutive - #8, #11 ! log10 - #25, #134 ! max-path - #18, #67 +! nth-triangle - #12, #42 ! number>digits - #16, #20, #30, #34 ! pandigital? - #32, #38 ! propagate-all - #18, #67 @@ -77,6 +78,9 @@ PRIVATE> : number>digits ( n -- seq ) number>string string>digits ; +: nth-triangle ( n -- n ) + dup 1+ * 2 / ; + : pandigital? ( n -- ? ) number>string natural-sort "123456789" = ; diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 3433fe7154..226c47b0a3 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,8 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.048 project-euler.067 project-euler.075 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.048 project-euler.067 + project-euler.075 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Sun, 3 Feb 2008 22:11:31 -0500 Subject: [PATCH 006/194] Solution to Project Euler problem 52 --- extra/project-euler/052/052.factor | 50 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +-- 2 files changed, 53 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/052/052.factor diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor new file mode 100644 index 0000000000..3f6487fb3e --- /dev/null +++ b/extra/project-euler/052/052.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib kernel math project-euler.common sequences sorting ; +IN: project-euler.052 + +! http://projecteuler.net/index.php?section=problems&id=52 + +! DESCRIPTION +! ----------- + +! It can be seen that the number, 125874, and its double, 251748, contain +! exactly the same digits, but in a different order. + +! Find the smallest positive integer, x, such that 2x, 3x, 4x, 5x, and 6x, +! contain the same digits. + + +! SOLUTION +! -------- + +! Analysis shows the number must be odd, divisible by 3, and larger than 123456 + +digits natural-sort ] map all-equal? ; + +: candidate? ( n -- ? ) + { [ dup odd? ] [ dup 3 mod zero? ] } && nip ; + +: next-all-same ( x n -- n ) + dup candidate? [ + 2dup swap map-nx all-same-digits? + [ nip ] [ 1+ next-all-same ] if + ] [ + 1+ next-all-same + ] if ; + +PRIVATE> + +: euler052 ( -- answer ) + 6 123456 next-all-same ; + +! [ euler052 ] 100 ave-time +! 403 ms run / 7 ms GC ave time - 100 trials + +MAIN: euler052 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 226c47b0a3..2f8a3184bb 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.048 project-euler.067 - project-euler.075 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.041 project-euler.042 project-euler.048 project-euler.052 + project-euler.067 project-euler.075 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Mon, 4 Feb 2008 01:40:47 -0500 Subject: [PATCH 007/194] Solution to Project Euler problem 97 --- extra/project-euler/097/097.factor | 31 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +-- 2 files changed, 33 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/097/097.factor diff --git a/extra/project-euler/097/097.factor b/extra/project-euler/097/097.factor new file mode 100644 index 0000000000..50e7af563d --- /dev/null +++ b/extra/project-euler/097/097.factor @@ -0,0 +1,31 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: math math.functions ; +IN: project-euler.097 + +! http://projecteuler.net/index.php?section=problems&id=97 + +! DESCRIPTION +! ----------- + +! The first known prime found to exceed one million digits was discovered in +! 1999, and is a Mersenne prime of the form 2^6972593 − 1; it contains exactly +! 2,098,960 digits. Subsequently other Mersenne primes, of the form 2p − 1, +! have been found which contain more digits. + +! However, in 2004 there was found a massive non-Mersenne prime which contains +! 2,357,207 digits: 28433 * 2^7830457 + 1. + +! Find the last ten digits of this prime number. + + +! SOLUTION +! -------- + +: euler097 ( -- answer ) + 2 7830457 10 10 ^ ^mod 28433 * 10 10 ^ mod 1+ ; + +! [ euler097 ] 100 ave-time +! 0 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler097 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 2f8a3184bb..0be0b456ad 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -13,8 +13,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.048 project-euler.052 - project-euler.067 project-euler.075 project-euler.134 project-euler.169 - project-euler.173 project-euler.175 ; + project-euler.067 project-euler.075 project-euler.097 project-euler.134 + project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Mon, 4 Feb 2008 01:49:31 -0500 Subject: [PATCH 008/194] Add missing dependency for Project Euler 42 --- extra/project-euler/042/042.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/project-euler/042/042.factor b/extra/project-euler/042/042.factor index 3d5f271374..95b3062e95 100644 --- a/extra/project-euler/042/042.factor +++ b/extra/project-euler/042/042.factor @@ -1,6 +1,6 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. -USING: ascii combinators.lib io.files kernel math namespaces +USING: ascii combinators.lib io.files kernel math math.functions namespaces project-euler.common sequences splitting ; IN: project-euler.042 From e2c20d23a4856580e1d8eabf2b57a8d6b5d78d0d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 11:06:11 -0600 Subject: [PATCH 009/194] add missing use fix dll path on windows --- extra/ogg/theora/theora.factor | 2 +- extra/ogg/vorbis/vorbis.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ogg/theora/theora.factor b/extra/ogg/theora/theora.factor index 0d9748a6f3..48b61b41a3 100644 --- a/extra/ogg/theora/theora.factor +++ b/extra/ogg/theora/theora.factor @@ -6,7 +6,7 @@ IN: ogg.theora << "theora" { - { [ win32? ] [ "libtheora.dll" ] } + { [ win32? ] [ "theora.dll" ] } { [ macosx? ] [ "libtheora.0.dylib" ] } { [ unix? ] [ "libtheora.so" ] } } cond "cdecl" add-library diff --git a/extra/ogg/vorbis/vorbis.factor b/extra/ogg/vorbis/vorbis.factor index 26e917ebf4..170d0ea6ef 100644 --- a/extra/ogg/vorbis/vorbis.factor +++ b/extra/ogg/vorbis/vorbis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. ! -USING: kernel system combinators alien alien.syntax ; +USING: kernel system combinators alien alien.syntax ogg ; IN: ogg.vorbis << From bc3bf6b2b4ede72aa4332dd3f7b98cd85f836756 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 11:45:53 -0600 Subject: [PATCH 010/194] make factor compile on win64 --- Makefile | 6 +++++- vm/Config.windows.nt.x86.32 | 1 + vm/Config.windows.nt.x86.64 | 6 ++++-- vm/os-windows-nt.32.h | 2 ++ vm/os-windows-nt.64.h | 2 ++ vm/os-windows-nt.c | 10 +++++----- vm/platform.h | 9 +++++++-- 7 files changed, 26 insertions(+), 10 deletions(-) create mode 100644 vm/os-windows-nt.32.h create mode 100644 vm/os-windows-nt.64.h diff --git a/Makefile b/Makefile index aad7fe90eb..bd1bf16c74 100755 --- a/Makefile +++ b/Makefile @@ -65,6 +65,7 @@ default: @echo "solaris-x86-64" @echo "windows-ce-arm" @echo "windows-nt-x86-32" + @echo "windows-nt-x86-64" @echo "" @echo "Additional modifiers:" @echo "" @@ -125,6 +126,9 @@ solaris-x86-64: windows-nt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 +windows-nt-x86-64: + $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 + windows-ce-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm @@ -151,7 +155,7 @@ clean: rm -f factor*.dll libfactor*.* vm/resources.o: - windres vm/factor.rs vm/resources.o + $(WINDRES) vm/factor.rs vm/resources.o .c.o: $(CC) -c $(CFLAGS) -o $@ $< diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.nt.x86.32 index 9a020a7bc1..603a7200ae 100644 --- a/vm/Config.windows.nt.x86.32 +++ b/vm/Config.windows.nt.x86.32 @@ -1,3 +1,4 @@ WINDRES=windres include vm/Config.windows.nt include vm/Config.x86.32 +#error "lolllll" diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 index 1c30e64096..6d3865c2f4 100644 --- a/vm/Config.windows.nt.x86.64 +++ b/vm/Config.windows.nt.x86.64 @@ -1,4 +1,6 @@ -CC=/k/target/bin/x86_64-pc-mingw32-gcc +#WIN64_PATH=/k/MinGW/win64/bin +WIN64_PATH=/cygdrive/k/MinGW/win64/bin/x86_64-pc-mingw32 +CC=$(WIN64_PATH)-gcc.exe +WINDRES=$(WIN64_PATH)-windres.exe include vm/Config.windows.nt include vm/Config.x86.64 -WINDRES = /k/target/bin/windres diff --git a/vm/os-windows-nt.32.h b/vm/os-windows-nt.32.h new file mode 100644 index 0000000000..9b10671ba0 --- /dev/null +++ b/vm/os-windows-nt.32.h @@ -0,0 +1,2 @@ +#define ESP Esp +#define EIP Eip diff --git a/vm/os-windows-nt.64.h b/vm/os-windows-nt.64.h new file mode 100644 index 0000000000..1f61c2335f --- /dev/null +++ b/vm/os-windows-nt.64.h @@ -0,0 +1,2 @@ +#define ESP Rsp +#define EIP Rip diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..3995b6a35a 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -57,26 +57,26 @@ long exception_handler(PEXCEPTION_POINTERS pe) PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord; CONTEXT *c = (CONTEXT*)pe->ContextRecord; - if(in_code_heap_p(c->Eip)) - signal_callstack_top = (void *)c->Esp; + if(in_code_heap_p(c->EIP)) + signal_callstack_top = (void *)c->ESP; else signal_callstack_top = NULL; if(e->ExceptionCode == EXCEPTION_ACCESS_VIOLATION) { signal_fault_addr = e->ExceptionInformation[1]; - c->Eip = (CELL)memory_signal_handler_impl; + c->EIP = (CELL)memory_signal_handler_impl; } else if(e->ExceptionCode == EXCEPTION_FLT_DIVIDE_BY_ZERO || e->ExceptionCode == EXCEPTION_INT_DIVIDE_BY_ZERO) { signal_number = ERROR_DIVIDE_BY_ZERO; - c->Eip = (CELL)divide_by_zero_signal_handler_impl; + c->EIP = (CELL)divide_by_zero_signal_handler_impl; } else { signal_number = 11; - c->Eip = (CELL)misc_signal_handler_impl; + c->EIP = (CELL)misc_signal_handler_impl; } return EXCEPTION_CONTINUE_EXECUTION; diff --git a/vm/platform.h b/vm/platform.h index b0641176bc..66f22bbf96 100644 --- a/vm/platform.h +++ b/vm/platform.h @@ -1,11 +1,11 @@ #if defined(__arm__) #define FACTOR_ARM +#elif defined(__amd64__) || defined(__x86_64__) + #define FACTOR_AMD64 #elif defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32) #define FACTOR_X86 #elif defined(__POWERPC__) || defined(__ppc__) || defined(_ARCH_PPC) #define FACTOR_PPC -#elif defined(__amd64__) || defined(__x86_64__) - #define FACTOR_AMD64 #else #error "Unsupported architecture" #endif @@ -18,6 +18,11 @@ #endif #include "os-windows.h" + #if defined(FACTOR_AMD64) + #include "os-windows-nt.64.h" + #elif defined(FACTOR_X86) + #include "os-windows-nt.32.h" + #endif #else #include "os-unix.h" From 87d44252c59f0a7d967157b634f10dc83acce442 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 12:30:23 -0600 Subject: [PATCH 011/194] add more dlls to script --- misc/factor.sh | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 032b0b3184..02f4c4a542 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -233,6 +233,16 @@ maybe_download_dlls() { check_ret wget wget http://factorcode.org/dlls/zlib1.dll check_ret wget + wget http://factorcode.org/dlls/OpenAL32.dll + check_ret wget + wget http://factorcode.org/dlls/alut.dll + check_ret wget + wget http://factorcode.org/dlls/ogg.dll + check_ret wget + wget http://factorcode.org/dlls/theora.dll + check_ret wget + wget http://factorcode.org/dlls/vorbis.dll + check_ret wget chmod 777 *.dll check_ret chmod fi From c9a7f35e9ccb21e4e08ece6182c110defdb6d490 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:32:27 -0600 Subject: [PATCH 012/194] remove spurious db.sql --- extra/db/db.factor | 1 - extra/db/sqlite/sqlite-tests.factor | 2 +- extra/db/sqlite/sqlite.factor | 2 +- 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/db/db.factor b/extra/db/db.factor index b765924cd6..1c287cd871 100644 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -10,7 +10,6 @@ C: db ( handle -- obj ) ! HOOK: db-create db ( str -- ) ! HOOK: db-drop db ( str -- ) GENERIC: db-open ( db -- ) -GENERIC: db-close ( db -- ) TUPLE: statement sql params handle bound? ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index f64b8d1104..aa7168530b 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -1,5 +1,5 @@ USING: io io.files io.launcher kernel namespaces -prettyprint tools.test db.sqlite db db.sql sequences +prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 49462dcc50..73b93d404b 100644 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2008 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien arrays assocs classes compiler db db.sql +USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint sequences strings tuples alien.c-types continuations db.sqlite.lib db.sqlite.ffi ; From 4066e1ca6b68512726bf66a9a4526a222ce770fe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:34:01 -0600 Subject: [PATCH 013/194] start mysql --- extra/db/mysql/ffi/ffi.factor | 25 ++++++++++ extra/db/mysql/lib/lib.factor | 94 +++++++++++++++++++++++++++++++++++ extra/db/mysql/mysql.factor | 15 ++++++ 3 files changed, 134 insertions(+) create mode 100644 extra/db/mysql/ffi/ffi.factor create mode 100644 extra/db/mysql/lib/lib.factor create mode 100644 extra/db/mysql/mysql.factor diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor new file mode 100644 index 0000000000..845381a23c --- /dev/null +++ b/extra/db/mysql/ffi/ffi.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: alien alien.syntax combinators kernel system ; +IN: db.mysql.ffi + +<< "mysql" { + { [ win32? ] [ "libmySQL.dll" "stdcall" ] } + { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } + { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } +} cond add-library >> + +LIBRARY: mysql + +FUNCTION: void* mysql_init ( void* mysql ) ; +FUNCTION: char* mysql_error ( void* mysql ) ; +FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; +FUNCTION: void mysql_close ( void* sock ) ; +FUNCTION: int mysql_query ( void* mysql, char* q ) ; +FUNCTION: void* mysql_use_result ( void* mysql ) ; +FUNCTION: void mysql_free_result ( void* result ) ; +FUNCTION: char** mysql_fetch_row ( void* result ) ; +FUNCTION: int mysql_num_fields ( void* result ) ; +FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor new file mode 100644 index 0000000000..7d5c2d55dc --- /dev/null +++ b/extra/db/mysql/lib/lib.factor @@ -0,0 +1,94 @@ +! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +! Adapted from mysql.h and mysql.c +! Tested with MySQL version - 5.0.24a +USING: kernel alien io prettyprint sequences +namespaces arrays math db.mysql.ffi system ; +IN: db.mysql.lib + +SYMBOL: my-conn + +TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; + +: new-mysql ( -- conn ) + f mysql_init ; + +: mysql-error-string ( mysql-connection -- str ) + mysql-db-handle mysql_error ; + +: mysql-error ( mysql -- ) + mysql-error-string throw ; + +: mysql-connect ( mysql-connection -- ) + init-mysql swap + [ set-mysql-connection-mysqlconn ] 2keep + [ mysql-connection-host ] keep + [ mysql-connection-user ] keep + [ mysql-connection-password ] keep + [ mysql-connection-db ] keep + [ mysql-connection-port f 0 mysql_real_connect ] keep + [ set-mysql-connection-handle ] keep + dup mysql-connection-handle + [ connect-error-msg throw ] unless ; + +! ========================================================= +! Low level mysql utility definitions +! ========================================================= + +: (mysql-query) ( mysql-connection query -- ret ) + >r mysql-connection-mysqlconn r> mysql_query ; + +: (mysql-result) ( mysql-connection -- ret ) + [ mysql-connection-mysqlconn mysql_use_result ] keep + [ set-mysql-connection-resulthandle ] keep ; + +: (mysql-affected-rows) ( mysql-connection -- n ) + mysql-connection-mysqlconn mysql_affected_rows ; + +: (mysql-free-result) ( mysql-connection -- ) + mysql-connection-resulthandle drop ; + +: (mysql-row) ( mysql-connection -- row ) + mysql-connection-resulthandle mysql_fetch_row ; + +: (mysql-num-cols) ( mysql-connection -- n ) + mysql-connection-resulthandle mysql_num_fields ; + +: mysql-char*-nth ( index object -- str ) + #! Utility based on 'char*-nth' to perform an additional sanity check on the value + #! extracted from the array of strings. + void*-nth [ alien>char-string ] [ "" ] if* ; + +: mysql-row>seq ( object n -- seq ) + [ swap mysql-char*-nth ] map-with ; + +: (mysql-result>seq) ( seq -- seq ) + my-conn get (mysql-row) dup [ + my-conn get (mysql-num-cols) mysql-row>seq + over push + (mysql-result>seq) + ] [ drop ] if + ! Perform needed cleanup on fetched results + my-conn get (mysql-free-result) ; + +! ========================================================= +! Public Word Definitions +! ========================================================= + + +: mysql-query ( query -- ret ) + >r my-conn get r> (mysql-query) drop + my-conn get (mysql-result) ; + +: mysql-command ( query -- n ) + mysql-query drop + my-conn get (mysql-affected-rows) ; + +: with-mysql ( host user password db port quot -- ) + [ + >r my-conn set + my-conn get mysql-connect drop r> + [ my-conn get mysql-close ] cleanup + ] with-scope ; inline diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor new file mode 100644 index 0000000000..8043bc2782 --- /dev/null +++ b/extra/db/mysql/mysql.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2008 Doug Coleman. +! See http://factorcode.org/license.txt for license. +USING: alien continuations io kernel prettyprint sequences +db ; +IN: db.mysql + +TUPLE: mysql-db handle host user password db port ; + +M: mysql-db db-open ( mysql-db -- ) + ; + +M: mysql-db dispose ( mysql-db -- ) + mysql-db-handle mysql_close ; + + From 13338b04f6f44499b700714bd07adc86ef666931 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:34:32 -0600 Subject: [PATCH 014/194] remove old mysql --- unmaintained/mysql/libmysql.factor | 35 ------ unmaintained/mysql/load.factor | 11 -- unmaintained/mysql/mysql.factor | 124 ------------------- unmaintained/mysql/test/create_database.sql | 17 --- unmaintained/mysql/test/mysql-example.factor | 57 --------- 5 files changed, 244 deletions(-) delete mode 100644 unmaintained/mysql/libmysql.factor delete mode 100644 unmaintained/mysql/load.factor delete mode 100644 unmaintained/mysql/mysql.factor delete mode 100644 unmaintained/mysql/test/create_database.sql delete mode 100644 unmaintained/mysql/test/mysql-example.factor diff --git a/unmaintained/mysql/libmysql.factor b/unmaintained/mysql/libmysql.factor deleted file mode 100644 index 064c7bffbc..0000000000 --- a/unmaintained/mysql/libmysql.factor +++ /dev/null @@ -1,35 +0,0 @@ -! See http://factorcode.org/license.txt -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/libmysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: alien kernel ; - -"mysql" { - { [ win32? ] [ "libmySQL.dll" "stdcall" ] } - { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] } - { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] } -} cond add-library - -LIBRARY: mysql - -! =============================================== -! mysql.c -! =============================================== - -FUNCTION: void* mysql_init ( void* mysql ) ; -FUNCTION: char* mysql_error ( void* mysql ) ; -FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ; -FUNCTION: void mysql_close ( void* sock ) ; -FUNCTION: int mysql_query ( void* mysql, char* q ) ; -FUNCTION: void* mysql_use_result ( void* mysql ) ; -FUNCTION: void mysql_free_result ( void* result ) ; -FUNCTION: char** mysql_fetch_row ( void* result ) ; -FUNCTION: int mysql_num_fields ( void* result ) ; -FUNCTION: ulong mysql_affected_rows ( void* mysql ) ; - diff --git a/unmaintained/mysql/load.factor b/unmaintained/mysql/load.factor deleted file mode 100644 index b3872d6259..0000000000 --- a/unmaintained/mysql/load.factor +++ /dev/null @@ -1,11 +0,0 @@ -! License: See http://factor.sf.net/license.txt for BSD license. -! Berlin Brown -! Date: 1/17/2007 -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a -PROVIDE: libs/mysql -{ +files+ { - "libmysql.factor" - "mysql.factor" -} } ; \ No newline at end of file diff --git a/unmaintained/mysql/mysql.factor b/unmaintained/mysql/mysql.factor deleted file mode 100644 index 22a6bc9248..0000000000 --- a/unmaintained/mysql/mysql.factor +++ /dev/null @@ -1,124 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Copyright (C) 2007 Berlin Brown -! Date: 1/17/2007 -! -! libs/mysql/mysql.factor -! -! Adapted from mysql.h and mysql.c -! Tested with MySQL version - 5.0.24a - -IN: mysql -USING: kernel alien errors io prettyprint - sequences namespaces arrays math tools generic ; - -SYMBOL: my-conn - -TUPLE: mysql-connection mysqlconn host user password db port handle resulthandle ; - -: init-mysql ( -- conn ) - f mysql_init ; - -C: mysql-connection ( host user password db port -- mysql-connection ) - [ set-mysql-connection-port ] keep - [ set-mysql-connection-db ] keep - [ set-mysql-connection-password ] keep - [ set-mysql-connection-user ] keep - [ set-mysql-connection-host ] keep ; - -: (mysql-error) ( mysql-connection -- str ) - mysql-connection-mysqlconn mysql_error ; - -: connect-error-msg ( mysql-connection -- s ) - mysql-connection-mysqlconn mysql_error - [ - "Couldn't connect to mysql database.\n" % - "Message: " % % - ] "" make ; - -: mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; - -! ========================================================= -! Low level mysql utility definitions -! ========================================================= - -: (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; - -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; - -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; - -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; - -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; - -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= - -: mysql-close ( mysql-connection -- ) - mysql-connection-mysqlconn mysql_close ; - -: mysql-print-table ( seq -- ) - [ [ write bl ] each "\n" write ] each ; - -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; - -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; - -: mysql-error ( -- s ) - #! Get the last mysql error - my-conn get (mysql-error) ; - -: mysql-result>seq ( -- seq ) - V{ } clone (mysql-result>seq) ; - -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline - -: with-mysql-catch ( host user password db port quot -- ) - [ with-mysql ] catch [ "Caught: " write print ] when* ; - \ No newline at end of file diff --git a/unmaintained/mysql/test/create_database.sql b/unmaintained/mysql/test/create_database.sql deleted file mode 100644 index 00fd323046..0000000000 --- a/unmaintained/mysql/test/create_database.sql +++ /dev/null @@ -1,17 +0,0 @@ --- --- Create three databases (development / test / production) --- with prefix 'factordb_' -create database factordb_development; -create database factordb_test; -create database factordb_production; - -grant all on factordb_development.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'localhost' identified by 'mysqlfactor'; - -grant all on factordb_development.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_test.* to 'factoruser'@'*' identified by 'mysqlfactor'; -grant all on factordb_production.* to 'factoruser'@'*' identified by 'mysqlfactor'; - --- End of the Script - diff --git a/unmaintained/mysql/test/mysql-example.factor b/unmaintained/mysql/test/mysql-example.factor deleted file mode 100644 index 2476153c8a..0000000000 --- a/unmaintained/mysql/test/mysql-example.factor +++ /dev/null @@ -1,57 +0,0 @@ -! See http://factorcode.org/license.txt for license. -! Simple test for mysql library -! libs/mysql/test/mysql-example.factor - -IN: mysql-example -REQUIRES: libs/mysql ; -USING: sequences mysql modules prettyprint kernel io math tools namespaces test ; - -"Testing..." print nl - -: get-drop-table ( -- s ) - "DROP TABLE if exists DISCUSSION_FORUM" ; - -: get-insert-table ( -- s ) - { - "INSERT INTO DISCUSSION_FORUM(category, full_name, email, title, main_url, keywords, message) " - "VALUES('none', 'John Doe', 'johndoe@test.com', 'The Message', NULL, NULL, 'Testing')" - } "" join ; - -: get-update-table ( -- s ) - "UPDATE DISCUSSION_FORUM set category = 'my-new-category'" ; - -: get-delete-table ( -- s ) - "DELETE FROM DISCUSSION_FORUM where id = 2" ; - -: get-create-table ( -- s ) - { - "create table DISCUSSION_FORUM(" - "id int(11) NOT NULL auto_increment," - "category varchar(128)," - "full_name varchar(128) NOT NULL," - "email varchar(128) NOT NULL," - "title varchar(255) NOT NULL," - "main_url varchar(255)," - "keywords varchar(255)," - "message text NOT NULL," - "created_on DATETIME NOT NULL DEFAULT '0000-00-0000:00:00'," - "PRIMARY KEY (id));" - } "" join ; - -[ "localhost" "factoruser" "mysqlfactor" "factordb_development" 0 [ - get-drop-table mysql-command drop - get-create-table mysql-command drop - get-update-table mysql-command drop - get-delete-table mysql-command drop - - ! Insert multiple records - 20 [ - get-insert-table mysql-command 2drop - ] each - - "select * from discussion_forum order by created_on" mysql-query drop - mysql-result>seq mysql-print-table - -] with-mysql ] time - -"Done" print \ No newline at end of file From eda2c710d450352314ebf9df616ebaa0e7d390dd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:38:59 -0600 Subject: [PATCH 015/194] add dll to script --- misc/factor.sh | 2 ++ 1 file changed, 2 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 02f4c4a542..fa8cdcd5b1 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -243,6 +243,8 @@ maybe_download_dlls() { check_ret wget wget http://factorcode.org/dlls/vorbis.dll check_ret wget + wget http://factorcode.org/dlls/sqlite3.dll + check_ret wget chmod 777 *.dll check_ret chmod fi From 354d85342e11f5465432e43662809fc5763d2af0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 13:57:22 -0600 Subject: [PATCH 016/194] remove dependency on sqlite3 binary --- extra/db/sqlite/sqlite-tests.factor | 45 +++++++++-------------------- 1 file changed, 13 insertions(+), 32 deletions(-) diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor index aa7168530b..c6576dcd62 100644 --- a/extra/db/sqlite/sqlite-tests.factor +++ b/extra/db/sqlite/sqlite-tests.factor @@ -3,40 +3,26 @@ prettyprint tools.test db.sqlite db sequences continuations ; IN: temporary -! "sqlite3 -init test.txt test.db" - -IN: scratchpad : test.db "extra/db/sqlite/test.db" resource-path ; -IN: temporary -: (create-db) ( -- str ) - [ - "sqlite3 -init " % - test.db % - " " % - test.db % - ] "" make ; +[ ] [ [ test.db delete-file ] catch drop ] unit-test -: create-db ( -- ) (create-db) run-process drop ; +[ ] [ + test.db [ + "create table person (name varchar(30), country varchar(30))" sql-command + "insert into person values('John', 'America')" sql-command + "insert into person values('Jane', 'New Zealand')" sql-command + ] with-sqlite +] unit-test -[ ] [ test.db delete-file ] unit-test -[ ] [ create-db ] unit-test - -[ - { - { "John" "America" } - { "Jane" "New Zealand" } - } -] [ +[ { { "John" "America" } { "Jane" "New Zealand" } } ] [ test.db [ "select * from person" sql-query ] with-sqlite ] unit-test -[ - { { "John" "America" } } -] [ +[ { { "John" "America" } } ] [ test.db [ "select * from person where name = :name and country = :country" [ @@ -52,15 +38,10 @@ IN: temporary ] with-sqlite ] unit-test -[ - { - { "1" "John" "America" } - { "2" "Jane" "New Zealand" } - } -] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test +[ { { "1" "John" "America" } { "2" "Jane" "New Zealand" } } ] +[ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test -[ -] [ +[ ] [ test.db [ "insert into person(name, country) values('Jimmy', 'Canada')" sql-command From aff818a07d82a013eb5a9963eeb4397bb0deb3f7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 16:40:14 -0600 Subject: [PATCH 017/194] add using --- extra/x/widgets/wm/frame/frame.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor index 4e3b4e7c93..b75671fa3c 100755 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -4,6 +4,7 @@ USING: kernel io combinators namespaces quotations arrays sequences x11.xlib x11.constants mortar mortar.sugar slot-accessors geom.rect + math.bitfields x x.gc x.widgets x.widgets.button x.widgets.wm.child From c0c08985c5c46c877ebefcceb034751e6143bd94 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:10:49 -0600 Subject: [PATCH 018/194] make hardware-info load on windows --- extra/hardware-info/hardware-info.factor | 7 +++--- .../windows/backend/backend.factor | 6 ----- extra/hardware-info/windows/ce/ce.factor | 4 ++-- extra/hardware-info/windows/nt/nt.factor | 24 +++++++++---------- extra/hardware-info/windows/windows.factor | 7 +++--- 5 files changed, 21 insertions(+), 27 deletions(-) delete mode 100644 extra/hardware-info/windows/backend/backend.factor diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 0515646a5f..69b8678749 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -1,12 +1,13 @@ -USING: alien.syntax kernel math prettyprint system -combinators vocabs.loader hardware-info.backend ; +USING: alien.syntax kernel math prettyprint +combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : kb. ( x -- ) 10 2^ /f . ; : megs. ( x -- ) 20 2^ /f . ; : gigs. ( x -- ) 30 2^ /f . ; -<< { +<< +{ { [ windows? ] [ "hardware-info.windows" ] } { [ linux? ] [ "hardware-info.linux" ] } { [ macosx? ] [ "hardware-info.macosx" ] } diff --git a/extra/hardware-info/windows/backend/backend.factor b/extra/hardware-info/windows/backend/backend.factor deleted file mode 100644 index 516603c441..0000000000 --- a/extra/hardware-info/windows/backend/backend.factor +++ /dev/null @@ -1,6 +0,0 @@ -IN: hardware-info.windows.backend - -TUPLE: wince ; -TUPLE: winnt ; -UNION: windows wince winnt ; - diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 1592bad14c..8923d86b03 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -2,8 +2,8 @@ USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 hardware-info.backend ; IN: hardware-info.windows.ce -TUPLE: wince ; -T{ wince } os set-global +TUPLE: wince-os ; +T{ wince-os } os set-global : memory-status ( -- MEMORYSTATUS ) "MEMORYSTATUS" diff --git a/extra/hardware-info/windows/nt/nt.factor b/extra/hardware-info/windows/nt/nt.factor index 827b32c2f2..8bdb75fe6a 100755 --- a/extra/hardware-info/windows/nt/nt.factor +++ b/extra/hardware-info/windows/nt/nt.factor @@ -1,16 +1,15 @@ -USING: alien alien.c-types hardware-info.windows.backend +USING: alien alien.c-types kernel libc math namespaces hardware-info.backend windows windows.advapi32 windows.kernel32 ; IN: hardware-info.windows.nt -TUPLE: winnt ; - -T{ winnt } os set-global +TUPLE: winnt-os ; +T{ winnt-os } os set-global : system-info ( -- SYSTEM_INFO ) "SYSTEM_INFO" [ GetSystemInfo ] keep ; -M: winnt cpus ( -- n ) +M: winnt-os cpus ( -- n ) system-info SYSTEM_INFO-dwNumberOfProcessors ; : memory-status ( -- MEMORYSTATUSEX ) @@ -18,25 +17,25 @@ M: winnt cpus ( -- n ) "MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength [ GlobalMemoryStatusEx ] keep swap zero? [ win32-error ] when ; -M: winnt memory-load ( -- n ) +M: winnt-os memory-load ( -- n ) memory-status MEMORYSTATUSEX-dwMemoryLoad ; -M: winnt physical-mem ( -- n ) +M: winnt-os physical-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPhys ; -M: winnt available-mem ( -- n ) +M: winnt-os available-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPhys ; -M: winnt total-page-file ( -- n ) +M: winnt-os total-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullTotalPageFile ; -M: winnt available-page-file ( -- n ) +M: winnt-os available-page-file ( -- n ) memory-status MEMORYSTATUSEX-ullAvailPageFile ; -M: winnt total-virtual-mem ( -- n ) +M: winnt-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullTotalVirtual ; -M: winnt available-virtual-mem ( -- n ) +M: winnt-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUSEX-ullAvailVirtual ; : computer-name ( -- string ) @@ -54,4 +53,3 @@ M: winnt available-virtual-mem ( -- n ) ] [ [ alien>u16-string ] keep free ] if ; - diff --git a/extra/hardware-info/windows/windows.factor b/extra/hardware-info/windows/windows.factor index 67d13fc50f..f3a1eb33f5 100755 --- a/extra/hardware-info/windows/windows.factor +++ b/extra/hardware-info/windows/windows.factor @@ -1,7 +1,7 @@ USING: alien alien.c-types kernel libc math namespaces windows windows.kernel32 windows.advapi32 -hardware-info.windows.backend -words combinators vocabs.loader hardware-info.backend ; +words combinators vocabs.loader hardware-info.backend +system ; IN: hardware-info.windows : system-info ( -- SYSTEM_INFO ) @@ -63,7 +63,8 @@ IN: hardware-info.windows : system-windows-directory ( -- str ) \ GetSystemWindowsDirectory get-directory ; +<< { { [ wince? ] [ "hardware-info.windows.ce" ] } { [ winnt? ] [ "hardware-info.windows.nt" ] } -} cond [ require ] when* +} cond [ require ] when* >> From 5c21b08606848c3c776534fa9c7a8432bb2eb234 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:11:55 -0600 Subject: [PATCH 019/194] remove a line of comments --- extra/db/postgresql/ffi/ffi.factor | 1 - 1 file changed, 1 deletion(-) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index dbaa70c625..23368164a1 100644 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -1,6 +1,5 @@ ! Copyright (C) 2007 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -! adapted from libpq-fe.h version 7.4.7 ! tested on debian linux with postgresql 8.1 USING: alien alien.syntax combinators system ; From 1ae14bbacfcc5c4a58d904779d286a745979a750 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:53:04 -0600 Subject: [PATCH 020/194] skeletonize mysql --- extra/db/mysql/lib/lib.factor | 102 ++++++++++++++-------------------- extra/db/mysql/mysql.factor | 45 ++++++++++++++- 2 files changed, 87 insertions(+), 60 deletions(-) diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor index 7d5c2d55dc..59d1b6ff3d 100644 --- a/extra/db/mysql/lib/lib.factor +++ b/extra/db/mysql/lib/lib.factor @@ -14,81 +14,65 @@ TUPLE: mysql-result-set ; : new-mysql ( -- conn ) f mysql_init ; - -: mysql-error-string ( mysql-connection -- str ) - mysql-db-handle mysql_error ; : mysql-error ( mysql -- ) - mysql-error-string throw ; + [ mysql_error throw ] when* ; : mysql-connect ( mysql-connection -- ) - init-mysql swap - [ set-mysql-connection-mysqlconn ] 2keep - [ mysql-connection-host ] keep - [ mysql-connection-user ] keep - [ mysql-connection-password ] keep - [ mysql-connection-db ] keep - [ mysql-connection-port f 0 mysql_real_connect ] keep - [ set-mysql-connection-handle ] keep - dup mysql-connection-handle - [ connect-error-msg throw ] unless ; + new-mysql over set-mysql-db-handle + dup { + mysql-db-handle + mysql-db-host + mysql-db-user + mysql-db-password + mysql-db-db + mysql-db-port + } get-slots f 0 mysql_real_connect mysql-error ; ! ========================================================= ! Low level mysql utility definitions ! ========================================================= : (mysql-query) ( mysql-connection query -- ret ) - >r mysql-connection-mysqlconn r> mysql_query ; + >r mysql-db-handle r> mysql_query ; -: (mysql-result) ( mysql-connection -- ret ) - [ mysql-connection-mysqlconn mysql_use_result ] keep - [ set-mysql-connection-resulthandle ] keep ; - -: (mysql-affected-rows) ( mysql-connection -- n ) - mysql-connection-mysqlconn mysql_affected_rows ; +! : (mysql-result) ( mysql-connection -- ret ) + ! [ mysql-db-handle mysql_use_result ] keep + ! [ set-mysql-connection-resulthandle ] keep ; -: (mysql-free-result) ( mysql-connection -- ) - mysql-connection-resulthandle drop ; +! : (mysql-affected-rows) ( mysql-connection -- n ) + ! mysql-connection-mysqlconn mysql_affected_rows ; -: (mysql-row) ( mysql-connection -- row ) - mysql-connection-resulthandle mysql_fetch_row ; +! : (mysql-free-result) ( mysql-connection -- ) + ! mysql-connection-resulthandle drop ; -: (mysql-num-cols) ( mysql-connection -- n ) - mysql-connection-resulthandle mysql_num_fields ; +! : (mysql-row) ( mysql-connection -- row ) + ! mysql-connection-resulthandle mysql_fetch_row ; + +! : (mysql-num-cols) ( mysql-connection -- n ) + ! mysql-connection-resulthandle mysql_num_fields ; -: mysql-char*-nth ( index object -- str ) - #! Utility based on 'char*-nth' to perform an additional sanity check on the value - #! extracted from the array of strings. - void*-nth [ alien>char-string ] [ "" ] if* ; - -: mysql-row>seq ( object n -- seq ) - [ swap mysql-char*-nth ] map-with ; - -: (mysql-result>seq) ( seq -- seq ) - my-conn get (mysql-row) dup [ - my-conn get (mysql-num-cols) mysql-row>seq - over push - (mysql-result>seq) - ] [ drop ] if - ! Perform needed cleanup on fetched results - my-conn get (mysql-free-result) ; - -! ========================================================= -! Public Word Definitions -! ========================================================= +! : mysql-char*-nth ( index object -- str ) + ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value + ! #! extracted from the array of strings. + ! void*-nth [ alien>char-string ] [ "" ] if* ; +! : mysql-row>seq ( object n -- seq ) + ! [ swap mysql-char*-nth ] map-with ; -: mysql-query ( query -- ret ) - >r my-conn get r> (mysql-query) drop - my-conn get (mysql-result) ; +! : (mysql-result>seq) ( seq -- seq ) + ! my-conn get (mysql-row) dup [ + ! my-conn get (mysql-num-cols) mysql-row>seq + ! over push + ! (mysql-result>seq) + ! ] [ drop ] if + ! ! Perform needed cleanup on fetched results + ! my-conn get (mysql-free-result) ; -: mysql-command ( query -- n ) - mysql-query drop - my-conn get (mysql-affected-rows) ; +! : mysql-query ( query -- ret ) + ! >r my-conn get r> (mysql-query) drop + ! my-conn get (mysql-result) ; -: with-mysql ( host user password db port quot -- ) - [ - >r my-conn set - my-conn get mysql-connect drop r> - [ my-conn get mysql-close ] cleanup - ] with-scope ; inline +! : mysql-command ( query -- n ) + ! mysql-query drop + ! my-conn get (mysql-affected-rows) ; diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor index 8043bc2782..941c25e1fa 100644 --- a/extra/db/mysql/mysql.factor +++ b/extra/db/mysql/mysql.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for license. USING: alien continuations io kernel prettyprint sequences -db ; +db db.mysql.ffi ; IN: db.mysql TUPLE: mysql-db handle host user password db port ; +TUPLE: mysql-statement ; +TUPLE: mysql-result-set ; M: mysql-db db-open ( mysql-db -- ) ; @@ -13,3 +15,44 @@ M: mysql-db dispose ( mysql-db -- ) mysql-db-handle mysql_close ; +M: mysql-db ( str -- statement ) + ; + +M: mysql-db ( str -- statement ) + ; + +M: mysql-statement prepare-statement ( statement -- ) + ; + +M: mysql-statement bind-statement* ( statement -- ) + ; + +M: mysql-statement rebind-statement ( statement -- ) + ; + +M: mysql-statement execute-statement ( statement -- ) + ; + +M: mysql-statement query-results ( query -- result-set ) + ; + +M: mysql-result-set #rows ( result-set -- n ) + ; + +M: mysql-result-set #columns ( result-set -- n ) + ; + +M: mysql-result-set row-column ( result-set n -- obj ) + ; + +M: mysql-result-set advance-row ( result-set -- ? ) + ; + +M: mysql-db begin-transaction ( -- ) + ; + +M: mysql-db commit-transaction ( -- ) + ; + +M: mysql-db rollback-transaction ( -- ) + ; From 21183af0ceb70821d6de9b6c0dcc5b8f824522ff Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 17:56:00 -0600 Subject: [PATCH 021/194] remove sudo requirement --- misc/factor.sh | 1 - 1 file changed, 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index fa8cdcd5b1..d1ef738cd9 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -45,7 +45,6 @@ check_gcc_version() { } check_installed_programs() { - ensure_program_installed sudo ensure_program_installed chmod ensure_program_installed uname ensure_program_installed git From 6aabef8e3213d0a92fff3688142ae30b5b5e066b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Mon, 4 Feb 2008 20:49:40 -0600 Subject: [PATCH 022/194] git pull to master delete staging.*.image --- misc/factor.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/misc/factor.sh b/misc/factor.sh index d1ef738cd9..c8e0456b3a 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -196,7 +196,7 @@ git_clone() { git_pull_factorcode() { echo "Updating the git repository from factorcode.org..." - git pull git://factorcode.org/git/factor.git + git pull git://factorcode.org/git/factor.git master check_ret git } @@ -219,6 +219,7 @@ delete_boot_images() { echo "Deleting old images..." rm $BOOT_IMAGE > /dev/null 2>&1 rm $BOOT_IMAGE.* > /dev/null 2>&1 + rm staging.*.image > /dev/null 2>&1 } get_boot_image() { From 1f66e8173f955a28416560be41f28707b68bba31 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 4 Feb 2008 21:26:59 -0600 Subject: [PATCH 023/194] builder: convert to io.launcher --- extra/builder/builder.factor | 151 +++++++++++++++++++---------------- 1 file changed, 82 insertions(+), 69 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 38570ae46f..cb0720d0a9 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,7 +1,7 @@ -USING: kernel io io.files io.launcher tools.deploy.backend - system namespaces sequences splitting math.parser - unix prettyprint tools.time calendar bake vars ; +USING: kernel io io.files io.launcher hashtables tools.deploy.backend + system continuations namespaces sequences splitting math.parser + prettyprint tools.time calendar bake vars http.client ; IN: builder @@ -19,16 +19,20 @@ IN: builder SYMBOL: builder-recipients -: quote ( str -- str ) "'" swap "'" 3append ; - : email-file ( subject file -- ) `{ - "cat" , - "| mutt -s" ,[ quote ] - "-x" %[ builder-recipients get ] - } - " " join system drop ; - + { +stdin+ , } + { +arguments+ { "mutt" "-s" , %[ builder-recipients get ] } } + } + >hashtable run-process drop ; + +: email-string ( subject -- ) + `{ "mutt" "-s" , %[ builder-recipients get ] } + + dup + dispose + process-stream-process wait-for-process drop ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; @@ -41,74 +45,83 @@ VAR: stamp : build ( -- ) -datestamp >stamp + datestamp >stamp -"/builds/factor" cd -"git pull git://factorcode.org/git/factor.git" system -0 = -[ ] -[ - "builder: git pull" "/dev/null" email-file - "builder: git pull" throw -] -if + "/builds/factor" cd + + { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" } + run-process process-status + 0 = + [ ] + [ + "builder: git pull" email-string + "builder: git pull" throw + ] + if -"/builds/" stamp> append make-directory -"/builds/" stamp> append cd -"git clone /builds/factor" system drop + "/builds/" stamp> append make-directory + "/builds/" stamp> append cd -"factor" cd + { "git" "clone" "/builds/factor" } run-process drop -{ "git" "show" } -[ readln ] with-stream -" " split second -"../git-id" [ print ] with-stream + "factor" cd -"make clean" system drop + { "git" "show" } + [ readln ] with-stream + " " split second + "../git-id" [ print ] with-stream -"make " target " > ../compile-log" 3append system -0 = -[ ] -[ - "builder: vm compile" "../compile-log" email-file - "builder: vm compile" throw -] if + { "make" "clean" } run-process drop -"wget http://factorcode.org/images/latest/" boot-image-name append system -0 = -[ ] -[ - "builder: image download" "/dev/null" email-file - "builder: image download" throw -] if + `{ + { +arguments+ { "make" ,[ target ] } } + { +stdout+ "../compile-log" } + { +stderr+ +stdout+ } + } + >hashtable run-process process-status + 0 = + [ ] + [ + "builder: vm compile" "../compile-log" email-file + "builder: vm compile" throw + ] if -[ - "./factor -i=" boot-image-name " -no-user-init > ../boot-log" - 3append - system -] -benchmark nip -"../boot-time" [ . ] with-stream -0 = -[ ] -[ - "builder: bootstrap" "../boot-log" email-file - "builder: bootstrap" throw -] if + [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ "builder: image download" email-string ] + recover -[ - "./factor -e='USE: tools.browser load-everything' > ../load-everything-log" - system -] benchmark nip -"../load-everything-time" [ . ] with-stream -0 = -[ ] -[ - "builder: load-everything" "../load-everything-log" email-file - "builder: load-everything" throw -] if + `{ + { +arguments+ { + "./factor" + ,[ "-i=" boot-image-name append ] + "-no-user-init" + } } + { +stdout+ "../boot-log" } + { +stderr+ +stdout+ } + } + >hashtable + [ run-process process-status ] + benchmark nip "../boot-time" [ . ] with-stream + 0 = + [ ] + [ + "builder: bootstrap" "../boot-log" email-file + "builder: bootstrap" throw + ] if -; + `{ + { +arguments+ { "./factor" "-e=USE: tools.browser load-everything" } } + { +stdout+ "../load-everything-log" } + { +stderr+ +stdout+ } + } + >hashtable [ run-process process-status ] benchmark nip + "../load-everything-time" [ . ] with-stream + 0 = + [ ] + [ + "builder: load-everything" "../load-everything-log" email-file + "builder: load-everything" throw + ] if ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From bd2226d89e09fa14a600238277166a490be96984 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Mon, 4 Feb 2008 21:58:57 -0600 Subject: [PATCH 024/194] builder: add factor-binary word --- extra/builder/builder.factor | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index cb0720d0a9..d20b5b8e5b 100644 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,7 +1,8 @@ USING: kernel io io.files io.launcher hashtables tools.deploy.backend system continuations namespaces sequences splitting math.parser - prettyprint tools.time calendar bake vars http.client ; + prettyprint tools.time calendar bake vars http.client + combinators ; IN: builder @@ -39,6 +40,15 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: factor-binary ( -- name ) + os + { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } + { "windows" [ "./factor-nt.exe" ] } + [ drop "./factor" ] } + case ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -92,7 +102,7 @@ VAR: stamp `{ { +arguments+ { - "./factor" + ,[ factor-binary ] ,[ "-i=" boot-image-name append ] "-no-user-init" } } @@ -110,7 +120,8 @@ VAR: stamp ] if `{ - { +arguments+ { "./factor" "-e=USE: tools.browser load-everything" } } + { +arguments+ + { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } { +stdout+ "../load-everything-log" } { +stderr+ +stdout+ } } From 659b6d8f3c3e2ca0f5deed100e8ace971dd7e4c7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:38 -0600 Subject: [PATCH 025/194] Better assert-depth error --- core/debugger/debugger.factor | 30 ++++++++++++++++++++++++++---- 1 file changed, 26 insertions(+), 4 deletions(-) diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 77c6da38e9..53f3387d85 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -87,7 +87,32 @@ TUPLE: assert got expect ; : depth ( -- n ) datastack length ; -: assert-depth ( quot -- ) depth slip depth swap assert= ; +: trim-datastacks ( seq1 seq2 -- seq1' seq2' ) + 2dup [ length ] 2apply min tuck tail >r tail r> ; + +TUPLE: relative-underflow stack ; + +: relative-underflow ( before after -- * ) + trim-datastacks nip \ relative-underflow construct-boa throw ; + +M: relative-underflow summary + drop "Too many items removed from data stack" ; + +TUPLE: relative-overflow stack ; + +M: relative-overflow summary + drop "Superfluous items pushed to data stack" ; + +: relative-overflow ( before after -- * ) + trim-datastacks drop \ relative-overflow construct-boa throw ; + +: assert-depth ( quot -- ) + >r datastack r> swap slip >r datastack r> + 2dup [ length ] compare sgn { + { -1 [ relative-underflow ] } + { 0 [ 2drop ] } + { 1 [ relative-overflow ] } + } case ; inline : expired-error. ( obj -- ) "Object did not survive image save/load: " write third . ; @@ -222,9 +247,6 @@ M: redefine-error error. "Re-definition of " write redefine-error-def . ; -M: forward-error error. - "Forward reference to " write forward-error-word . ; - M: undefined summary drop "Calling a deferred word before it has been defined" ; From 87887a11654619d03ca37e7d63a87196c5506a7e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:49 -0600 Subject: [PATCH 026/194] Monitors tweak --- extra/io/unix/linux/linux.factor | 10 ++-------- extra/io/windows/nt/monitor/monitor.factor | 16 ++++++++-------- 2 files changed, 10 insertions(+), 16 deletions(-) diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 1707ac9546..dcf1beabf9 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -25,8 +25,6 @@ TUPLE: inotify watches ; : wd>monitor ( wd -- monitor ) watches at ; -: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; - : ( -- port ) H{ } clone inotify_init dup io-error inotify @@ -89,12 +87,8 @@ M: linux-monitor dispose ( monitor -- ) ] { } make ; : parse-file-notify ( buffer -- changed path ) - { - inotify-event-wd - inotify-event-name - inotify-event-mask - } get-slots - parse-action -rot alien>char-string >r wd>path r> path+ ; + { inotify-event-name inotify-event-mask } get-slots + parse-action swap alien>char-string ; : events-exhausted? ( i buffer -- ? ) buffer-fill >= ; diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index d418dff270..6f956760a8 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -65,20 +65,20 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; -: parse-file-notify ( directory buffer -- changed path ) +: parse-file-notify ( buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots parse-action 1array -rot - memory>u16-string path+ ; + } get-slots parse-action 1array swap + memory>u16-string ; -: (changed-files) ( directory buffer -- ) - 2dup parse-file-notify changed-file +: (changed-files) ( buffer -- ) + dup parse-file-notify changed-file dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? - [ 3drop ] [ swap (changed-files) ] if ; + [ 2drop ] [ swap (changed-files) ] if ; M: windows-nt-io fill-queue ( monitor -- ) - dup win32-monitor-path over buffer-ptr pick read-changes - [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc + dup buffer-ptr over read-changes + [ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc swap set-monitor-queue ; From 2d3298d611ab2fd1dcdfa2b7577928299d8de9bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:30:59 -0600 Subject: [PATCH 027/194] Method usages cleanup --- core/bootstrap/image/image.factor | 8 +------- core/bootstrap/stage2.factor | 1 + core/compiler/units/units-docs.factor | 9 +-------- core/compiler/units/units.factor | 5 ----- core/definitions/definitions-docs.factor | 4 +--- core/definitions/definitions-tests.factor | 4 +++- core/generic/generic-tests.factor | 2 +- core/generic/generic.factor | 13 ++++++++----- core/generic/standard/standard.factor | 2 +- core/inference/inference.factor | 11 +++++++---- core/optimizer/backend/backend.factor | 2 +- core/parser/parser-docs.factor | 4 +--- core/parser/parser-tests.factor | 4 ++-- core/parser/parser.factor | 10 +++------- core/source-files/source-files.factor | 14 ++++++++++++++ core/vocabs/loader/loader-tests.factor | 2 +- core/words/words-tests.factor | 3 ++- extra/tools/browser/browser.factor | 2 +- extra/tools/crossref/crossref.factor | 17 +---------------- 19 files changed, 50 insertions(+), 67 deletions(-) mode change 100644 => 100755 core/compiler/units/units-docs.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 60e73cb249..3dadee5193 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -203,14 +203,8 @@ M: f ' ! Words -DEFER: emit-word - -: emit-generic ( generic -- ) - dup "default-method" word-prop method-word emit-word - "methods" word-prop [ nip method-word emit-word ] assoc-each ; - : emit-word ( word -- ) - dup generic? [ dup emit-generic ] when + dup subwords [ emit-word ] each [ dup hashcode ' , dup word-name ' , diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 7a0fab8a99..f3483add57 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -24,6 +24,7 @@ IN: bootstrap.stage2 "Cross-referencing..." print flush H{ } clone crossref set-global xref-words + xref-generics xref-sources ] unless diff --git a/core/compiler/units/units-docs.factor b/core/compiler/units/units-docs.factor old mode 100644 new mode 100755 index 363b5b5014..99124d40ae --- a/core/compiler/units/units-docs.factor +++ b/core/compiler/units/units-docs.factor @@ -28,9 +28,7 @@ HELP: redefine-error HELP: remember-definition { $values { "definition" "a definition specifier" } { "loc" "a " { $snippet "{ path line# }" } " pair" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: old-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined by " { $link file } " the most recent time it was loaded." } ; @@ -38,11 +36,6 @@ HELP: old-definitions HELP: new-definitions { $var-description "Stores an assoc where the keys form the set of definitions which were defined so far by the current parsing of " { $link file } "." } ; -HELP: forward-error -{ $values { "word" word } } -{ $description "Throws a " { $link forward-error } "." } -{ $description "Indicates a word is being referenced prior to the location of its most recent definition. This can only happen if a source file is loaded, and subsequently edited such that two dependent definitions are reversed." } ; - HELP: with-compilation-unit { $values { "quot" quotation } } { $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." } diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 68e1a79185..242ed9854a 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -26,11 +26,6 @@ TUPLE: redefine-error def ; over new-definitions get first key? [ dup redefine-error ] when new-definitions get second (remember-definition) ; -TUPLE: forward-error word ; - -: forward-error ( word -- ) - \ forward-error construct-boa throw ; - : forward-reference? ( word -- ? ) dup old-definitions get assoc-stack [ new-definitions get assoc-stack not ] diff --git a/core/definitions/definitions-docs.factor b/core/definitions/definitions-docs.factor index eec88bba0c..d855a14be9 100755 --- a/core/definitions/definitions-docs.factor +++ b/core/definitions/definitions-docs.factor @@ -52,9 +52,7 @@ $nl $nl "If the parser did not have special checks for this case, then the modified source file would still load, because when the definition of " { $snippet "hello-world" } " on line 4 is being parsed, the " { $snippet "world" } " word is already present in the dictionary from an earlier run. The developer would then not discover this mistake until attempting to load the source file into a fresh image." $nl -"Since this is undesirable, the parser explicitly raises an error if a source file refers to a word which is in the dictionary, but defined after it is used." -{ $subsection forward-error } -"If a source file raises a " { $link forward-error } " when loaded into a development image, then it would have raised a " { $link no-word } " error when loaded into a fresh image." +"Since this is undesirable, the parser explicitly raises a " { $link no-word } " error if a source file refers to a word which is in the dictionary, but defined after it is used." $nl "The parser also catches duplicate definitions. If an artifact is defined twice in the same source file, the earlier definition will never be accessible, and this is almost always a mistake, perhaps due to a bad choice of word names, or a copy and paste error. The parser raises an error in this case." { $subsection redefine-error } ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index a4cb4de902..f0b0888052 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -6,6 +6,8 @@ TUPLE: combination-1 ; M: combination-1 perform-combination 2drop { } [ ] each [ ] ; +M: combination-1 make-default-method 2drop [ "No method" throw ] ; + SYMBOL: generic-1 [ @@ -20,7 +22,7 @@ SYMBOL: generic-1 ] with-compilation-unit ] unit-test -GENERIC: some-generic +GENERIC: some-generic ( a -- b ) USE: arrays diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f0d5bf3063..f1e1ebd6d2 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -177,7 +177,7 @@ M: f tag-and-f 4 ; TUPLE: debug-combination ; M: debug-combination make-default-method - 2drop [ "Oops" throw ] when ; + 2drop [ "Oops" throw ] ; M: debug-combination perform-combination drop diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 2100f49423..453d72effb 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -73,7 +73,8 @@ M: method-body stack-effect : ( quot class generic -- word ) [ make-method-def ] 2keep method-word-name f - dup rot define ; + dup rot define + dup xref ; : ( quot class generic -- method ) check-method @@ -135,12 +136,14 @@ M: assoc update-methods ( assoc -- ) make-generic ] if ; -: subwords ( generic -- seq ) +GENERIC: subwords ( word -- seq ) + +M: word subwords drop f ; + +M: generic subwords dup "methods" word-prop values swap "default-method" word-prop add [ method-word ] map ; : xref-generics ( -- ) - all-words - [ generic? ] subset - [ subwords [ xref ] each ] each ; + all-words [ subwords [ xref ] each ] each ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index d52208ccbf..88f6a05bc2 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -91,7 +91,7 @@ TUPLE: no-method object generic ; : class-hash-dispatch-quot ( methods quot picker -- quot ) >r >r hash-methods r> map - hash-dispatch-quot r> [ class-hash ] rot 3append ; + hash-dispatch-quot r> [ class-hash ] rot 3append ; inline : big-generic ( methods -- quot ) [ small-generic ] picker class-hash-dispatch-quot ; diff --git a/core/inference/inference.factor b/core/inference/inference.factor index 0fc344dd85..3f52eaadf4 100755 --- a/core/inference/inference.factor +++ b/core/inference/inference.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: inference.backend inference.state inference.dataflow inference.known-words inference.transforms inference.errors -sequences prettyprint io effects kernel namespaces quotations -words vocabs ; +kernel io effects namespaces sequences quotations vocabs +generic words ; IN: inference GENERIC: infer ( quot -- effect ) @@ -28,4 +28,7 @@ M: callable dataflow-with ] with-infer nip ; : forget-errors ( -- ) - all-words [ f "no-effect" set-word-prop ] each ; + all-words [ + dup subwords [ f "no-effect" set-word-prop ] each + f "no-effect" set-word-prop + ] each ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 27b1b1e0ec..9d75346091 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -256,7 +256,7 @@ M: #dispatch optimize-node* tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 5 >= + dup word-def flat-length 6 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index 30e259c033..d8d6c9b7bc 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -202,9 +202,7 @@ HELP: location HELP: save-location { $values { "definition" "a definition specifier" } } -{ $description "Saves the location of a definition and associates this definition with the current source file." -$nl -"This is the book-keeping required to detect " { $link redefine-error } " and " { $link forward-error } "." } ; +{ $description "Saves the location of a definition and associates this definition with the current source file." } ; HELP: parser-notes { $var-description "A boolean controlling whether the parser will print various notes and warnings. Switched on by default. If a source file is being run for its effect on the " { $link stdio } " stream, this variable should be switched off, to prevent parser notes from polluting the output." } ; diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index b00e8e26b4..f503528a24 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -342,7 +342,7 @@ IN: temporary [ "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test [ ] [ @@ -354,7 +354,7 @@ IN: temporary [ "IN: temporary \\ class-fwd-test" "redefining-a-class-3" parse-stream drop - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test [ t ] [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index ffecf9493e..6d7ad47843 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -235,7 +235,8 @@ M: no-word summary : no-word ( name -- newword ) dup \ no-word construct-boa - swap words-named word-restarts throw-restarts + swap words-named [ forward-reference? not ] subset + word-restarts throw-restarts dup word-vocabulary (use+) ; : check-forward ( str word -- word ) @@ -244,7 +245,7 @@ M: no-word summary dup use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ forward-error ] ?if + [ ] [ no-word ] ?if ] [ nip ] if ; @@ -415,11 +416,6 @@ SYMBOL: interactive-vocabs over stack. ] when 2drop ; -: outside-usages ( seq -- usages ) - dup [ - over usage [ pathname? not ] subset seq-diff - ] curry { } map>assoc ; - : filter-moved ( assoc -- newassoc ) [ drop where dup [ first ] when diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index c974145928..64ae2e376e 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -96,3 +96,17 @@ SYMBOL: file source-file-definitions old-definitions set [ ] [ file get rollback-source-file ] cleanup ] with-scope ; inline + +: smart-usage ( word -- definitions ) + \ f or usage [ + dup method-body? [ + "method" word-prop + { method-specializer method-generic } get-slots + 2array + ] when + ] map ; + +: outside-usages ( seq -- usages ) + dup [ + over smart-usage [ pathname? not ] subset seq-diff + ] curry { } map>assoc ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index f38276d318..560affa566 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -79,7 +79,7 @@ IN: temporary "resource:core/vocabs/loader/test/a/a.factor" parse-stream - ] catch [ forward-error? ] is? + ] catch [ no-word? ] is? ] unit-test 0 "count-me" set-global diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 2455250dc9..35a2421e71 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -87,7 +87,8 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset [ interned? not ] subset empty? + \ * usage [ word? ] subset + [ dup interned? swap method-body? or ] all? ] unit-test DEFER: calls-a-gensym diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 370e55eb97..dabc37e5de 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -238,7 +238,7 @@ C: vocab-author : vocab-xref ( vocab quot -- vocabs ) >r dup vocab-name swap words r> map [ [ word? ] subset [ word-vocabulary ] map ] map>set - remove [ vocab ] map ; inline + remove [ ] subset [ vocab ] map ; inline : vocab-uses ( vocab -- vocabs ) [ uses ] vocab-xref ; diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor index 663df61926..f6561e9f26 100755 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -3,7 +3,7 @@ USING: arrays definitions assocs io kernel math namespaces prettyprint sequences strings io.styles words generic tools.completion quotations parser inspector -sorting hashtables vocabs ; +sorting hashtables vocabs parser source-files ; IN: tools.crossref : synopsis-alist ( definitions -- alist ) @@ -12,21 +12,6 @@ IN: tools.crossref : definitions. ( alist -- ) [ write-object nl ] assoc-each ; -: (method-usage) ( word generic -- methods ) - tuck methods - [ second uses member? ] with subset keys - swap [ 2array ] curry map ; - -: method-usage ( word seq -- methods ) - [ generic? ] subset [ (method-usage) ] with map concat ; - -: compound-usage ( words -- seq ) - [ generic? not ] subset ; - -: smart-usage ( word -- definitions ) - \ f or - dup usage dup compound-usage -rot method-usage append ; - : usage. ( word -- ) smart-usage synopsis-alist sort-keys definitions. ; From 751a1da3d2fb1ee36d4d5e01238307ff371c4a2f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 23:48:18 -0600 Subject: [PATCH 028/194] Builder tweak --- extra/builder/builder.factor | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) mode change 100644 => 100755 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100644 new mode 100755 index d20b5b8e5b..3216105d47 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -14,7 +14,7 @@ IN: builder ,[ dup timestamp-day ] ,[ dup timestamp-hour ] ,[ timestamp-minute ] } - [ number>string 2 CHAR: 0 pad-left ] map "-" join ; + [ pad-00 ] map "-" join ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -29,10 +29,7 @@ SYMBOL: builder-recipients : email-string ( subject -- ) `{ "mutt" "-s" , %[ builder-recipients get ] } - - dup - dispose - process-stream-process wait-for-process drop ; + [ ] with-process-stream drop ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From ba1a958a321efdec8be27cdb4c7b0edcffd13468 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 13:11:36 -0600 Subject: [PATCH 029/194] Move cd and cwd primitives to native I/O, fix Windows normalize-pathname --- core/bootstrap/primitives.factor | 2 - core/bootstrap/stage2.factor | 6 +-- core/io/files/files-docs.factor | 4 +- core/io/files/files.factor | 6 ++- extra/io/unix/files/files.factor | 9 +++- extra/io/windows/nt/backend/backend.factor | 37 +------------ extra/io/windows/nt/files/files.factor | 62 ++++++++++++++++++++-- extra/io/windows/nt/nt-tests.factor | 6 ++- extra/unix/bsd/bsd.factor | 2 + extra/unix/linux/linux.factor | 2 + extra/unix/unix.factor | 1 + extra/windows/kernel32/kernel32.factor | 6 ++- vm/io.h | 2 - vm/os-unix.c | 13 ----- vm/os-windows-ce.c | 10 ---- vm/os-windows-nt.c | 15 ------ vm/os-windows.h | 1 + vm/primitives.c | 2 - 18 files changed, 93 insertions(+), 93 deletions(-) mode change 100644 => 100755 extra/unix/bsd/bsd.factor mode change 100644 => 100755 extra/unix/linux/linux.factor mode change 100644 => 100755 vm/io.h diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 550aac71b0..967840a3dc 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -553,8 +553,6 @@ builtins get num-tags get tail f union-class define-class { "millis" "system" } { "type" "kernel.private" } { "tag" "kernel.private" } - { "cwd" "io.files" } - { "cd" "io.files" } { "modify-code-heap" "compiler.units" } { "dlopen" "alien" } { "dlsym" "alien" } diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index f3483add57..c601ba7671 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: init command-line namespaces words debugger io kernel.private math memory continuations kernel io.files io.backend system parser vocabs sequences prettyprint vocabs.loader combinators splitting source-files strings definitions assocs compiler.errors compiler.units -math.parser ; +math.parser generic ; IN: bootstrap.stage2 ! Wrap everything in a catch which starts a listener so @@ -88,5 +88,5 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute + print-error :c "listener" vocab-main execute 1 exit ] recover diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 3a23c8f6ef..0b9a748eb8 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,12 +52,12 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; -HELP: cwd ( -- path ) +HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; -HELP: cd ( path -- ) +HELP: cd { $values { "path" "a pathname string" } } { $description "Changes the current working directory of the Factor process." } { $errors "Windows CE has no concept of ``current directory'', so this word throws an error there." } ; diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 6e4648b590..9952e6387b 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -1,10 +1,14 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: io.files USING: io.backend io.files.private io hashtables kernel math memory namespaces sequences strings assocs arrays definitions system combinators splitting sbufs ; +HOOK: cd io-backend ( path -- ) + +HOOK: cwd io-backend ( -- path ) + HOOK: io-backend ( path -- stream ) HOOK: io-backend ( path -- stream ) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index edee598435..3201c29c45 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,9 +1,16 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io unix kernel math continuations math.bitfields ; IN: io.unix.files +M: unix-io cwd + MAXPATHLEN dup getcwd + [ alien>char-string ] [ (io-error) ] if* ; + +M: unix-io cd + chdir io-error ; + : read-flags O_RDONLY ; inline : open-read ( path -- fd ) diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 88e7cdf84a..760bcec457 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -2,45 +2,10 @@ USING: alien alien.c-types arrays assocs combinators continuations destructors io io.backend io.nonblocking io.windows libc kernel math namespaces sequences threads tuples.lib windows windows.errors windows.kernel32 -strings splitting io.files qualified ascii ; +strings splitting io.files qualified ascii combinators.lib ; QUALIFIED: windows.winsock IN: io.windows.nt.backend -: unicode-prefix ( -- seq ) - "\\\\?\\" ; inline - -M: windows-nt-io root-directory? ( path -- ? ) - dup length 2 = [ - dup first Letter? - swap second CHAR: : = and - ] [ - drop f - ] if ; - -M: windows-nt-io normalize-pathname ( string -- string ) - dup string? [ "pathname must be a string" throw ] unless - "/" split "\\" join - { - ! empty - { [ dup empty? ] [ "empty path" throw ] } - ! .\\foo - { [ dup ".\\" head? ] [ - >r unicode-prefix cwd r> 1 tail 3append - ] } - ! c:\\foo - { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] } - ! \\\\?\\c:\\foo - { [ dup unicode-prefix head? ] [ ] } - ! foo.txt ..\\foo.txt - { [ t ] [ - [ - unicode-prefix % cwd % - dup first CHAR: \\ = [ CHAR: \\ , ] unless % - ] "" make - ] } - } cond [ "/\\." member? ] right-trim - dup peek CHAR: : = [ "\\" append ] when ; - SYMBOL: io-hash TUPLE: io-callback port continuation ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 4a304e5ac9..43686707a2 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,64 @@ -USING: continuations destructors io.buffers io.nonblocking -io.windows io.windows.nt.backend kernel libc math threads -windows windows.kernel32 ; +USING: continuations destructors io.buffers io.files io.backend +io.nonblocking io.windows io.windows.nt.backend kernel libc math +threads windows windows.kernel32 alien.c-types alien.arrays +sequences combinators combinators.lib ascii splitting alien +strings ; IN: io.windows.nt.files +M: windows-nt-io cwd + MAX_UNICODE_PATH dup "ushort" + [ GetCurrentDirectory win32-error=0/f ] keep + alien>u16-string ; + +M: windows-nt-io cd + SetCurrentDirectory win32-error=0/f ; + +: unicode-prefix ( -- seq ) + "\\\\?\\" ; inline + +M: windows-nt-io root-directory? ( path -- ? ) + dup length 2 = [ + dup first Letter? + swap second CHAR: : = and + ] [ + drop f + ] if ; + +: root-directory ( string -- string' ) + { + [ dup length 2 >= ] + [ dup second CHAR: : = ] + [ dup first Letter? ] + } && [ 2 head ] [ "Not an absolute path" throw ] if ; + +: prepend-prefix ( string -- string' ) + unicode-prefix swap append ; + +: windows-path+ ( cwd path -- newpath ) + { + ! empty + { [ dup empty? ] [ "empty path" throw ] } + ! \\\\?\\c:\\foo + { [ dup unicode-prefix head? ] [ nip ] } + ! ..\\foo + { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + ! .\\foo + { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } + ! \\foo + { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } + ! c:\\foo + { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + ! foo.txt + { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + } cond ; + +M: windows-nt-io normalize-pathname ( string -- string ) + dup string? [ "pathname must be a string" throw ] unless + "/" split "\\" join + cwd swap windows-path+ + [ "/\\." member? ] right-trim + dup peek CHAR: : = [ "\\" append ] when ; + M: windows-nt-io CreateFile-flags ( DWORD -- DWORD ) FILE_FLAG_OVERLAPPED bitor ; diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index 9dfef6796d..ad409fb083 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,4 @@ -USING: io.files kernel tools.test ; +USING: io.files kernel tools.test io.backend splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -14,3 +14,7 @@ IN: temporary [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test + +[ ] [ "" resource-path cd ] unit-test + +[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test diff --git a/extra/unix/bsd/bsd.factor b/extra/unix/bsd/bsd.factor old mode 100644 new mode 100755 index 0a5aa1080e..e652f1b9f9 --- a/extra/unix/bsd/bsd.factor +++ b/extra/unix/bsd/bsd.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! FreeBSD +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor old mode 100644 new mode 100755 index 0a3eb7ee5f..11db6cc862 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -5,6 +5,8 @@ USING: alien.syntax ; ! Linux. +: MAXPATHLEN 1024 ; inline + : O_RDONLY HEX: 0000 ; inline : O_WRONLY HEX: 0001 ; inline : O_RDWR HEX: 0002 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 750a4b5044..d32fc25eab 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -124,6 +124,7 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: int futimes ( int id, timeval[2] times ) ; FUNCTION: char* gai_strerror ( int ecode ) ; FUNCTION: int getaddrinfo ( char* hostname, char* servname, addrinfo* hints, addrinfo** res ) ; +FUNCTION: char* getcwd ( char* buf, size_t size ) ; FUNCTION: int getdtablesize ; FUNCTION: gid_t getegid ; FUNCTION: uid_t geteuid ; diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 45bd6bfae9..b8928c5820 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -892,7 +892,8 @@ FUNCTION: DWORD GetConsoleTitleW ( LPWSTR lpConsoleTitle, DWORD nSize ) ; ! FUNCTION: GetCurrentActCtx ! FUNCTION: GetCurrentConsoleFont ! FUNCTION: GetCurrentDirectoryA -! FUNCTION: GetCurrentDirectoryW +FUNCTION: BOOL GetCurrentDirectoryW ( DWORD len, LPTSTR buf ) ; +: GetCurrentDirectory GetCurrentDirectoryW ; inline FUNCTION: HANDLE GetCurrentProcess ( ) ; ! FUNCTION: GetCurrentProcessId FUNCTION: HANDLE GetCurrentThread ( ) ; @@ -1387,7 +1388,8 @@ FUNCTION: BOOL SetConsoleTitleW ( LPCWSTR lpConsoleTitle ) ; ! FUNCTION: SetCPGlobal ! FUNCTION: SetCriticalSectionSpinCount ! FUNCTION: SetCurrentDirectoryA -! FUNCTION: SetCurrentDirectoryW +FUNCTION: BOOL SetCurrentDirectoryW ( LPCWSTR lpDirectory ) ; +: SetCurrentDirectory SetCurrentDirectoryW ; inline ! FUNCTION: SetDefaultCommConfigA ! FUNCTION: SetDefaultCommConfigW ! FUNCTION: SetDllDirectoryA diff --git a/vm/io.h b/vm/io.h old mode 100644 new mode 100755 index d8cc2a0578..39e7390c3e --- a/vm/io.h +++ b/vm/io.h @@ -13,5 +13,3 @@ DECLARE_PRIMITIVE(fread); DECLARE_PRIMITIVE(open_file); DECLARE_PRIMITIVE(stat); DECLARE_PRIMITIVE(read_dir); -DECLARE_PRIMITIVE(cwd); -DECLARE_PRIMITIVE(cd); diff --git a/vm/os-unix.c b/vm/os-unix.c index 41dbe9cabf..92028dfc43 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -115,19 +115,6 @@ DEFINE_PRIMITIVE(read_dir) dpush(result); } -DEFINE_PRIMITIVE(cwd) -{ - char wd[MAXPATHLEN]; - if(getcwd(wd,MAXPATHLEN) == NULL) - io_error(); - box_char_string(wd); -} - -DEFINE_PRIMITIVE(cd) -{ - chdir(unbox_char_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows-ce.c b/vm/os-windows-ce.c index e68a6385ae..9b73692aa0 100755 --- a/vm/os-windows-ce.c +++ b/vm/os-windows-ce.c @@ -10,16 +10,6 @@ s64 current_millis(void) | (s64)ft.dwHighDateTime<<32) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - not_implemented_error(); -} - -DEFINE_PRIMITIVE(cd) -{ - not_implemented_error(); -} - char *strerror(int err) { /* strerror() is not defined on WinCE */ diff --git a/vm/os-windows-nt.c b/vm/os-windows-nt.c index e356c2f674..99ac21f62f 100755 --- a/vm/os-windows-nt.c +++ b/vm/os-windows-nt.c @@ -8,21 +8,6 @@ s64 current_millis(void) - EPOCH_OFFSET) / 10000; } -DEFINE_PRIMITIVE(cwd) -{ - F_CHAR buf[MAX_UNICODE_PATH]; - - if(!GetCurrentDirectory(MAX_UNICODE_PATH, buf)) - io_error(); - - box_u16_string(buf); -} - -DEFINE_PRIMITIVE(cd) -{ - SetCurrentDirectory(unbox_u16_string()); -} - DEFINE_PRIMITIVE(os_envs) { GROWABLE_ARRAY(result); diff --git a/vm/os-windows.h b/vm/os-windows.h index f252c214af..a22252fde8 100755 --- a/vm/os-windows.h +++ b/vm/os-windows.h @@ -30,6 +30,7 @@ typedef wchar_t F_CHAR; F_STRING *get_error_message(void); DLLEXPORT F_CHAR *error_message(DWORD id); +void windows_error(void); void init_ffi(void); void ffi_dlopen(F_DLL *dll, bool error); diff --git a/vm/primitives.c b/vm/primitives.c index f2f8ccf18d..dc7333c667 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -109,8 +109,6 @@ void *primitives[] = { primitive_millis, primitive_type, primitive_tag, - primitive_cwd, - primitive_cd, primitive_modify_code_heap, primitive_dlopen, primitive_dlsym, From c68e70877d47bd1239f6a1402edc767a7b6a3dfe Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Tue, 5 Feb 2008 16:42:50 -0500 Subject: [PATCH 030/194] Solution to Project Euler problem 43 --- extra/project-euler/043/043.factor | 97 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 6 +- 2 files changed, 100 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/043/043.factor diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor new file mode 100644 index 0000000000..abe455e273 --- /dev/null +++ b/extra/project-euler/043/043.factor @@ -0,0 +1,97 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: combinators.lib hashtables kernel math math.combinatorics math.parser + math.ranges project-euler.common sequences sorting ; +IN: project-euler.043 + +! http://projecteuler.net/index.php?section=problems&id=43 + +! DESCRIPTION +! ----------- + +! The number, 1406357289, is a 0 to 9 pandigital number because it is made up +! of each of the digits 0 to 9 in some order, but it also has a rather +! interesting sub-string divisibility property. + +! Let d1 be the 1st digit, d2 be the 2nd digit, and so on. In this way, we note +! the following: + +! * d2d3d4 = 406 is divisible by 2 +! * d3d4d5 = 063 is divisible by 3 +! * d4d5d6 = 635 is divisible by 5 +! * d5d6d7 = 357 is divisible by 7 +! * d6d7d8 = 572 is divisible by 11 +! * d7d8d9 = 728 is divisible by 13 +! * d8d9d10 = 289 is divisible by 17 + +! Find the sum of all 0 to 9 pandigital numbers with this property. + + +! SOLUTION +! -------- + +! Brute force generating all the pandigitals then checking 3-digit divisiblity +! properties...this is very slow! + +integer swap mod zero? ; + +: interesting? ( seq -- ? ) + { + [ 17 8 pick subseq-divisible? ] + [ 13 7 pick subseq-divisible? ] + [ 11 6 pick subseq-divisible? ] + [ 7 5 pick subseq-divisible? ] + [ 5 4 pick subseq-divisible? ] + [ 3 3 pick subseq-divisible? ] + [ 2 2 pick subseq-divisible? ] + } && nip ; + +PRIVATE> + +: euler043 ( -- answer ) + 1234567890 number>digits all-permutations + [ interesting? ] subset [ 10 swap digits>integer ] map sum ; + +! [ euler043 ] time +! 125196 ms run / 19548 ms GC time + + +! ALTERNATE SOLUTIONS +! ------------------- + +! Build the number from right to left, generating the next 3-digits according +! to the divisiblity rules and combining them with the previous digits if they +! overlap and still have all unique digits. When done with that, add whatever +! missing digit is needed to make the number pandigital. + + [ number>digits 3 0 pad-left ] map [ all-unique? ] subset ; + +: overlap? ( seq -- ? ) + dup first 2 tail* swap second 2 head = ; + +: clean ( seq -- seq ) + [ unclip 1 head add* concat ] map [ all-unique? ] subset ; + +: add-missing-digit ( seq -- seq ) + dup natural-sort 10 seq-diff first add* ; + +: interesting-pandigitals ( -- seq ) + 17 candidates { 13 11 7 5 3 2 } [ + candidates swap cartesian-product [ overlap? ] subset clean + ] each [ add-missing-digit ] map ; + +PRIVATE> + +: euler043a ( -- answer ) + interesting-pandigitals [ 10 swap digits>integer ] sigma ; + +! [ euler043a ] 100 ave-time +! 19 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler043a diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 0be0b456ad..ef28cf8778 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,9 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.048 project-euler.052 - project-euler.067 project-euler.075 project-euler.097 project-euler.134 - project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.043 project-euler.048 + project-euler.052 project-euler.067 project-euler.075 project-euler.097 + project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; IN: project-euler Date: Tue, 5 Feb 2008 16:35:42 -0600 Subject: [PATCH 031/194] Fix MIMIC: --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index c0da9c51bc..667805dcc3 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -39,7 +39,7 @@ M: tuple-class group-words : define-mimic ( group mimicker mimicked -- ) >r >r group-words r> r> [ pick "methods" word-prop at dup - [ method-def spin define-method ] [ 3drop ] if + [ method-def spin define-method ] [ 3drop ] if ] 2curry each ; : MIMIC: From 2b9f977912d1472bd909ad58432aa98fd2403e32 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:35:57 -0600 Subject: [PATCH 032/194] Fix Windows normalize-pathname --- extra/io/windows/nt/files/files.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 43686707a2..5cbcd063bd 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -1,8 +1,8 @@ USING: continuations destructors io.buffers io.files io.backend io.nonblocking io.windows io.windows.nt.backend kernel libc math threads windows windows.kernel32 alien.c-types alien.arrays -sequences combinators combinators.lib ascii splitting alien -strings ; +sequences combinators combinators.lib sequences.lib ascii +splitting alien strings ; IN: io.windows.nt.files M: windows-nt-io cwd @@ -47,7 +47,7 @@ M: windows-nt-io root-directory? ( path -- ? ) ! \\foo { [ dup "\\" head? ] [ >r root-directory r> append prepend-prefix ] } ! c:\\foo - { [ dup second CHAR: : = ] [ nip prepend-prefix ] } + { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] } ! foo.txt { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } } cond ; From 4297777e19bf43a735419f2e898edcfaaa9655eb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 16:36:11 -0600 Subject: [PATCH 033/194] better logging for webapps.planet --- extra/io/server/server.factor | 17 +++++++++-------- extra/webapps/planet/planet.factor | 20 +++++++++++++------- 2 files changed, 22 insertions(+), 15 deletions(-) diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 408fd29714..3c3d2c20f5 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io io.sockets io.files continuations kernel math math.parser namespaces parser sequences strings @@ -9,11 +9,14 @@ IN: io.server SYMBOL: log-stream +: with-log-stream ( quot -- ) + log-stream get swap with-stream* ; inline + : log-message ( str -- ) - log-stream get [ + [ "[" write now timestamp>string write "] " write print flush - ] with-stream* ; + ] with-log-stream ; : log-error ( str -- ) "Error: " swap append log-message ; @@ -24,15 +27,13 @@ SYMBOL: log-stream : log-file ( service -- path ) ".log" append resource-path ; -: with-log-stream ( stream quot -- ) - log-stream swap with-variable ; inline - : with-log-file ( file quot -- ) >r r> - [ with-log-stream ] curry with-disposal ; inline + [ log-stream swap with-variable ] curry + with-disposal ; inline : with-log-stdio ( quot -- ) - stdio get swap with-log-stream ; + stdio get log-stream rot with-variable ; inline : with-logging ( service quot -- ) over [ diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index e9105ee459..ede0c579de 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint ; +xml.writer prettyprint io.server ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -75,13 +75,11 @@ SYMBOL: cached-postings SYMBOL: last-update -: diagnostic write print flush ; - : fetch-feed ( triple -- feed ) second - dup "Fetching " diagnostic + "Fetching " over append log-message dup download-feed feed-entries - swap "Done fetching " diagnostic ; + "Done fetching " swap append log-message ; : ( author entry -- entry' ) clone @@ -89,7 +87,11 @@ SYMBOL: last-update [ set-entry-title ] keep ; : ?fetch-feed ( triple -- feed/f ) - [ fetch-feed ] [ swap . error. f ] recover ; + [ + fetch-feed + ] [ + swap [ . error. ] with-log-stream f + ] recover ; : fetch-blogroll ( blogroll -- entries ) dup 0 @@ -111,7 +113,11 @@ SYMBOL: last-update update-thread ; : start-update-thread ( -- ) - [ update-thread ] in-thread ; + [ + "webapps.planet" [ + update-thread + ] with-logging + ] in-thread ; "planet" "planet-factor" "extra/webapps/planet" web-app From be39d64ef8e3f7aec8300883ab5a0903f7362b67 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:07:37 -0600 Subject: [PATCH 034/194] Check fork() error code --- extra/unix/process/process.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 8b7144b979..c315d10d7f 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -8,7 +8,8 @@ IN: unix.process ! to implement io.launcher on Unix. User code should use ! io.launcher instead. -: >argv ( seq -- alien ) [ malloc-char-string ] map f add >c-void*-array ; +: >argv ( seq -- alien ) + [ malloc-char-string ] map f add >c-void*-array ; : exec ( pathname argv -- int ) [ malloc-char-string ] [ >argv ] bi* execv ; @@ -29,7 +30,7 @@ IN: unix.process >r [ first ] [ ] bi r> exec-with-env ; : with-fork ( child parent -- ) - fork dup zero? -roll swap curry if ; inline + fork dup io-error dup zero? -roll swap curry if ; inline : wait-for-pid ( pid -- status ) 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file From ede3254f0ab9ac092177481af3c5e994a18eb65c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:27:29 -0600 Subject: [PATCH 035/194] Bootstrap prints restarts --- core/bootstrap/stage2.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index c601ba7671..1a9bdd599a 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -88,5 +88,7 @@ IN: bootstrap.stage2 "output-image" get resource-path save-image-and-exit ] if ] [ - print-error :c "listener" vocab-main execute 1 exit + print-error :c restarts. + "listener" vocab-main execute + 1 exit ] recover From 898770f774005f701301146aaa421fba934b0286 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:31:27 -0600 Subject: [PATCH 036/194] Bootstrap fixes --- extra/io/unix/files/files.factor | 3 ++- extra/unix/process/process.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 3201c29c45..a70f7339d2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix kernel math continuations math.bitfields ; +unix kernel math continuations math.bitfields byte-arrays +alien ; IN: io.unix.files M: unix-io cwd diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index c315d10d7f..6fdc8e358b 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -1,6 +1,6 @@ USING: kernel alien.c-types sequences math unix combinators.cleave vectors kernel namespaces continuations -threads assocs vectors ; +threads assocs vectors io.unix.backend ; IN: unix.process From 9804d9462de31b3edbaa57dbe355ce0a2a674d22 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 17:33:36 -0600 Subject: [PATCH 037/194] Rename symbols to be consistent --- extra/io/launcher/launcher-docs.factor | 14 +++++++------- extra/io/launcher/launcher.factor | 16 ++++++++-------- 2 files changed, 15 insertions(+), 15 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index e372f7a41e..4979f135ac 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -24,11 +24,11 @@ $nl HELP: +environment-mode+ { $description "Launch descriptor key. Must equal of the following:" { $list - { $link prepend-environment } - { $link replace-environment } - { $link append-environment } + { $link +prepend-environment+ } + { $link +replace-environment+ } + { $link +append-environment+ } } -"Default value is " { $link append-environment } "." +"Default value is " { $link +append-environment+ } "." } ; HELP: +stdin+ @@ -61,17 +61,17 @@ HELP: +stderr+ HELP: +closed+ { $description "Possible value for " { $link +stdin+ } ", " { $link +stdout+ } ", and " { $link +stderr+ } " launch descriptors." } ; -HELP: prepend-environment +HELP: +prepend-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key together with the current environment, with entries from the current environment taking precedence." $nl "This is used in situations where you want to spawn a child process with some default environment variables set, but allowing the user to override these defaults by changing the environment before launching Factor." } ; -HELP: replace-environment +HELP: +replace-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the value of the " { $link +environment+ } " key." $nl "This is used in situations where you want full control over a child process environment, perhaps for security or testing." } ; -HELP: append-environment +HELP: +append-environment+ { $description "Possible value of " { $link +environment-mode+ } " launch descriptor key. The child process environment consists of the current environment together with the value of the " { $link +environment+ } " key, with entries from the " { $link +environment+ } " key taking precedence." $nl "This is used in situations where you want a spawn child process with some overridden environment variables." } ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9be90d28de..f2ed59a591 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -35,9 +35,9 @@ SYMBOL: +stdout+ SYMBOL: +stderr+ SYMBOL: +closed+ -SYMBOL: prepend-environment -SYMBOL: replace-environment -SYMBOL: append-environment +SYMBOL: +prepend-environment+ +SYMBOL: +replace-environment+ +SYMBOL: +append-environment+ : default-descriptor H{ @@ -45,7 +45,7 @@ SYMBOL: append-environment { +arguments+ f } { +detached+ f } { +environment+ H{ } } - { +environment-mode+ append-environment } + { +environment-mode+ +append-environment+ } } ; : with-descriptor ( desc quot -- ) @@ -53,14 +53,14 @@ SYMBOL: append-environment : pass-environment? ( -- ? ) +environment+ get assoc-empty? not - +environment-mode+ get replace-environment eq? or ; + +environment-mode+ get +replace-environment+ eq? or ; : get-environment ( -- env ) +environment+ get +environment-mode+ get { - { prepend-environment [ os-envs union ] } - { append-environment [ os-envs swap union ] } - { replace-environment [ ] } + { +prepend-environment+ [ os-envs union ] } + { +append-environment+ [ os-envs swap union ] } + { +replace-environment+ [ ] } } case ; GENERIC: >descriptor ( desc -- desc ) From f8df69d9a119967ea723a6924829da6a44dba210 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:00:24 -0600 Subject: [PATCH 038/194] Rename io.monitor to io.monitors; add log-viewer demo --- extra/help/handbook/handbook.factor | 4 ++-- extra/io/{monitor => monitors}/authors.txt | 0 .../monitors-docs.factor} | 14 +++++++------- .../monitor.factor => monitors/monitors.factor} | 2 +- extra/io/{monitor => monitors}/summary.txt | 0 extra/io/unix/linux/linux.factor | 2 +- .../windows/nt/{monitor => monitors}/authors.txt | 0 .../monitor.factor => monitors/monitors.factor} | 7 +++---- extra/io/windows/nt/nt.factor | 2 +- extra/log-viewer/authors.txt | 1 + extra/log-viewer/log-viewer.factor | 14 ++++++++++++++ extra/log-viewer/summary.txt | 1 + extra/log-viewer/tags.txt | 1 + 13 files changed, 32 insertions(+), 16 deletions(-) rename extra/io/{monitor => monitors}/authors.txt (100%) rename extra/io/{monitor/monitor-docs.factor => monitors/monitors-docs.factor} (87%) rename extra/io/{monitor/monitor.factor => monitors/monitors.factor} (94%) rename extra/io/{monitor => monitors}/summary.txt (100%) rename extra/io/windows/nt/{monitor => monitors}/authors.txt (100%) rename extra/io/windows/nt/{monitor/monitor.factor => monitors/monitors.factor} (94%) create mode 100755 extra/log-viewer/authors.txt create mode 100755 extra/log-viewer/log-viewer.factor create mode 100755 extra/log-viewer/summary.txt create mode 100755 extra/log-viewer/tags.txt diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 234e7891d7..81e4bea7b3 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -137,7 +137,7 @@ ARTICLE: "collections" "Collections" { $subsection "graphs" } { $subsection "buffers" } ; -USING: io.sockets io.launcher io.mmap io.monitor ; +USING: io.sockets io.launcher io.mmap io.monitors ; ARTICLE: "io" "Input and output" { $subsection "streams" } @@ -155,7 +155,7 @@ ARTICLE: "io" "Input and output" "Advanced features:" { $subsection "io.launcher" } { $subsection "io.mmap" } -{ $subsection "io.monitor" } ; +{ $subsection "io.monitors" } ; ARTICLE: "tools" "Developer tools" { $subsection "tools.annotations" } diff --git a/extra/io/monitor/authors.txt b/extra/io/monitors/authors.txt similarity index 100% rename from extra/io/monitor/authors.txt rename to extra/io/monitors/authors.txt diff --git a/extra/io/monitor/monitor-docs.factor b/extra/io/monitors/monitors-docs.factor similarity index 87% rename from extra/io/monitor/monitor-docs.factor rename to extra/io/monitors/monitors-docs.factor index de649f48e7..9d985ff3fb 100755 --- a/extra/io/monitor/monitor-docs.factor +++ b/extra/io/monitors/monitors-docs.factor @@ -1,4 +1,4 @@ -IN: io.monitor +IN: io.monitors USING: help.markup help.syntax continuations ; HELP: @@ -9,7 +9,7 @@ $nl HELP: next-change { $values { "monitor" "a monitor" } { "path" "a pathname string" } { "changes" "a change descriptor" } } -{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitor.descriptors" } "." } ; +{ $description "Waits for file system changes and outputs the pathname of the first changed file. The change descriptor is aq sequence of symbols documented in " { $link "io.monitors.descriptors" } "." } ; HELP: with-monitor { $values { "path" "a pathname string" } { "recursive?" "a boolean" } { "quot" "a quotation with stack effect " { $snippet "( monitor -- )" } } } @@ -27,7 +27,7 @@ HELP: +modify-file+ HELP: +rename-file+ { $description "Indicates that file has been renamed." } ; -ARTICLE: "io.monitor.descriptors" "File system change descriptors" +ARTICLE: "io.monitors.descriptors" "File system change descriptors" "Change descriptors output by " { $link next-change } ":" { $subsection +add-file+ } { $subsection +remove-file+ } @@ -35,24 +35,24 @@ ARTICLE: "io.monitor.descriptors" "File system change descriptors" { $subsection +rename-file+ } { $subsection +add-file+ } ; -ARTICLE: "io.monitor" "File system change monitors" +ARTICLE: "io.monitors" "File system change monitors" "File system change monitors listen for changes to file names, attributes and contents under a specified directory. They can optionally be recursive, in which case subdirectories are also monitored." $nl "Creating a file system change monitor and listening for changes:" { $subsection } { $subsection next-change } -{ $subsection "io.monitor.descriptors" } +{ $subsection "io.monitors.descriptors" } "Monitors are closed by calling " { $link dispose } " or " { $link with-disposal } "." $nl "A utility combinator which opens a monitor and cleans it up after:" { $subsection with-monitor } "An example which watches the Factor directory for changes:" { $code - "USE: io.monitor" + "USE: io.monitors" ": watch-loop ( monitor -- )" " dup next-change . . nl nl flush watch-loop ;" "" "\"\" resource-path f [ watch-loop ] with-monitor" } ; -ABOUT: "io.monitor" +ABOUT: "io.monitors" diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitors/monitors.factor similarity index 94% rename from extra/io/monitor/monitor.factor rename to extra/io/monitors/monitors.factor index 1d8499b392..d652f34f1e 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitors/monitors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io.backend kernel continuations namespaces sequences assocs hashtables sorting arrays ; -IN: io.monitor +IN: io.monitors ( path recursive? -- monitor ) FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots parse-action 1array swap - memory>u16-string ; + } get-slots parse-action 1array -rot memory>u16-string ; : (changed-files) ( buffer -- ) dup parse-file-notify changed-file diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index 5bdefd7713..b957aa2fca 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -5,7 +5,7 @@ USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files USE: io.windows.nt.launcher -USE: io.windows.nt.monitor +USE: io.windows.nt.monitors USE: io.windows.nt.sockets USE: io.windows.mmap USE: io.backend diff --git a/extra/log-viewer/authors.txt b/extra/log-viewer/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/log-viewer/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/log-viewer/log-viewer.factor b/extra/log-viewer/log-viewer.factor new file mode 100755 index 0000000000..0f139d184e --- /dev/null +++ b/extra/log-viewer/log-viewer.factor @@ -0,0 +1,14 @@ +USING: kernel io io.files io.monitors ; +IN: log-viewer + +: read-lines ( stream -- ) + dup stream-readln dup + [ print read-lines ] [ 2drop flush ] if ; + +: tail-file-loop ( stream monitor -- ) + dup next-change 2drop over read-lines tail-file-loop ; + +: tail-file ( file -- ) + dup dup read-lines + swap parent-directory f + tail-file-loop ; diff --git a/extra/log-viewer/summary.txt b/extra/log-viewer/summary.txt new file mode 100755 index 0000000000..5eb102447a --- /dev/null +++ b/extra/log-viewer/summary.txt @@ -0,0 +1 @@ +Simple log file watcher demo using io.monitors diff --git a/extra/log-viewer/tags.txt b/extra/log-viewer/tags.txt new file mode 100755 index 0000000000..cb5fc203e1 --- /dev/null +++ b/extra/log-viewer/tags.txt @@ -0,0 +1 @@ +demos From 53810cd17b49a9de41a80977e9c0e03b58be176a Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 5 Feb 2008 18:28:05 -0600 Subject: [PATCH 039/194] builder: update target --- extra/builder/builder.factor | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 3216105d47..832b89a7dc 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -33,7 +33,12 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; + +: target ( -- target ) + { { [ os "windows" = ] [ "windows-nt-x86-32" ] } + { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } + cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 20e4fcecda6d3b2a2d20756ae002fa85c19a1b34 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:48:38 -0600 Subject: [PATCH 040/194] Make OS name more consistent for extra/builder --- Makefile | 8 ++++---- core/system/system-docs.factor | 3 ++- core/system/system.factor | 2 +- vm/os-windows-nt.h | 2 +- 4 files changed, 8 insertions(+), 7 deletions(-) mode change 100644 => 100755 core/system/system-docs.factor mode change 100644 => 100755 core/system/system.factor diff --git a/Makefile b/Makefile index aad7fe90eb..5e1a9d6220 100755 --- a/Makefile +++ b/Makefile @@ -63,8 +63,8 @@ default: @echo "macosx-ppc" @echo "solaris-x86-32" @echo "solaris-x86-64" - @echo "windows-ce-arm" - @echo "windows-nt-x86-32" + @echo "wince-arm" + @echo "winnt-x86-32" @echo "" @echo "Additional modifiers:" @echo "" @@ -122,10 +122,10 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -windows-nt-x86-32: +winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -windows-ce-arm: +wince-arm: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor diff --git a/core/system/system-docs.factor b/core/system/system-docs.factor old mode 100644 new mode 100755 index d80cfa9ceb..bdd04307df --- a/core/system/system-docs.factor +++ b/core/system/system-docs.factor @@ -51,7 +51,8 @@ HELP: os "openbsd" "netbsd" "solaris" - "windows" + "wince" + "winnt" } } ; diff --git a/core/system/system.factor b/core/system/system.factor old mode 100644 new mode 100755 index 4983260a36..4500720058 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -22,7 +22,7 @@ splitting assocs ; os "wince" = ; foldable : winnt? ( -- ? ) - os "windows" = ; foldable + os "winnt" = ; foldable : windows? ( -- ? ) wince? winnt? or ; foldable diff --git a/vm/os-windows-nt.h b/vm/os-windows-nt.h index 9e451f0301..e289b6617d 100755 --- a/vm/os-windows-nt.h +++ b/vm/os-windows-nt.h @@ -12,7 +12,7 @@ typedef char F_SYMBOL; #define unbox_symbol_string unbox_char_string #define from_symbol_string from_char_string -#define FACTOR_OS_STRING "windows" +#define FACTOR_OS_STRING "winnt" #define FACTOR_DLL L"factor-nt.dll" #define FACTOR_DLL_NAME "factor-nt.dll" From cf99e405fe22f35900160fc054d401894f101d69 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:50:24 -0600 Subject: [PATCH 041/194] More intuitive error message for about --- extra/help/help.factor | 3 +++ 1 file changed, 3 insertions(+) mode change 100644 => 100755 extra/help/help.factor diff --git a/extra/help/help.factor b/extra/help/help.factor old mode 100644 new mode 100755 index 87bc0a4b7f..aefbf2aba2 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -96,6 +96,9 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup vocab [ ] [ + "No such vocabulary: " swap append throw + ] ?if dup vocab-help [ help ] [ From 551b3a42a130eaf0e0ea77e1b9ba873c5e5628db Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:52:16 -0600 Subject: [PATCH 042/194] New reset-memoized word --- extra/memoize/memoize.factor | 3 +++ extra/xmode/catalog/catalog.factor | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) mode change 100644 => 100755 extra/xmode/catalog/catalog.factor diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 5fa112921c..3b0b8fd29f 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -50,3 +50,6 @@ M: memoized definition "memo-quot" word-prop ; : memoize-quot ( quot effect -- memo-quot ) gensym swap dupd "declared-effect" set-word-prop dup rot define-memoized 1quotation ; + +: reset-memoized ( word -- ) + "memoize" word-prop clear-assoc ; diff --git a/extra/xmode/catalog/catalog.factor b/extra/xmode/catalog/catalog.factor old mode 100644 new mode 100755 index 9c7e6a1ee7..d6402603fa --- a/extra/xmode/catalog/catalog.factor +++ b/extra/xmode/catalog/catalog.factor @@ -99,7 +99,7 @@ SYMBOL: rule-sets (load-mode) dup finalize-mode ; : reset-modes ( -- ) - \ (load-mode) "memoize" word-prop clear-assoc ; + \ (load-mode) reset-memoized ; : ?glob-matches ( string glob/f -- ? ) dup [ glob-matches? ] [ 2drop f ] if ; From 18403d15faf04ade5a159672585fdb4f68a12bff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:10 -0600 Subject: [PATCH 043/194] tools.browser now uses io.monitor --- extra/tools/browser/browser-docs.factor | 22 ++++++++++-- extra/tools/browser/browser.factor | 47 ++++++++++++++++++------- extra/vocabs/monitor/authors.txt | 1 + extra/vocabs/monitor/monitor.factor | 14 ++++++++ extra/vocabs/monitor/summary.txt | 1 + 5 files changed, 71 insertions(+), 14 deletions(-) mode change 100644 => 100755 extra/tools/browser/browser-docs.factor create mode 100644 extra/vocabs/monitor/authors.txt create mode 100755 extra/vocabs/monitor/monitor.factor create mode 100644 extra/vocabs/monitor/summary.txt diff --git a/extra/tools/browser/browser-docs.factor b/extra/tools/browser/browser-docs.factor old mode 100644 new mode 100755 index db0e5942f5..28bef58a8a --- a/extra/tools/browser/browser-docs.factor +++ b/extra/tools/browser/browser-docs.factor @@ -2,16 +2,34 @@ USING: help.markup help.syntax io strings ; IN: tools.browser ARTICLE: "vocab-index" "Vocabulary index" -{ $tags,authors } +{ $tags } +{ $authors } { $describe-vocab "" } ; ARTICLE: "tools.browser" "Vocabulary browser" "Getting and setting vocabulary meta-data:" +{ $subsection vocab-file-contents } +{ $subsection set-vocab-file-contents } { $subsection vocab-summary } { $subsection set-vocab-summary } { $subsection vocab-tags } { $subsection set-vocab-tags } -{ $subsection add-vocab-tags } ; +{ $subsection add-vocab-tags } +"Global meta-data:" +{ $subsection all-vocabs } +{ $subsection all-vocabs-seq } +{ $subsection all-tags } +{ $subsection all-authors } +"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:" +{ $subsection reset-cache } ; + +HELP: vocab-file-contents +{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } +{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; + +HELP: set-vocab-file-contents +{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } +{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; HELP: vocab-summary { $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } } diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index dabc37e5de..7aefbc8aaa 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -1,13 +1,30 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces splitting sequences io.files kernel assocs words vocabs vocabs.loader definitions parser continuations inspector debugger io io.styles io.streams.lines hashtables sorting prettyprint source-files arrays combinators strings system math.parser help.markup help.topics help.syntax -help.stylesheet ; +help.stylesheet memoize ; IN: tools.browser +MEMO: (vocab-file-contents) ( path -- lines ) + ?resource-path dup exists? + [ lines ] [ drop f ] if ; + +: vocab-file-contents ( vocab name -- seq ) + vocab-path+ dup [ (vocab-file-contents) ] when ; + +: set-vocab-file-contents ( seq vocab name -- ) + dupd vocab-path+ [ + ?resource-path + [ [ print ] each ] with-stream + ] [ + "The " swap vocab-name + " vocabulary was not loaded from the file system" + 3append throw + ] ?if ; + : vocab-summary-path ( vocab -- string ) vocab-dir "summary.txt" path+ ; @@ -86,7 +103,7 @@ M: vocab-link summary vocab-summary ; dup [ "" vocabs-in-dir ] { } make ] { } map>assoc ; -: all-vocabs-seq ( -- seq ) +MEMO: all-vocabs-seq ( -- seq ) all-vocabs values concat ; : dangerous? ( name -- ? ) @@ -288,20 +305,20 @@ C: vocab-author : $tagged-vocabs ( element -- ) first tagged vocabs. ; -: all-tags ( vocabs -- seq ) [ vocab-tags ] map>set ; +MEMO: all-tags ( -- seq ) + all-vocabs-seq [ vocab-tags ] map>set ; : $authored-vocabs ( element -- ) first authored vocabs. ; -: all-authors ( vocabs -- seq ) [ vocab-authors ] map>set ; +MEMO: all-authors ( -- seq ) + all-vocabs-seq [ vocab-authors ] map>set ; -: $tags,authors ( element -- ) - drop - all-vocabs-seq - "Tags" $heading - dup all-tags tags. - "Authors" $heading - all-authors authors. ; +: $tags ( element -- ) + drop "Tags" $heading all-tags tags. ; + +: $authors ( element -- ) + drop "Authors" $heading all-authors authors. ; M: vocab-spec article-title vocab-name " vocabulary" append ; @@ -339,3 +356,9 @@ M: vocab-author article-content M: vocab-author article-parent drop "vocab-index" ; M: vocab-author summary article-title ; + +: reset-cache ( -- ) + \ (vocab-file-contents) reset-memoized + \ all-vocabs-seq reset-memoized + \ all-authors reset-memoized + \ all-tags reset-memoized ; diff --git a/extra/vocabs/monitor/authors.txt b/extra/vocabs/monitor/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/vocabs/monitor/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/vocabs/monitor/monitor.factor b/extra/vocabs/monitor/monitor.factor new file mode 100755 index 0000000000..24aa8b1d99 --- /dev/null +++ b/extra/vocabs/monitor/monitor.factor @@ -0,0 +1,14 @@ +USING: threads io.files io.monitors init kernel tools.browser ; +IN: vocabs.monitor + +! Use file system change monitoring to flush the tags/authors +! cache +: update-thread ( monitor -- ) + dup next-change 2drop reset-cache update-thread ; + +: start-update-thread + [ + "" resource-path t update-thread + ] in-thread ; + +[ start-update-thread ] "tools.browser" add-init-hook diff --git a/extra/vocabs/monitor/summary.txt b/extra/vocabs/monitor/summary.txt new file mode 100644 index 0000000000..27c0d3867a --- /dev/null +++ b/extra/vocabs/monitor/summary.txt @@ -0,0 +1 @@ +Use io.monitors to clear tools.browser authors/tags/summary cache From c87bd84635ed8c984f2cd9d87ef0e14b6711adef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:20 -0600 Subject: [PATCH 044/194] Fix opengl tags --- extra/opengl/tags.txt | 3 --- 1 file changed, 3 deletions(-) mode change 100644 => 100755 extra/opengl/tags.txt diff --git a/extra/opengl/tags.txt b/extra/opengl/tags.txt old mode 100644 new mode 100755 index 5e477dbcb3..bb863cf9a0 --- a/extra/opengl/tags.txt +++ b/extra/opengl/tags.txt @@ -1,4 +1 @@ -opengl.glu -opengl.gl -opengl bindings From 687cd7860321ac07a36f0c6d96b1c1cd946099b6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 18:55:28 -0600 Subject: [PATCH 045/194] Word moved --- extra/tools/deploy/config/config.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/tools/deploy/config/config.factor b/extra/tools/deploy/config/config.factor index e6d03c2233..1f34e68f29 100755 --- a/extra/tools/deploy/config/config.factor +++ b/extra/tools/deploy/config/config.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: vocabs.loader io.files io kernel sequences assocs splitting parser prettyprint namespaces math vocabs -hashtables ; +hashtables tools.browser ; IN: tools.deploy.config SYMBOL: deploy-name From 038578939f998bcdce47e47980cf019e3971105b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 19:01:19 -0600 Subject: [PATCH 046/194] Change require-all for Ed --- core/vocabs/loader/loader-docs.factor | 13 +++---- core/vocabs/loader/loader.factor | 50 ++++++++++++--------------- extra/bootstrap/io/io.factor | 2 ++ 3 files changed, 30 insertions(+), 35 deletions(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index 899d50407f..bc88661530 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,15 +124,12 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; +HELP: refresh-all-error +{ $values { "vocabs" "a sequence of vocabularies" } } +{ $description "Throws a " { $link require-all-error } "." } +{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; + HELP: refresh-all { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; { refresh refresh-all } related-words - -HELP: vocab-file-contents -{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } } -{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ; - -HELP: set-vocab-file-contents -{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } } -{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index f2c5b2a012..6e6d1923e0 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,16 +148,31 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: require-restart { { "Ignore this vocabulary" t } } ; +: load-error. ( vocab error -- ) + "While loading " swap dup >vocab-link write-object ":" print + print-error ; -: require-all ( seq -- ) - [ +TUPLE: require-all-error vocabs ; + +: require-all-error ( vocabs -- ) + \ require-all-error construct-boa throw ; + +M: require-all-error summary + drop "The require-all operation failed" ; + +: require-all ( vocabs -- ) + dup length 1 = [ first require ] [ [ - [ require ] - [ require-restart rethrow-restarts 2drop ] - recover - ] each - ] with-compiler-errors ; + [ + [ [ require ] [ 2array , ] recover ] each + ] { } make + dup empty? [ drop ] [ + "==== LOAD ERRORS:" print + dup [ nl load-error. ] assoc-each + keys require-all-error + ] if + ] with-compiler-errors + ] if ; : do-refresh ( modified-sources modified-docs -- ) 2dup @@ -190,22 +205,3 @@ load-vocab-hook set-global M: vocab where vocab-where ; M: vocab-link where vocab-where ; - -: vocab-file-contents ( vocab name -- seq ) - vocab-path+ dup [ - ?resource-path dup exists? [ - lines - ] [ - drop f - ] if - ] when ; - -: set-vocab-file-contents ( seq vocab name -- ) - dupd vocab-path+ [ - ?resource-path - [ [ print ] each ] with-stream - ] [ - "The " swap vocab-name - " vocabulary was not loaded from the file system" - 3append throw - ] ?if ; diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 065f7dd5c4..4d5440e546 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,3 +10,5 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when + +"vocabs.monitor" require From 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 19:16:22 -0600 Subject: [PATCH 047/194] Bug fixes --- core/io/files/files.factor | 13 ++++++++----- core/vocabs/loader/loader-docs.factor | 2 +- core/vocabs/loader/loader.factor | 2 +- extra/io/windows/nt/files/files.factor | 12 +++++++++--- extra/io/windows/nt/nt-tests.factor | 22 +++++++++++++++++++--- 5 files changed, 38 insertions(+), 13 deletions(-) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9952e6387b..9a99090699 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -29,12 +29,15 @@ HOOK: root-directory? io-backend ( path -- ? ) M: object root-directory? ( path -- ? ) path-separator? ; -: trim-path-separators ( str -- newstr ) +: right-trim-separators ( str -- newstr ) [ path-separator? ] right-trim ; +: left-trim-separators ( str -- newstr ) + [ path-separator? ] left-trim ; + : path+ ( str1 str2 -- str ) - >r trim-path-separators "/" r> - [ path-separator? ] left-trim 3append ; + >r right-trim-separators "/" r> + left-trim-separators 3append ; : stat ( path -- directory? permissions length modified ) normalize-pathname (stat) ; @@ -69,7 +72,7 @@ TUPLE: no-parent-directory path ; \ no-parent-directory construct-boa throw ; : parent-directory ( path -- parent ) - trim-path-separators { + right-trim-separators { { [ dup empty? ] [ drop "/" ] } { [ dup root-directory? ] [ ] } { [ dup [ path-separator? ] contains? not ] [ drop "." ] } @@ -90,7 +93,7 @@ TUPLE: no-parent-directory path ; "resource:" ?head [ resource-path ] when ; : make-directories ( path -- ) - normalize-pathname trim-path-separators { + normalize-pathname right-trim-separators { { [ dup "." = ] [ ] } { [ dup root-directory? ] [ ] } { [ dup empty? ] [ ] } diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index bc88661530..f8626f3370 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,7 +124,7 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; -HELP: refresh-all-error +HELP: require-all-error { $values { "vocabs" "a sequence of vocabularies" } } { $description "Throws a " { $link require-all-error } "." } { $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 6e6d1923e0..64372fe4b7 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -149,7 +149,7 @@ SYMBOL: load-help? dup modified-sources swap modified-docs ; : load-error. ( vocab error -- ) - "While loading " swap dup >vocab-link write-object ":" print + "While loading " rot dup >vocab-link write-object ":" print print-error ; TUPLE: require-all-error vocabs ; diff --git a/extra/io/windows/nt/files/files.factor b/extra/io/windows/nt/files/files.factor index 5cbcd063bd..a1c331816c 100755 --- a/extra/io/windows/nt/files/files.factor +++ b/extra/io/windows/nt/files/files.factor @@ -37,11 +37,13 @@ M: windows-nt-io root-directory? ( path -- ? ) : windows-path+ ( cwd path -- newpath ) { ! empty - { [ dup empty? ] [ "empty path" throw ] } + { [ dup empty? ] [ drop ] } + ! .. + { [ dup ".." = ] [ drop parent-directory prepend-prefix ] } ! \\\\?\\c:\\foo { [ dup unicode-prefix head? ] [ nip ] } ! ..\\foo - { [ dup "..\\" head? ] [ >r parent-directory r> 2 tail windows-path+ ] } + { [ dup "..\\" head? ] [ >r parent-directory r> 3 tail windows-path+ ] } ! .\\foo { [ dup ".\\" head? ] [ 1 tail append prepend-prefix ] } ! \\foo @@ -49,7 +51,11 @@ M: windows-nt-io root-directory? ( path -- ? ) ! c:\\foo { [ dup ?second CHAR: : = ] [ nip prepend-prefix ] } ! foo.txt - { [ t ] [ [ first CHAR: \\ = "" "\\" ? ] keep 3append prepend-prefix ] } + { [ t ] [ + >r right-trim-separators "\\" r> + left-trim-separators + 3append prepend-prefix + ] } } cond ; M: windows-nt-io normalize-pathname ( string -- string ) diff --git a/extra/io/windows/nt/nt-tests.factor b/extra/io/windows/nt/nt-tests.factor index ad409fb083..e4ebe3dd37 100755 --- a/extra/io/windows/nt/nt-tests.factor +++ b/extra/io/windows/nt/nt-tests.factor @@ -1,4 +1,5 @@ -USING: io.files kernel tools.test io.backend splitting ; +USING: io.files kernel tools.test io.backend +io.windows.nt.files splitting ; IN: temporary [ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test @@ -9,8 +10,8 @@ IN: temporary [ "Z:" ] [ "Z:\\" parent-directory ] unit-test [ "c:" ] [ "c:" parent-directory ] unit-test [ "Z:" ] [ "Z:" parent-directory ] unit-test -[ t ] [ "c:\\" trim-path-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-path-separators root-directory? ] unit-test +[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test +[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test [ f ] [ "c:\\foo" root-directory? ] unit-test [ f ] [ "." root-directory? ] unit-test [ f ] [ ".." root-directory? ] unit-test @@ -18,3 +19,18 @@ IN: temporary [ ] [ "" resource-path cd ] unit-test [ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test + +[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ + "C:\\builds\\factor\\12345\\" + "..\\log.txt" windows-path+ +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." windows-path+ +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." windows-path+ +] unit-test From 3f9e4bcf0025c03e5a1f3ad0630e8a85f9d3410a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 20:11:35 -0600 Subject: [PATCH 048/194] More efficient specializers --- core/generator/generator.factor | 5 ++- core/optimizer/backend/backend.factor | 6 +-- core/optimizer/known-words/known-words.factor | 16 +++---- core/optimizer/optimizer-docs.factor | 29 ------------- core/optimizer/optimizer.factor | 43 +------------------ .../specializers/specializers-docs.factor | 26 +++++++++++ .../specializers/specializers.factor | 41 ++++++++++++++++++ extra/benchmark/recursive/recursive.factor | 6 --- extra/math/vectors/vectors.factor | 30 ++++++------- 9 files changed, 98 insertions(+), 104 deletions(-) mode change 100644 => 100755 core/optimizer/optimizer-docs.factor mode change 100644 => 100755 core/optimizer/optimizer.factor create mode 100755 core/optimizer/specializers/specializers-docs.factor create mode 100755 core/optimizer/specializers/specializers.factor mode change 100644 => 100755 extra/benchmark/recursive/recursive.factor diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 3d66241bc3..3883fb6e35 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -3,8 +3,9 @@ USING: arrays assocs classes combinators cpu.architecture effects generator.fixup generator.registers generic hashtables inference inference.backend inference.dataflow io kernel -kernel.private layouts math namespaces optimizer prettyprint -quotations sequences system threads words vectors ; +kernel.private layouts math namespaces optimizer +optimizer.specializers prettyprint quotations sequences system +threads words vectors ; IN: generator SYMBOL: compile-queue diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index 9d75346091..e73200b861 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -4,7 +4,7 @@ USING: arrays generic assocs inference inference.class inference.dataflow inference.backend inference.state io kernel math namespaces sequences vectors words quotations hashtables combinators classes generic.math continuations optimizer.def-use -optimizer.pattern-match generic.standard ; +optimizer.pattern-match generic.standard optimizer.specializers ; IN: optimizer.backend SYMBOL: class-substitutions @@ -256,7 +256,7 @@ M: #dispatch optimize-node* tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 6 >= + dup word-def flat-length 5 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t @@ -363,7 +363,7 @@ M: #dispatch optimize-node* : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ - >r node-input-classes r> length tail* + >r node-input-classes r> specialized-length tail* [ types length 1 = ] all? ] [ 2drop f diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index 6828a0948c..5820d8f5b2 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -124,19 +124,19 @@ float-arrays combinators.private combinators ; ] each \ push-all -{ { string array } { sbuf vector } } +{ { string sbuf } { array vector } } "specializer" set-word-prop \ append -{ { string array } { string array } } +{ { string string } { array array } } "specializer" set-word-prop \ subseq -{ fixnum fixnum { string array } } +{ { fixnum fixnum string } { fixnum fixnum array } } "specializer" set-word-prop \ reverse-here -{ { string array } } +{ { string } { array } } "specializer" set-word-prop \ mismatch @@ -147,9 +147,9 @@ float-arrays combinators.private combinators ; \ >string { sbuf } "specializer" set-word-prop -\ >array { { string vector } } "specializer" set-word-prop +\ >array { { string } { vector } } "specializer" set-word-prop -\ >vector { { array vector } } "specializer" set-word-prop +\ >vector { { array } { vector } } "specializer" set-word-prop \ >sbuf { string } "specializer" set-word-prop @@ -163,6 +163,6 @@ float-arrays combinators.private combinators ; \ assoc-stack { vector } "specializer" set-word-prop -\ >le { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop -\ >be { { fixnum bignum } fixnum } "specializer" set-word-prop +\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop diff --git a/core/optimizer/optimizer-docs.factor b/core/optimizer/optimizer-docs.factor old mode 100644 new mode 100755 index ff694650bc..4be1176cda --- a/core/optimizer/optimizer-docs.factor +++ b/core/optimizer/optimizer-docs.factor @@ -2,31 +2,6 @@ USING: help.markup help.syntax quotations words math sequences ; IN: optimizer -ARTICLE: "specializers" "Word specializers" -"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." -$nl -"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is a sequence having the same number of elements as the word has inputs; each element takes one of the following forms and gives the compiler a hint about the corresponding parameter:" -{ $table - { { $snippet { $emphasis "class" } } { "a class word indicates that this parameter is expected to be an instance of the class most of the time." } } - { { $snippet "{ " { $emphasis "classes..." } " }" } { "a sequence of class words indicates that this parameter is expected to be an instance of one of these classes most of the time." } } - { { $snippet "number" } { "the " { $link number } " class word has a special behavior. It will result in a version of the word being generated for every primitive numeric type, where this parameter is assumed to have that type. A fast jump table will then determine which version is chosen at run time." } } - { { $snippet "*" } { "indicates no specialization should be performed on this parameter." } } -} -"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." -$nl -"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." -$nl -"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." -$nl -"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" -{ $code -"\\ append" -"{ { string array } { string array } }" -"\"specializer\" set-word-prop" -} -"The specialized version of a word which will be compiled by the compiler can be inspected:" -{ $subsection specialized-def } ; - ARTICLE: "optimizer" "Optimizer" "The words in the " { $vocab-link "optimizer" } " vocabulary are internal to the compiler and user code has no reason to call them." $nl @@ -43,7 +18,3 @@ HELP: optimize-1 HELP: optimize { $values { "node" "a dataflow graph" } { "newnode" "a dataflow graph" } } { $description "Continues to optimize a dataflow graph until a fixed point is reached." } ; - -HELP: specialized-def -{ $values { "word" word } { "quot" quotation } } -{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/optimizer.factor b/core/optimizer/optimizer.factor old mode 100644 new mode 100755 index 66e4ac9220..219b27197f --- a/core/optimizer/optimizer.factor +++ b/core/optimizer/optimizer.factor @@ -1,10 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays generic hashtables kernel kernel.private math -namespaces sequences vectors words strings layouts combinators -combinators.private classes optimizer.backend optimizer.def-use -optimizer.known-words optimizer.math inference.class -generic.standard ; +USING: kernel namespaces optimizer.backend optimizer.def-use +optimizer.known-words optimizer.math inference.class ; IN: optimizer : optimize-1 ( node -- newnode ? ) @@ -22,39 +19,3 @@ IN: optimizer : optimize ( node -- newnode ) optimize-1 [ optimize ] when ; - -: simple-specializer ( quot dispatch# classes -- quot ) - swap (dispatch#) [ - object add* swap [ 2array ] curry map - object method-alist>quot - ] with-variable ; - -: dispatch-specializer ( quot dispatch# symbol dispatcher -- quot ) - rot (dispatch#) [ - [ - picker % - , - get swap , - \ dispatch , - ] [ ] make - ] with-variable ; - -: tag-specializer ( quot dispatch# -- quot ) - num-tags \ tag dispatch-specializer ; - -: type-specializer ( quot dispatch# -- quot ) - num-types \ type dispatch-specializer ; - -: make-specializer ( quot dispatch# spec -- quot ) - { - { [ dup number eq? ] [ drop tag-specializer ] } - { [ dup object eq? ] [ drop type-specializer ] } - { [ dup \ * eq? ] [ 2drop ] } - { [ dup array? ] [ simple-specializer ] } - { [ t ] [ 1array simple-specializer ] } - } cond ; - -: specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - [ length ] keep [ make-specializer ] 2each - ] when* ; diff --git a/core/optimizer/specializers/specializers-docs.factor b/core/optimizer/specializers/specializers-docs.factor new file mode 100755 index 0000000000..de5d5d7a1f --- /dev/null +++ b/core/optimizer/specializers/specializers-docs.factor @@ -0,0 +1,26 @@ +IN: optimizer.specializers +USING: help.markup help.syntax sequences words quotations ; + +ARTICLE: "specializers" "Word specializers" +"The optimizer can be passed hints as to the classes of parameters a word is expected to be called with. The optimizer will then generate multiple versions of word when compiling, specialized to each class." +$nl +"Specialization hints are stored in the " { $snippet "\"specializer\"" } " word property. The value of this property is either a sequence of classes, or a sequence of sequences of classes. Each element in the sequence (or the sequence itself, in the former case) is a specialization hint." +$nl +"Specialization can help in the case where a word calls a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place." +$nl +"Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information." +$nl +"In some cases, specialization will not help at all, and can make generated code slower from the increase in code size. The compiler is capable of inferring enough static type information to generate efficient code in many cases without explicit help from the programmer. Specializers should be used as a last resort, after profiling shows that a critical loop makes a lot of repeated calls to generic words which dispatch on the same class." +$nl +"For example, the " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:" +{ $code +"\\ append" +"{ { string string } { array array } }" +"\"specializer\" set-word-prop" +} +"The specialized version of a word which will be compiled by the compiler can be inspected:" +{ $subsection specialized-def } ; + +HELP: specialized-def +{ $values { "word" word } { "quot" quotation } } +{ $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ; diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor new file mode 100755 index 0000000000..223ce18117 --- /dev/null +++ b/core/optimizer/specializers/specializers.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2006, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays generic hashtables kernel kernel.private math +namespaces sequences vectors words strings layouts combinators +combinators.private classes generic.standard assocs ; +IN: optimizer.specializers + +: (make-specializer) ( class picker -- quot ) + swap "predicate" word-prop append ; + +: make-specializer ( classes -- quot ) + dup length + [ (picker) 2array ] 2map + [ drop object eq? not ] assoc-subset + dup empty? [ drop [ t ] ] [ + [ (make-specializer) ] { } assoc>map + unclip [ swap [ f ] \ if 3array append [ ] like ] reduce + ] if ; + +: tag-specializer ( quot -- newquot ) + [ + [ dup tag ] % + num-tags get swap , + \ dispatch , + ] [ ] make ; + +: specialized-def ( word -- quot ) + dup word-def swap "specializer" word-prop [ + dup { number } = [ + drop tag-specializer + ] [ + dup [ array? ] all? [ 1array ] unless [ + [ make-specializer ] keep + [ declare ] curry pick append + ] { } map>assoc + alist>quot + ] if + ] when* ; + +: specialized-length ( specializer -- n ) + dup [ array? ] all? [ first ] when length ; diff --git a/extra/benchmark/recursive/recursive.factor b/extra/benchmark/recursive/recursive.factor old mode 100644 new mode 100755 index 79c6dfbaca..6e3c201cf0 --- a/extra/benchmark/recursive/recursive.factor +++ b/extra/benchmark/recursive/recursive.factor @@ -4,8 +4,6 @@ USING: math kernel hints prettyprint io ; : fib ( m -- n ) dup 2 < [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ; -! HINTS: fib { fixnum float } ; -! : ack ( m n -- x ) over zero? [ nip 1+ @@ -17,8 +15,6 @@ USING: math kernel hints prettyprint io ; ] if ] if ; -! HINTS: ack fixnum fixnum ; - : tak ( x y z -- t ) pick pick swap < [ [ rot 1- -rot tak ] 3keep @@ -29,8 +25,6 @@ USING: math kernel hints prettyprint io ; 2nip ] if ; -! HINTS: tak { fixnum float } { fixnum float } { fixnum float } ; - : recursive ( n -- ) 3 over ack . flush dup 27.0 + fib . flush diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index b2a8995df0..2be9cf7f58 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -27,20 +27,20 @@ IN: math.vectors : set-axis ( u v axis -- w ) dup length [ >r zero? pick pick ? r> swap nth ] 2map 2nip ; -HINTS: vneg { float-array array } ; -HINTS: norm-sq { float-array array } ; -HINTS: norm { float-array array } ; -HINTS: normalize { float-array array } ; +HINTS: vneg { float-array } { array } ; +HINTS: norm-sq { float-array } { array } ; +HINTS: norm { float-array } { array } ; +HINTS: normalize { float-array } { array } ; -HINTS: n*v * { float-array array } ; -HINTS: v*n { float-array array } * ; -HINTS: n/v * { float-array array } ; -HINTS: v/n { float-array array } * ; +HINTS: n*v { object float-array } { object array } ; +HINTS: v*n { float-array object } { array object } ; +HINTS: n/v { object float-array } { array } ; +HINTS: v/n { float-array object } { array object } ; -HINTS: v+ { float-array array } { float-array array } ; -HINTS: v- { float-array array } { float-array array } ; -HINTS: v* { float-array array } { float-array array } ; -HINTS: v/ { float-array array } { float-array array } ; -HINTS: vmax { float-array array } { float-array array } ; -HINTS: vmin { float-array array } { float-array array } ; -HINTS: v. { float-array array } { float-array array } ; +HINTS: v+ { float-array float-array } { array array } ; +HINTS: v- { float-array float-array } { array array } ; +HINTS: v* { float-array float-array } { array array } ; +HINTS: v/ { float-array float-array } { array array } ; +HINTS: vmax { float-array float-array } { array array } ; +HINTS: vmin { float-array float-array } { array array } ; +HINTS: v. { float-array float-array } { array array } ; From 95651daef07cea2485add25be8791f957b67dc86 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 5 Feb 2008 22:36:10 -0600 Subject: [PATCH 049/194] Faster parser --- core/parser/parser-docs.factor | 6 ---- core/parser/parser.factor | 47 +++++++++++++++++--------------- extra/multiline/multiline.factor | 4 +-- 3 files changed, 27 insertions(+), 30 deletions(-) mode change 100644 => 100755 extra/multiline/multiline.factor diff --git a/core/parser/parser-docs.factor b/core/parser/parser-docs.factor index d8d6c9b7bc..ae38925c68 100755 --- a/core/parser/parser-docs.factor +++ b/core/parser/parser-docs.factor @@ -136,8 +136,6 @@ ARTICLE: "parser-lexer" "The lexer" { $subsection } "A word to test of the end of input has been reached:" { $subsection still-parsing? } -"A word to get the text of the current line:" -{ $subsection line-text } "A word to advance the lexer to the next line:" { $subsection next-line } "Two generic words to override the lexer's token boundary detection:" @@ -222,10 +220,6 @@ HELP: { $values { "msg" "an error" } { "error" parse-error } } { $description "Creates a new " { $link parse-error } ", filling in the location information from the current " { $link lexer } "." } ; -HELP: line-text -{ $values { "lexer" lexer } { "str" string } } -{ $description "Outputs the text of the line being parsed." } ; - HELP: skip { $values { "i" "a starting index" } { "seq" "a sequence" } { "quot" "a quotation with stack effect " { $snippet "( elt -- ? )" } } { "n" integer } } { $description "Variant of " { $link find* } " that outputs the length of the sequence instead of " { $link f } " if no elements satisfy the predicate." } ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 6d7ad47843..59d18dc734 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -8,12 +8,17 @@ io.files io.streams.string io.streams.lines vocabs source-files classes hashtables compiler.errors compiler.units ; IN: parser -TUPLE: lexer text line column ; +TUPLE: lexer text line line-text line-length column ; -: ( text -- lexer ) 1 0 lexer construct-boa ; +: next-line ( lexer -- ) + 0 over set-lexer-column + dup lexer-line over lexer-text ?nth over set-lexer-line-text + dup lexer-line-text length over set-lexer-line-length + dup lexer-line 1+ swap set-lexer-line ; -: line-text ( lexer -- str ) - dup lexer-line 1- swap lexer-text ?nth ; +: ( text -- lexer ) + 0 { set-lexer-text set-lexer-line } lexer construct + dup lexer-text empty? [ dup next-line ] unless ; : location ( -- loc ) file get lexer get lexer-line 2dup and @@ -50,18 +55,14 @@ t parser-notes set-global "Note: " write dup print ] when drop ; -: next-line ( lexer -- ) - 0 over set-lexer-column - dup lexer-line 1+ swap set-lexer-line ; - : skip ( i seq ? -- n ) over >r [ swap CHAR: \s eq? xor ] curry find* drop - [ r> drop ] [ r> length ] if* ; inline + [ r> drop ] [ r> length ] if* ; : change-column ( lexer quot -- ) swap - [ dup lexer-column swap line-text rot call ] keep + [ dup lexer-column swap lexer-line-text rot call ] keep set-lexer-column ; inline GENERIC: skip-blank ( lexer -- ) @@ -73,20 +74,20 @@ GENERIC: skip-word ( lexer -- ) M: lexer skip-word ( lexer -- ) [ - 2dup nth CHAR: " = [ drop 1+ ] [ f skip ] if + 2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if ] change-column ; : still-parsing? ( lexer -- ? ) dup lexer-line swap lexer-text length <= ; : still-parsing-line? ( lexer -- ? ) - dup lexer-column swap line-text length < ; + dup lexer-column swap lexer-line-length < ; : (parse-token) ( lexer -- str ) [ lexer-column ] keep [ skip-word ] keep [ lexer-column ] keep - line-text subseq ; + lexer-line-text subseq ; : parse-token ( lexer -- str/f ) dup still-parsing? [ @@ -139,9 +140,8 @@ TUPLE: parse-error file line col text ; : ( msg -- error ) file get - lexer get lexer-line - lexer get lexer-column - lexer get line-text + lexer get + { lexer-line lexer-column lexer-line-text } get-slots parse-error construct-boa [ set-delegate ] keep ; @@ -239,22 +239,25 @@ M: no-word summary word-restarts throw-restarts dup word-vocabulary (use+) ; -: check-forward ( str word -- word ) +: check-forward ( str word -- word/f ) dup forward-reference? [ drop - dup use get + use get [ at ] with map [ ] subset [ forward-reference? not ] find nip - [ ] [ no-word ] ?if ] [ nip ] if ; -: search ( str -- word ) - dup use get assoc-stack [ check-forward ] [ no-word ] if* ; +: search ( str -- word/f ) + dup use get assoc-stack check-forward ; : scan-word ( -- word/number/f ) - scan dup [ dup string>number [ ] [ search ] ?if ] when ; + scan dup [ + dup search [ ] [ + dup string>number [ ] [ no-word ] ?if + ] ?if + ] when ; TUPLE: staging-violation word ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor old mode 100644 new mode 100755 index 7f831e5351..9a6d052b60 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -4,7 +4,7 @@ USING: namespaces parser kernel sequences words quotations math ; IN: multiline : next-line-text ( -- str ) - lexer get dup next-line line-text ; + lexer get dup next-line lexer-line-text ; : (parse-here) ( -- ) next-line-text dup ";" = @@ -19,7 +19,7 @@ IN: multiline parse-here 1quotation define ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) - lexer get line-text 2dup start + lexer get lexer-line-text 2dup start [ rot dupd >r >r swap subseq % r> r> length + ] [ rot tail % "\n" % 0 lexer get next-line swap (parse-multiline-string) From ac0aa6b3b20354042f1b7dd74e596768391d2a5d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 22:49:36 -0600 Subject: [PATCH 050/194] do a better merge --- Makefile | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/Makefile b/Makefile index 06d0b28ccf..05a185f643 100755 --- a/Makefile +++ b/Makefile @@ -126,14 +126,10 @@ solaris-x86-64: winnt-x86-32: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 -<<<<<<< HEAD:Makefile -windows-nt-x86-64: +winnt-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64 -windows-ce-arm: -======= wince-arm: ->>>>>>> 1eda70f1ad1f0d744ed846ce8c975a1cd4b28fb6:Makefile $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm macosx.app: factor From 3bbf622ff4795148fc10e5f9611029550a1c37db Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 22:51:09 -0600 Subject: [PATCH 051/194] update factor.sh for new Makefile renaming --- misc/factor.sh | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/misc/factor.sh b/misc/factor.sh index d1ef738cd9..903038a964 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -99,9 +99,9 @@ find_os() { uname_s=`uname -s` check_ret uname case $uname_s in - CYGWIN_NT-5.2-WOW64) OS=windows-nt;; - *CYGWIN_NT*) OS=windows-nt;; - *CYGWIN*) OS=windows-nt;; + CYGWIN_NT-5.2-WOW64) OS=winnt;; + *CYGWIN_NT*) OS=winnt;; + *CYGWIN*) OS=winnt;; *darwin*) OS=macosx;; *Darwin*) OS=macosx;; *linux*) OS=linux;; @@ -139,7 +139,7 @@ find_word_size() { set_factor_binary() { case $OS in - windows-nt) FACTOR_BINARY=factor-nt;; + winnt) FACTOR_BINARY=factor-nt;; macosx) FACTOR_BINARY=./Factor.app/Contents/MacOS/factor;; *) FACTOR_BINARY=factor;; esac @@ -227,7 +227,7 @@ get_boot_image() { } maybe_download_dlls() { - if [[ $OS == windows-nt ]] ; then + if [[ $OS == winnt ]] ; then wget http://factorcode.org/dlls/freetype6.dll check_ret wget wget http://factorcode.org/dlls/zlib1.dll From 4439e394cca6be96a06d85a9532795bd052f8f1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 23:04:31 -0600 Subject: [PATCH 052/194] fix getcwd --- extra/io/unix/files/files.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index a70f7339d2..101114ffb2 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,7 +6,7 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup getcwd + MAXPATHLEN dup swap getcwd [ alien>char-string ] [ (io-error) ] if* ; M: unix-io cd From e3e2cc7e0d647b628b245372a7c178ed492f42c4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Tue, 5 Feb 2008 23:09:33 -0600 Subject: [PATCH 053/194] Add builder.load-everything --- extra/builder/builder.factor | 57 ++++++++++++------- .../load-everything/load-everything.factor | 23 ++++++++ 2 files changed, 58 insertions(+), 22 deletions(-) create mode 100644 extra/builder/load-everything/load-everything.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 832b89a7dc..375023cb5e 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -33,19 +33,19 @@ SYMBOL: builder-recipients ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; +: target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -: target ( -- target ) - { { [ os "windows" = ] [ "windows-nt-x86-32" ] } - { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } - cond ; +! : target ( -- target ) +! { { [ os "windows" = ] [ "windows-nt-x86-32" ] } +! { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } +! cond ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : factor-binary ( -- name ) os { { "macosx" [ "./Factor.app/Contents/MacOS/factor" ] } - { "windows" [ "./factor-nt.exe" ] } + { "winnt" [ "./factor-nt.exe" ] } [ drop "./factor" ] } case ; @@ -61,7 +61,13 @@ VAR: stamp "/builds/factor" cd - { "git" "pull" "--no-summary" "git://factorcode.org/git/factor.git" } + { + "git" + "pull" + "--no-summary" + "git://factorcode.org/git/factor.git" + "master" + } run-process process-status 0 = [ ] @@ -74,7 +80,7 @@ VAR: stamp "/builds/" stamp> append make-directory "/builds/" stamp> append cd - { "git" "clone" "/builds/factor" } run-process drop + { "git" "clone" "../factor" } run-process drop "factor" cd @@ -121,20 +127,27 @@ VAR: stamp "builder: bootstrap" throw ] if - `{ - { +arguments+ - { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } - { +stdout+ "../load-everything-log" } - { +stderr+ +stdout+ } - } - >hashtable [ run-process process-status ] benchmark nip - "../load-everything-time" [ . ] with-stream - 0 = - [ ] - [ - "builder: load-everything" "../load-everything-log" email-file - "builder: load-everything" throw - ] if ; +! `{ +! { +arguments+ +! { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } +! { +stdout+ "../load-everything-log" } +! { +stderr+ +stdout+ } +! } +! >hashtable [ run-process process-status ] benchmark nip +! "../load-everything-time" [ . ] with-stream +! 0 = +! [ ] +! [ +! "builder: load-everything" "../load-everything-log" email-file +! "builder: load-everything" throw +! ] if ; + + `{ ,[ factor-binary ] "-run=builder.load-everything" } run-process drop + "../load-everything-log" exists? + [ "builder: load-everything" "../load-everything-log" email-file ] + when + + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/load-everything/load-everything.factor b/extra/builder/load-everything/load-everything.factor new file mode 100644 index 0000000000..12007f214b --- /dev/null +++ b/extra/builder/load-everything/load-everything.factor @@ -0,0 +1,23 @@ + +USING: kernel continuations io io.files prettyprint vocabs.loader + tools.time tools.browser ; + +IN: builder.load-everything + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: runtime ( quot -- time ) benchmark nip ; + +: log-runtime ( quot file -- ) + >r runtime r> [ . ] with-stream ; + +: log-object ( object file -- ) [ . ] with-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: do-load-everything ( -- ) + [ [ load-everything ] catch ] "../load-everything-time" log-runtime + [ require-all-error-vocabs "../load-everything-log" log-object ] + when ; + +MAIN: do-load-everything \ No newline at end of file From 537d94566005c51b29fe358f79d2709b33c4b392 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 5 Feb 2008 23:14:10 -0600 Subject: [PATCH 054/194] fix getcwd --- extra/io/unix/files/files.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index 101114ffb2..3bf0e3f897 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -6,8 +6,8 @@ alien ; IN: io.unix.files M: unix-io cwd - MAXPATHLEN dup swap getcwd - [ alien>char-string ] [ (io-error) ] if* ; + MAXPATHLEN dup swap + getcwd [ (io-error) ] unless* ; M: unix-io cd chdir io-error ; From d27ae067089d7d196cc9634fd87940e0717ca236 Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Wed, 6 Feb 2008 00:53:18 -0500 Subject: [PATCH 055/194] Solution to Project Euler problem 44 --- extra/project-euler/044/044.factor | 50 ++++++++++++++++++++++++ extra/project-euler/project-euler.factor | 7 ++-- 2 files changed, 54 insertions(+), 3 deletions(-) create mode 100644 extra/project-euler/044/044.factor diff --git a/extra/project-euler/044/044.factor b/extra/project-euler/044/044.factor new file mode 100644 index 0000000000..6369cb5372 --- /dev/null +++ b/extra/project-euler/044/044.factor @@ -0,0 +1,50 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.functions math.ranges project-euler.common sequences ; +IN: project-euler.044 + +! http://projecteuler.net/index.php?section=problems&id=44 + +! DESCRIPTION +! ----------- + +! Pentagonal numbers are generated by the formula, Pn=n(3n−1)/2. The first ten +! pentagonal numbers are: + +! 1, 5, 12, 22, 35, 51, 70, 92, 117, 145, ... + +! It can be seen that P4 + P7 = 22 + 70 = 92 = P8. However, their difference, +! 70 − 22 = 48, is not pentagonal. + +! Find the pair of pentagonal numbers, Pj and Pk, for which their sum and +! difference is pentagonal and D = |Pk − Pj| is minimised; what is the value of D? + + +! SOLUTION +! -------- + +! Brute force using a cartesian product and an arbitrarily chosen limit. + + [ 24 * 1+ sqrt 1+ 6 / 1 mod zero? ] [ drop f ] if ; + +: sum-and-diff? ( m n -- ? ) + 2dup + -rot - [ pentagonal? ] 2apply and ; + +PRIVATE> + +: euler044 ( -- answer ) + 2500 [1,b] [ nth-pentagonal ] map dup cartesian-product + [ first2 sum-and-diff? ] subset [ first2 - abs ] map infimum ; + +! [ euler044 ] 10 ave-time +! 8924 ms run / 2872 ms GC ave time - 10 trials + +! TODO: this solution is ugly and not very efficient...find a better algorithm + +MAIN: euler044 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index ef28cf8778..36a9069d77 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -12,9 +12,10 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 project-euler.037 project-euler.038 project-euler.039 project-euler.040 - project-euler.041 project-euler.042 project-euler.043 project-euler.048 - project-euler.052 project-euler.067 project-euler.075 project-euler.097 - project-euler.134 project-euler.169 project-euler.173 project-euler.175 ; + project-euler.041 project-euler.042 project-euler.043 project-euler.044 + project-euler.048 project-euler.052 project-euler.067 project-euler.075 + project-euler.097 project-euler.134 project-euler.169 project-euler.173 + project-euler.175 ; IN: project-euler Date: Wed, 6 Feb 2008 04:26:13 -0600 Subject: [PATCH 056/194] Add builder.test --- extra/builder/builder.factor | 46 +++++++++++++--------------------- extra/builder/test/test.factor | 33 ++++++++++++++++++++++++ 2 files changed, 51 insertions(+), 28 deletions(-) create mode 100644 extra/builder/test/test.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 375023cb5e..2acdbc3294 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -8,6 +8,15 @@ IN: builder ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: runtime ( quot -- time ) benchmark nip ; + +: log-runtime ( quot file -- ) + >r runtime r> [ . ] with-stream ; + +: log-object ( object file -- ) [ . ] with-stream ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + : datestamp ( -- string ) now `{ ,[ dup timestamp-year ] ,[ dup timestamp-month ] @@ -35,11 +44,6 @@ SYMBOL: builder-recipients : target ( -- target ) `{ ,[ os ] %[ cpu "." split ] } "-" join ; -! : target ( -- target ) -! { { [ os "windows" = ] [ "windows-nt-x86-32" ] } -! { [ t ] [ `{ ,[ os ] %[ cpu "." split ] } "-" join ] } } -! cond ; - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : factor-binary ( -- name ) @@ -84,10 +88,8 @@ VAR: stamp "factor" cd - { "git" "show" } - [ readln ] with-stream - " " split second - "../git-id" [ print ] with-stream + { "git" "show" } [ readln ] with-stream " " split second + "../git-id" log-object { "make" "clean" } run-process drop @@ -117,9 +119,7 @@ VAR: stamp { +stdout+ "../boot-log" } { +stderr+ +stdout+ } } - >hashtable - [ run-process process-status ] - benchmark nip "../boot-time" [ . ] with-stream + >hashtable [ run-process ] "../boot-time" log-runtime process-status 0 = [ ] [ @@ -127,26 +127,16 @@ VAR: stamp "builder: bootstrap" throw ] if -! `{ -! { +arguments+ -! { ,[ factor-binary ] "-e=USE: tools.browser load-everything" } } -! { +stdout+ "../load-everything-log" } -! { +stderr+ +stdout+ } -! } -! >hashtable [ run-process process-status ] benchmark nip -! "../load-everything-time" [ . ] with-stream -! 0 = -! [ ] -! [ -! "builder: load-everything" "../load-everything-log" email-file -! "builder: load-everything" throw -! ] if ; - - `{ ,[ factor-binary ] "-run=builder.load-everything" } run-process drop + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop + "../load-everything-log" exists? [ "builder: load-everything" "../load-everything-log" email-file ] when + "../failing-tests" exists? + [ "builder: failing tests" "../failing-tests" email-file ] + when + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor new file mode 100644 index 0000000000..ed75e99527 --- /dev/null +++ b/extra/builder/test/test.factor @@ -0,0 +1,33 @@ + +USING: kernel sequences assocs builder continuations vocabs vocabs.loader + io + io.files + tools.browser + tools.test ; + +IN: builder.test + +: do-load ( -- ) + [ [ load-everything ] catch ] "../load-everything-time" log-runtime + [ require-all-error-vocabs "../load-everything-log" log-object ] + when* ; + +: do-tests ( -- ) + "" child-vocabs + [ vocab-source-loaded? ] subset + [ vocab-tests-path ] map + [ dup [ ?resource-path exists? ] when ] subset + [ dup run-test ] { } map>assoc + [ second empty? not ] subset + dup empty? + [ drop ] + [ + "../failing-tests" + [ [ nl failures. ] assoc-each ] + with-stream + ] + if ; + +: do-all ( -- ) do-load do-tests ; + +MAIN: do-all \ No newline at end of file From a5c69dae631af981fdc598828c44ecdc12423bbe Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Feb 2008 06:10:55 -0600 Subject: [PATCH 057/194] update builder.test --- .../load-everything/load-everything.factor | 23 ------------------- extra/builder/test/test.factor | 9 +++++--- 2 files changed, 6 insertions(+), 26 deletions(-) delete mode 100644 extra/builder/load-everything/load-everything.factor diff --git a/extra/builder/load-everything/load-everything.factor b/extra/builder/load-everything/load-everything.factor deleted file mode 100644 index 12007f214b..0000000000 --- a/extra/builder/load-everything/load-everything.factor +++ /dev/null @@ -1,23 +0,0 @@ - -USING: kernel continuations io io.files prettyprint vocabs.loader - tools.time tools.browser ; - -IN: builder.load-everything - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: runtime ( quot -- time ) benchmark nip ; - -: log-runtime ( quot file -- ) - >r runtime r> [ . ] with-stream ; - -: log-object ( object file -- ) [ . ] with-stream ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: do-load-everything ( -- ) - [ [ load-everything ] catch ] "../load-everything-time" log-runtime - [ require-all-error-vocabs "../load-everything-log" log-object ] - when ; - -MAIN: do-load-everything \ No newline at end of file diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index ed75e99527..fb9c62e2aa 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -8,9 +8,12 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test : do-load ( -- ) - [ [ load-everything ] catch ] "../load-everything-time" log-runtime - [ require-all-error-vocabs "../load-everything-log" log-object ] - when* ; + [ + [ load-everything ] + [ require-all-error-vocabs "../load-everything-log" log-object ] + recover + ] + "../load-everything-time" log-runtime ; : do-tests ( -- ) "" child-vocabs From 548e6dce4774507eb289968268438c255028c054 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:09:42 -0600 Subject: [PATCH 058/194] Fixing crossreferencing --- core/compiler/test/redefine.factor | 37 +++++++++++++++++++++++++++++ core/generic/generic-tests.factor | 37 +++++++++++++++++++++++++++++ core/generic/generic.factor | 7 +++++- core/words/words.factor | 29 ++++++++++------------ extra/help/handbook/handbook.factor | 2 ++ 5 files changed, 94 insertions(+), 18 deletions(-) diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 01dd27f8be..9bcdcdfcde 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -250,3 +250,40 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test [ 2 1 ] [ defer-redefine-test-2 ] unit-test + +! Cross-referencing issue +: compiled-xref-a ; + +: compiled-xref-c ; inline + +GENERIC: compiled-xref-b ( a -- b ) + +TUPLE: c-1 ; + +M: c-1 compiled-xref-b compiled-xref-a compiled-xref-c ; + +TUPLE: c-2 ; + +M: c-2 compiled-xref-b drop 3 ; + +[ t ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + [ + \ compiled-xref-a forget + ] with-compilation-unit +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test + +[ ] [ + "IN: temporary : compiled-xref-c ; FORGET: { c-2 compiled-xref-b }" eval +] unit-test + +[ f ] [ + \ compiled-xref-a compiled-crossref get key? +] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index f1e1ebd6d2..4de05aafd0 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -203,3 +203,40 @@ TUPLE: redefinition-test-tuple ; redefinition-test-generic , ] { } make all-equal? ] unit-test + +! Issues with forget +GENERIC: generic-forget-test-1 + +M: integer generic-forget-test-1 / ; + +[ t ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +[ ] [ + [ \ generic-forget-test-1 forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ / usage [ word? ] subset + [ word-name "generic-forget-test-1/integer" = ] contains? +] unit-test + +GENERIC: generic-forget-test-2 + +M: sequence generic-forget-test-2 = ; + +[ t ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test + +[ ] [ + [ { sequence generic-forget-test-2 } forget ] with-compilation-unit +] unit-test + +[ f ] [ + \ = usage [ word? ] subset + [ word-name "generic-forget-test-2/sequence" = ] contains? +] unit-test diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 453d72effb..53f47c09d5 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -102,7 +102,9 @@ M: method-spec definition first2 method dup [ method-def ] when ; : forget-method ( class generic -- ) - check-method [ delete-at ] with-methods ; + check-method + [ delete-at* ] with-methods + [ method-word forget ] [ drop ] if ; M: method-spec forget* first2 forget-method ; @@ -145,5 +147,8 @@ M: generic subwords swap "default-method" word-prop add [ method-word ] map ; +M: generic forget-word + dup subwords [ forget-word ] each (forget-word) ; + : xref-generics ( -- ) all-words [ subwords [ xref ] each ] each ; diff --git a/core/words/words.factor b/core/words/words.factor index 93b1185335..c2118598af 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -71,7 +71,9 @@ GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; -M: interned (quot-uses) dupd set-at ; +M: word (quot-uses) + >r dup "forgotten" word-prop + [ r> 2drop ] [ dup r> set-at ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -194,24 +196,17 @@ M: word where "loc" word-prop ; M: word set-where swap "loc" set-word-prop ; -GENERIC: (forget-word) ( word -- ) +GENERIC: forget-word ( word -- ) -M: interned (forget-word) - dup word-name swap word-vocabulary vocab-words delete-at ; +: (forget-word) ( word -- ) + dup "forgotten" word-prop [ + dup delete-xref + dup delete-compiled-xref + dup word-name over word-vocabulary vocab-words delete-at + dup t "forgotten" set-word-prop + ] unless drop ; -M: word (forget-word) - drop ; - -: rename-word ( word newname newvocab -- ) - pick (forget-word) - pick set-word-vocabulary - over set-word-name - reveal ; - -: forget-word ( word -- ) - dup delete-xref - dup delete-compiled-xref - (forget-word) ; +M: word forget-word (forget-word) ; M: word forget* forget-word ; diff --git a/extra/help/handbook/handbook.factor b/extra/help/handbook/handbook.factor index 81e4bea7b3..d6b4ec7ffe 100755 --- a/extra/help/handbook/handbook.factor +++ b/extra/help/handbook/handbook.factor @@ -32,6 +32,8 @@ $nl { { $snippet "with-" { $emphasis "foo" } } { "performs some kind of initialization and cleanup related to " { $snippet "foo" } ", usually in a new dynamic scope" } { $links with-scope with-stream } } { { $snippet "$" { $emphasis "foo" } } { "help markup" } { $links $heading $emphasis } } } +{ $heading "Stack effect conventions" } +"Stack effect conventions are documented in " { $link "effect-declaration" } "." { $heading "Glossary of terms" } "Common terminology and abbreviations used throughout Factor and its documentation:" { $table From 38b4f67b70d7cbe007fdb525dc8931edae8bd6b7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:44:13 -0600 Subject: [PATCH 059/194] Save bootstrap time in a global variable --- core/bootstrap/stage2.factor | 79 +++++++++++++++++++++++------------- 1 file changed, 51 insertions(+), 28 deletions(-) diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 1a9bdd599a..9dd56c6524 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -8,25 +8,63 @@ definitions assocs compiler.errors compiler.units math.parser generic ; IN: bootstrap.stage2 +SYMBOL: bootstrap-time + +: default-image-name ( -- string ) + vm file-name windows? [ "." split1 drop ] when + ".image" append ; + +: do-crossref ( -- ) + "Cross-referencing..." print flush + H{ } clone crossref set-global + xref-words + xref-generics + xref-sources ; + +: load-components ( -- ) + "exclude" "include" + [ get-global " " split [ empty? not ] subset ] 2apply + seq-diff + [ "bootstrap." swap append require ] each ; + +: compile-remaining ( -- ) + "Compiling remaining words..." print flush + vocabs [ + words "compile" "compiler" lookup execute + ] each ; + +: count-words ( pred -- ) + all-words swap subset length number>string write ; + +: print-report ( time -- ) + 1000 /i + 60 /mod swap + "Bootstrap completed in " write number>string write + " minutes and " write number>string write " seconds." print + + [ compiled? ] count-words " compiled words" print + [ symbol? ] count-words " symbol words" print + [ ] count-words " words total" print + + "Bootstrapping is complete." print + "Now, you can run Factor:" print + vm write " -i=" write "output-image" get print flush ; + ! Wrap everything in a catch which starts a listener so ! you can see what went wrong, instead of dealing with a ! fep [ - vm file-name windows? [ "." split1 drop ] when - ".image" append "output-image" set-global + ! We time bootstrap + millis >r + + default-image-name "output-image" set-global "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line - "-no-crossref" cli-args member? [ - "Cross-referencing..." print flush - H{ } clone crossref set-global - xref-words - xref-generics - xref-sources - ] unless + "-no-crossref" cli-args member? [ do-crossref ] unless ! Set dll paths wince? [ "windows.ce" require ] when @@ -40,19 +78,12 @@ IN: bootstrap.stage2 ] if [ - "exclude" "include" - [ get-global " " split [ empty? not ] subset ] 2apply - seq-diff - [ "bootstrap." swap append require ] each + load-components run-bootstrap-init - "Compiling remaining words..." print flush - "bootstrap.compiler" vocab [ - vocabs [ - words "compile" "compiler" lookup execute - ] each + compile-remaining ] when ] with-compiler-errors :errors @@ -74,16 +105,8 @@ IN: bootstrap.stage2 ] [ print-error 1 exit ] recover ] set-boot-quot - : count-words ( pred -- ) - all-words swap subset length number>string write ; - - [ compiled? ] count-words " compiled words" print - [ symbol? ] count-words " symbol words" print - [ ] count-words " words total" print - - "Bootstrapping is complete." print - "Now, you can run Factor:" print - vm write " -i=" write "output-image" get print flush + millis r> - dup bootstrap-time set-global + print-report "output-image" get resource-path save-image-and-exit ] if From d9338b1cd26a519d00fee2bbab7cebdcf888ecb0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 12:47:15 -0600 Subject: [PATCH 060/194] Remove interned predicate class --- core/classes/classes-tests.factor | 4 +++- core/compiler/test/redefine.factor | 4 +--- core/source-files/source-files.factor | 2 +- core/tuples/tuples-tests.factor | 2 +- core/vocabs/vocabs-docs.factor | 2 +- core/words/words-docs.factor | 16 +--------------- core/words/words-tests.factor | 11 +---------- core/words/words.factor | 21 ++++++++++++--------- 8 files changed, 21 insertions(+), 41 deletions(-) mode change 100644 => 100755 core/vocabs/vocabs-docs.factor diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index 854e6add5a..efff0db5d1 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -172,7 +172,9 @@ UNION: forget-class-bug-2 forget-class-bug-1 dll ; FORGET: forget-class-bug-1 FORGET: forget-class-bug-2 -[ t ] [ integer dll class-or interned? ] unit-test +[ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test + +[ f ] [ forget-class-bug-2 typemap get values [ memq? ] with contains? ] unit-test DEFER: mixin-forget-test-g diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 9bcdcdfcde..5d07e764d6 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -92,8 +92,6 @@ DEFER: x-4 [ t ] [ \ x-3 "compiled-uses" word-prop >boolean ] unit-test -[ t ] [ \ x-3 "compiled-uses" word-prop [ drop interned? ] assoc-all? ] unit-test - DEFER: g-test-1 DEFER: g-test-3 @@ -237,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ t ] [ \ ax compiled-usage [ drop interned? ] assoc-all? ] unit-test +[ f ] [ \ bx \ ax compiled-usage contains? ] unit-test DEFER: defer-redefine-test-2 diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 64ae2e376e..7ddf6f02c0 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -38,7 +38,7 @@ uses definitions ; : (xref-source) ( source-file -- pathname uses ) dup source-file-path swap source-file-uses - [ interned? ] subset ; + [ crossref? ] subset ; : xref-source ( source-file -- ) (xref-source) crossref get add-vertex ; diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index edd2387645..627ee5562f 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma interned? ] unit-test + [ f ] [ \ yo-momma crossref ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/vocabs/vocabs-docs.factor b/core/vocabs/vocabs-docs.factor old mode 100644 new mode 100755 index cb2cabb369..f16a33f0d5 --- a/core/vocabs/vocabs-docs.factor +++ b/core/vocabs/vocabs-docs.factor @@ -76,7 +76,7 @@ HELP: all-words HELP: forget-vocab { $values { "vocab" string } } -{ $description "Removes a vocabulary. All words in the vocabulary become uninterned." } +{ $description "Removes a vocabulary. All words in the vocabulary are forgotten." } { $notes "This word must be called from inside " { $link with-compilation-unit } "." } ; HELP: load-vocab-hook diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 24e81c70a6..62848e46b2 100755 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -14,9 +14,7 @@ $nl { $subsection lookup } "Words can output their name and vocabulary:" { $subsection word-name } -{ $subsection word-vocabulary } -"Testing if a word object is part of a vocabulary:" -{ $subsection interned? } ; +{ $subsection word-vocabulary } ; ARTICLE: "uninterned-words" "Uninterned words" "A word that is not a member of any vocabulary is said to be " { $emphasis "uninterned" } "." @@ -369,18 +367,6 @@ HELP: delimiter? { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } { $notes "Outputs " { $link f } " if the object is not a word." } ; -HELP: interned -{ $class-description "The class of words defined in the " { $link dictionary } "." } -{ $examples - { $example "\\ + interned? ." "t" } - { $example "gensym interned? ." "f" } -} ; - -HELP: rename-word -{ $values { "word" word } { "newname" string } { "newvocab" string } } -{ $description "Changes the name and vocabulary of a word, and adds it to its new vocabulary." } -{ $side-effects "word" } ; - HELP: make-flushable { $values { "word" word } } { $description "Declares a word as " { $link POSTPONE: flushable } "." } diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 35a2421e71..92f5284c49 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -54,22 +54,14 @@ GENERIC: testing [ f ] [ \ testing generic? ] unit-test -[ f ] [ gensym interned? ] unit-test - : forgotten ; : another-forgotten ; -[ f ] [ \ forgotten interned? ] unit-test - FORGET: forgotten -[ f ] [ \ another-forgotten interned? ] unit-test - FORGET: another-forgotten : another-forgotten ; -[ t ] [ \ + interned? ] unit-test - ! I forgot remove-crossref calls! : fee ; : foe fee ; @@ -87,8 +79,7 @@ FORGET: foe ] unit-test [ t ] [ - \ * usage [ word? ] subset - [ dup interned? swap method-body? or ] all? + \ * usage [ word? ] subset [ crossref? ] all? ] unit-test DEFER: calls-a-gensym diff --git a/core/words/words.factor b/core/words/words.factor index c2118598af..f628d68bee 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -IN: words USING: arrays definitions graphs assocs kernel kernel.private slots.private math namespaces sequences strings vectors sbufs quotations assocs hashtables sorting math.parser words.private -vocabs ; +vocabs combinators ; +IN: words : word ( -- word ) \ word get-global ; @@ -65,15 +65,20 @@ SYMBOL: bootstrapping? : bootstrap-word ( word -- target ) [ target-word ] [ ] if-bootstrapping ; -PREDICATE: word interned dup target-word eq? ; +: crossref? ( word -- ? ) + { + { [ dup "forgotten" word-prop ] [ f ] } + { [ dup "method" word-prop ] [ t ] } + { [ dup word-vocabulary ] [ t ] } + { [ t ] [ f ] } + } cond nip ; GENERIC# (quot-uses) 1 ( obj assoc -- ) M: object (quot-uses) 2drop ; M: word (quot-uses) - >r dup "forgotten" word-prop - [ r> 2drop ] [ dup r> set-at ] if ; + >r dup crossref? [ dup r> set-at ] [ r> 2drop ] if ; : seq-uses ( seq assoc -- ) [ (quot-uses) ] curry each ; @@ -94,6 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) + [ crossref? ] subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; @@ -118,9 +124,6 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; -: crossref? ( word -- ? ) - dup word-vocabulary swap "method" word-prop or ; - : define ( word def -- ) [ ] like over unxref From 8a4db990297699eb69f1e5c105230fa75314dc54 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:15:15 -0600 Subject: [PATCH 061/194] Improved tools.test --- extra/tools/test/test.factor | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2a26c8639e..aa994e91d2 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,7 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units ; +vocabs.loader source-files compiler.units inspector ; IN: tools.test SYMBOL: failures @@ -30,9 +30,17 @@ SYMBOL: this-test TUPLE: expected-error ; -: unit-test-fails ( quot -- ) - [ f ] append [ [ drop t ] recover ] curry - [ t ] swap unit-test ; +M: expected-error summary + drop + "The unit test expected the quotation to throw an error" ; + +: must-fail-with ( quot test -- ) + >r [ expected-error construct-empty throw ] compose r> + [ recover ] 2curry + [ ] swap unit-test ; + +: must-fail ( quot -- ) + [ drop t ] must-fail-with ; : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit From be2c8b13d742c843ed5cc1d1fe7019808d87d933 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:47:19 -0600 Subject: [PATCH 062/194] Rename unit-test-fails to must-fail and add must-fail-with to replace [ t ] [ [ ... ] catch ... ] unit-test idiom --- core/alien/alien-tests.factor | 6 +- core/alien/c-types/c-types-tests.factor | 2 +- core/arrays/arrays-tests.factor | 12 +-- core/bit-arrays/bit-arrays-tests.factor | 2 +- core/byte-arrays/byte-arrays-tests.factor | 2 +- core/classes/classes-tests.factor | 6 +- core/combinators/combinators-tests.factor | 2 +- core/compiler/test/alien.factor | 20 ++--- core/compiler/test/intrinsics.factor | 4 +- core/compiler/test/optimizer.factor | 4 +- core/compiler/test/redefine.factor | 2 +- core/compiler/test/simple.factor | 4 +- core/compiler/test/stack-trace.factor | 8 +- core/continuations/continuations-docs.factor | 12 +-- core/continuations/continuations-tests.factor | 42 +++++----- core/continuations/continuations.factor | 10 +-- core/float-arrays/float-arrays-tests.factor | 2 +- core/generic/generic-tests.factor | 8 +- core/growable/growable-tests.factor | 8 +- core/hashtables/hashtables-tests.factor | 6 +- core/heaps/heaps-tests.factor | 4 +- core/inference/inference-tests.factor | 72 +++++++---------- .../transforms/transforms-tests.factor | 2 +- core/io/streams/duplex/duplex-tests.factor | 4 +- core/kernel/kernel-tests.factor | 46 +++++------ core/listener/listener-tests.factor | 4 +- core/math/integers/integers-tests.factor | 4 +- core/math/parser/parser-tests.factor | 6 +- core/memory/memory-tests.factor | 2 +- core/parser/parser-tests.factor | 78 ++++++++----------- core/quotations/quotations-tests.factor | 2 +- core/sequences/sequences-tests.factor | 20 ++--- core/splitting/splitting-tests.factor | 2 +- core/strings/strings-tests.factor | 11 ++- core/threads/threads-tests.factor | 2 +- core/tuples/tuples-tests.factor | 18 ++--- core/vectors/vectors-tests.factor | 20 ++--- core/vocabs/loader/loader-tests.factor | 14 +--- core/words/words-tests.factor | 8 +- extra/bitfields/bitfields-tests.factor | 12 +-- extra/bootstrap/io/io.factor | 2 - extra/calendar/calendar-tests.factor | 16 ++-- extra/circular/circular-tests.factor | 4 +- extra/combinators/lib/lib-tests.factor | 15 ++-- extra/concurrency/concurrency-docs.factor | 2 +- extra/concurrency/concurrency-tests.factor | 15 ++-- extra/concurrency/concurrency.factor | 2 +- extra/coroutines/coroutines-tests.factor | 2 +- extra/crypto/xor/xor-tests.factor | 8 +- extra/db/postgresql/postgresql-tests.factor | 4 +- extra/db/sqlite/sqlite-tests.factor | 4 +- extra/destructors/destructors-tests.factor | 4 +- extra/help/crossref/crossref-tests.factor | 2 +- extra/inverse/inverse-tests.factor | 8 +- extra/io/buffers/buffers-tests.factor | 2 +- extra/io/mmap/mmap-tests.factor | 4 +- extra/io/unix/launcher/launcher-tests.factor | 8 +- extra/io/unix/linux/linux.factor | 6 +- extra/io/unix/unix-tests.factor | 20 ++--- extra/io/windows/nt/nt.factor | 3 + extra/irc/irc.factor | 2 +- extra/math/complex/complex-tests.factor | 4 +- extra/math/functions/functions-tests.factor | 2 +- extra/memoize/memoize-tests.factor | 2 +- .../multi-methods/multi-methods-tests.factor | 2 +- .../parser-combinators-tests.factor | 2 +- extra/regexp/regexp-tests.factor | 2 +- extra/roman/roman-tests.factor | 6 +- extra/sequences/lib/lib-tests.factor | 2 +- extra/tetris/board/board-tests.factor | 2 +- .../interpreter/interpreter-tests.factor | 2 +- extra/tools/test/inference/inference.factor | 7 +- extra/tools/test/test.factor | 3 + extra/ui/tools/listener/listener-tests.factor | 2 +- extra/xml/test/errors.factor | 2 +- extra/xml/test/test.factor | 2 +- 76 files changed, 299 insertions(+), 369 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index d5133753c1..74c94c8edf 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -14,7 +14,7 @@ prettyprint ; ! Testing the various bignum accessor 10 "dump" set -[ "dump" get alien-address ] unit-test-fails +[ "dump" get alien-address ] must-fail [ 123 ] [ 123 "dump" get 0 set-alien-signed-1 @@ -61,9 +61,9 @@ cell 8 = [ [ ] [ 0 F{ 1 2 3 } drop ] unit-test [ ] [ 0 ?{ t f t } drop ] unit-test -[ 0 B{ 1 2 3 } alien-address ] unit-test-fails +[ 0 B{ 1 2 3 } alien-address ] must-fail -[ 1 1 ] unit-test-fails +[ 1 1 ] must-fail [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test diff --git a/core/alien/c-types/c-types-tests.factor b/core/alien/c-types/c-types-tests.factor index 3148b85782..719068e031 100755 --- a/core/alien/c-types/c-types-tests.factor +++ b/core/alien/c-types/c-types-tests.factor @@ -71,4 +71,4 @@ TYPEDEF: uchar* MyLPBYTE [ 0 B{ 1 2 3 4 } -] unit-test-fails +] must-fail diff --git a/core/arrays/arrays-tests.factor b/core/arrays/arrays-tests.factor index 3ff81fda72..e07f192197 100755 --- a/core/arrays/arrays-tests.factor +++ b/core/arrays/arrays-tests.factor @@ -2,10 +2,10 @@ USING: arrays kernel sequences sequences.private growable tools.test vectors layouts system math vectors.private ; IN: temporary -[ -2 { "a" "b" "c" } nth ] unit-test-fails -[ 10 { "a" "b" "c" } nth ] unit-test-fails -[ "hi" -2 { "a" "b" "c" } set-nth ] unit-test-fails -[ "hi" 10 { "a" "b" "c" } set-nth ] unit-test-fails +[ -2 { "a" "b" "c" } nth ] must-fail +[ 10 { "a" "b" "c" } nth ] must-fail +[ "hi" -2 { "a" "b" "c" } set-nth ] must-fail +[ "hi" 10 { "a" "b" "c" } set-nth ] must-fail [ f ] [ { "a" "b" "c" } dup clone eq? ] unit-test [ "hi" ] [ "hi" 1 { "a" "b" "c" } clone [ set-nth ] keep second ] unit-test [ V{ "a" "b" "c" } ] [ { "a" "b" "c" } >vector ] unit-test @@ -17,5 +17,5 @@ IN: temporary [ { "a" "b" "c" "d" "e" } ] [ { "a" } { "b" "c" } { "d" "e" } 3append ] unit-test -[ -1 f ] unit-test-fails -[ cell-bits cell log2 - 2^ f ] unit-test-fails +[ -1 f ] must-fail +[ cell-bits cell log2 - 2^ f ] must-fail diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index f605eba24c..5f89b90608 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -51,4 +51,4 @@ IN: temporary [ ?{ t t } ] [ 2 ?{ t t f t f t f t t t f t } resize-bit-array ] unit-test -[ -10 ?{ } resize-bit-array ] unit-test-fails +[ -10 ?{ } resize-bit-array ] must-fail diff --git a/core/byte-arrays/byte-arrays-tests.factor b/core/byte-arrays/byte-arrays-tests.factor index b39551eb86..b5b01c201b 100755 --- a/core/byte-arrays/byte-arrays-tests.factor +++ b/core/byte-arrays/byte-arrays-tests.factor @@ -5,4 +5,4 @@ USING: tools.test byte-arrays ; [ B{ 1 2 } ] [ 2 B{ 1 2 3 4 5 6 7 8 9 } resize-byte-array ] unit-test -[ -10 B{ } resize-byte-array ] unit-test-fails +[ -10 B{ } resize-byte-array ] must-fail diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index efff0db5d1..d78436bd5f 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -91,7 +91,7 @@ M: union-1 generic-update-test drop "union-1" ; [ f ] [ union-1 union-class? ] unit-test [ t ] [ union-1 predicate-class? ] unit-test [ "union-1" ] [ 8 generic-update-test ] unit-test -[ -7 generic-update-test ] unit-test-fails +[ -7 generic-update-test ] must-fail ! Test mixins MIXIN: sequence-mixin @@ -193,7 +193,7 @@ DEFER: mixin-forget-test-g ] unit-test [ { } ] [ { } mixin-forget-test-g ] unit-test -[ H{ } mixin-forget-test-g ] unit-test-fails +[ H{ } mixin-forget-test-g ] must-fail [ ] [ { @@ -207,7 +207,7 @@ DEFER: mixin-forget-test-g parse-stream drop ] unit-test -[ { } mixin-forget-test-g ] unit-test-fails +[ { } mixin-forget-test-g ] must-fail [ H{ } ] [ H{ } mixin-forget-test-g ] unit-test ! Method flattening interfered with mixin update diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 208f8c0c84..3cefda7f71 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -38,7 +38,7 @@ namespaces combinators words ; ! Interpreted [ "two" ] [ 2 \ case-test-1 word-def call ] unit-test -[ "x" case-test-1 ] unit-test-fails +[ "x" case-test-1 ] must-fail : case-test-2 { diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index 9416fd1415..dbdbbfc9fa 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -13,7 +13,7 @@ FUNCTION: int ffi_test_1 ; FUNCTION: int ffi_test_2 int x int y ; [ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] unit-test-fails +[ "hi" 3 ffi_test_2 ] must-fail FUNCTION: int ffi_test_3 int x int y int z int t ; [ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test @@ -26,8 +26,8 @@ FUNCTION: double ffi_test_5 ; FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; [ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] unit-test-fails -[ 1 2 3 4 5 6 "a" ffi_test_9 ] unit-test-fails +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail C-STRUCT: foo { "int" "x" } @@ -53,7 +53,7 @@ FUNCTION: char* ffi_test_15 char* x char* y ; [ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test [ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] unit-test-fails +[ 1 2 ffi_test_15 ] must-fail C-STRUCT: bar { "long" "x" } @@ -75,7 +75,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test -[ t ] [ [ [ alien-indirect ] infer ] catch inference-error? ] unit-test +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with : indirect-test-1 "int" { } "cdecl" alien-indirect ; @@ -84,7 +84,7 @@ FUNCTION: tiny ffi_test_17 int x ; [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test -[ -1 indirect-test-1 ] unit-test-fails +[ -1 indirect-test-1 ] must-fail : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; @@ -120,7 +120,7 @@ unit-test FUNCTION: double ffi_test_6 float x float y ; [ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] unit-test-fails +[ "a" "b" ffi_test_6 ] must-fail FUNCTION: double ffi_test_7 double x double y ; [ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test @@ -157,7 +157,7 @@ FUNCTION: long ffi_test_22 long x longlong y longlong z ; [ 987655432 ] [ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test -[ 1111 f 123456789 ffi_test_22 ] unit-test-fails +[ 1111 f 123456789 ffi_test_22 ] must-fail C-STRUCT: rect { "float" "x" } @@ -177,7 +177,7 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; [ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] unit-test-fails +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; @@ -292,7 +292,7 @@ FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; [ ] [ callback-1 callback_test_1 ] unit-test -: callback-2 "void" { } "cdecl" [ [ 5 throw ] catch drop ] alien-callback ; +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; [ ] [ callback-2 callback_test_1 ] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics.factor index 1d0ad141c2..679938b7f3 100755 --- a/core/compiler/test/intrinsics.factor +++ b/core/compiler/test/intrinsics.factor @@ -422,11 +422,11 @@ cell 8 = [ [ B{ 0 0 0 0 } [ { byte-array } declare ] compile-call -] unit-test-fails +] must-fail [ B{ 0 0 0 0 } [ { c-ptr } declare ] compile-call -] unit-test-fails +] must-fail [ 4 5 diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index b59c0d5f33..091648cbbc 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -136,7 +136,7 @@ TUPLE: pred-test ; GENERIC: void-generic ( obj -- * ) : breakage "hi" void-generic ; [ t ] [ \ breakage compiled? ] unit-test -[ breakage ] unit-test-fails +[ breakage ] must-fail ! regression : test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline @@ -247,7 +247,7 @@ M: slice foozul ; GENERIC: detect-number ( obj -- obj ) M: number detect-number ; -[ 10 f [ 0 + detect-number ] compile-call ] unit-test-fails +[ 10 f [ 0 + detect-number ] compile-call ] must-fail ! Regression [ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index 5d07e764d6..e9927f4964 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -243,7 +243,7 @@ DEFER: defer-redefine-test-2 [ ] [ "IN: temporary : defer-redefine-test-2 defer-redefine-test-1 1 ;" eval ] unit-test -[ defer-redefine-test-2 ] unit-test-fails +[ defer-redefine-test-2 ] must-fail [ ] [ "IN: temporary : defer-redefine-test-1 2 ;" eval ] unit-test diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor index 9f831bb1f8..6f5cb33c1a 100755 --- a/core/compiler/test/simple.factor +++ b/core/compiler/test/simple.factor @@ -57,8 +57,8 @@ IN: temporary ! Make sure error reporting works -[ [ dup ] compile-call ] unit-test-fails -[ [ drop ] compile-call ] unit-test-fails +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail ! Regression diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace.factor index 59ee3c3d88..71c95b1b61 100755 --- a/core/compiler/test/stack-trace.factor +++ b/core/compiler/test/stack-trace.factor @@ -10,7 +10,7 @@ words splitting ; : foo 3 throw 7 ; : bar foo 4 ; : baz bar 5 ; -[ 3 ] [ [ baz ] catch ] unit-test +[ baz ] [ 3 = ] must-fail-with [ t ] [ symbolic-stack-trace [ word? ] subset @@ -22,11 +22,11 @@ words splitting ; : stack-trace-contains? symbolic-stack-trace memq? ; [ t ] [ - [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains? + [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains? ] unit-test [ t f ] [ - [ { "hi" } bleh ] catch drop + [ { "hi" } bleh ] ignore-errors \ + stack-trace-contains? \ > stack-trace-contains? ] unit-test @@ -34,6 +34,6 @@ words splitting ; : quux [ t [ "hi" throw ] when ] times ; [ t ] [ - [ 10 quux ] catch drop + [ 10 quux ] ignore-errors \ (each-integer) stack-trace-contains? ] unit-test diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 51e461c715..2977d02c6f 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -23,10 +23,9 @@ $nl "Two words raise an error in the innermost error handler for the current dynamic extent:" { $subsection throw } { $subsection rethrow } -"A set of words establish an error handler:" +"Two words for establishing an error handler:" { $subsection cleanup } { $subsection recover } -{ $subsection catch } "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." { $subsection "errors-restartable" } { $subsection "errors-post-mortem" } ; @@ -147,12 +146,7 @@ HELP: throw { $values { "error" object } } { $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; -HELP: catch -{ $values { "try" quotation } { "error/f" object } } -{ $description "Calls the " { $snippet "try" } " quotation. If an error is thrown in the dynamic extent of the quotation, restores the data stack and pushes the error. If the quotation returns successfully, outputs " { $link f } " without restoring the data stack." } -{ $notes "This word cannot differentiate between the case of " { $link f } " being thrown, and no error being thrown. You should never throw " { $link f } ", and you should also use other error handling combinators where possible." } ; - -{ catch cleanup recover } related-words +{ cleanup recover } related-words HELP: cleanup { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } @@ -166,7 +160,7 @@ HELP: rethrow { $values { "error" object } } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } { $notes - "This word is intended to be used in conjunction with " { $link recover } " or " { $link catch } " to implement error handlers which perform an action and pass the error to the next outermost error handler." + "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." } { $examples "The " { $link with-parser } " catches errors, annotates them with file name and line number information, and rethrows them:" diff --git a/core/continuations/continuations-tests.factor b/core/continuations/continuations-tests.factor index 360f4750c9..b7d580afe5 100755 --- a/core/continuations/continuations-tests.factor +++ b/core/continuations/continuations-tests.factor @@ -25,13 +25,11 @@ IN: temporary [ t ] [ 10 callcc1-test 10 reverse >vector = ] unit-test [ t ] [ callcc-namespace-test ] unit-test -[ f ] [ [ ] catch ] unit-test - -[ 5 ] [ [ 5 throw ] catch ] unit-test +[ 5 throw ] [ 5 = ] must-fail-with [ t ] [ - [ "Hello" throw ] catch drop - global [ error get ] bind + [ "Hello" throw ] ignore-errors + error get-global "Hello" = ] unit-test @@ -41,13 +39,13 @@ IN: temporary "!!! The following error is part of the test" print -[ [ "2 car" ] eval ] catch print-error +[ ] [ [ [ "2 car" ] eval ] [ print-error ] recover ] unit-test -[ f throw ] unit-test-fails +[ f throw ] must-fail ! Weird PowerPC bug. [ ] [ - [ "4" throw ] catch drop + [ "4" throw ] ignore-errors data-gc data-gc ] unit-test @@ -56,10 +54,10 @@ IN: temporary [ f ] [ { "A" "B" } kernel-error? ] unit-test ! ! See how well callstack overflow is handled -! [ clear drop ] unit-test-fails +! [ clear drop ] must-fail ! ! : callstack-overflow callstack-overflow f ; -! [ callstack-overflow ] unit-test-fails +! [ callstack-overflow ] must-fail : don't-compile-me { } [ ] each ; @@ -84,24 +82,20 @@ SYMBOL: error-counter [ 1 ] [ always-counter get ] unit-test [ 0 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ "a" throw ] - [ always-counter inc ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ "a" throw ] + [ always-counter inc ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 2 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test - [ "a" ] [ - [ - [ ] - [ always-counter inc "a" throw ] - [ error-counter inc ] cleanup - ] catch - ] unit-test + [ + [ ] + [ always-counter inc "a" throw ] + [ error-counter inc ] cleanup + ] [ "a" = ] must-fail-with [ 3 ] [ always-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor index 6e4ce16bea..b6ca056691 100755 --- a/core/continuations/continuations.factor +++ b/core/continuations/continuations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays vectors kernel kernel.private sequences namespaces math splitting sorting quotations assocs ; @@ -17,9 +17,6 @@ SYMBOL: restarts : c> ( -- continuation ) catchstack* pop ; -: (catch) ( quot -- newquot ) - [ swap >c call c> drop ] curry ; inline - : dummy ( -- obj ) #! Optimizing compiler assumes stack won't be messed with #! in-transit. To ensure that a value is actually reified @@ -120,11 +117,8 @@ PRIVATE> catchstack* empty? [ die ] when dup save-error c> continue-with ; -: catch ( try -- error/f ) - (catch) [ f ] compose callcc1 ; inline - : recover ( try recovery -- ) - >r (catch) r> ifcc ; inline + >r [ swap >c call c> drop ] curry r> ifcc ; inline : cleanup ( try cleanup-always cleanup-error -- ) over >r compose [ dip rethrow ] curry diff --git a/core/float-arrays/float-arrays-tests.factor b/core/float-arrays/float-arrays-tests.factor index afadaac0db..0e0ab3feb6 100755 --- a/core/float-arrays/float-arrays-tests.factor +++ b/core/float-arrays/float-arrays-tests.factor @@ -7,4 +7,4 @@ USING: float-arrays tools.test ; [ F{ 1 2 } ] [ 2 F{ 1 2 3 4 5 6 7 8 9 } resize-float-array ] unit-test -[ -10 F{ } resize-float-array ] unit-test-fails +[ -10 F{ } resize-float-array ] must-fail diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 4de05aafd0..e4d4160605 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -16,7 +16,7 @@ M: word class-of drop "word" ; [ "fixnum" ] [ 5 class-of ] unit-test [ "word" ] [ \ class-of class-of ] unit-test -[ 3.4 class-of ] unit-test-fails +[ 3.4 class-of ] must-fail [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test @@ -90,7 +90,7 @@ M: number union-containment drop 2 ; "IN: temporary GENERIC: unhappy ( x -- x )" eval [ "IN: temporary M: dictionary unhappy ;" eval -] unit-test-fails +] must-fail [ ] [ "IN: temporary GENERIC: unhappy ( x -- x )" eval ] unit-test GENERIC# complex-combination 1 ( a b -- c ) @@ -155,9 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ T{ no-method f 1.0 my-hook } ] [ - 1.0 my-var set [ my-hook ] catch -] unit-test +[ 1.0 my-var set my-hook ] [ [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) diff --git a/core/growable/growable-tests.factor b/core/growable/growable-tests.factor index 39d8721726..a220ccc45e 100755 --- a/core/growable/growable-tests.factor +++ b/core/growable/growable-tests.factor @@ -9,16 +9,16 @@ IN: temporary ! overflow bugs [ "hi" most-positive-fixnum 2 * 2 + V{ } clone set-nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + { 1 } clone nth ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone lengthen ] -unit-test-fails +must-fail [ most-positive-fixnum 2 * 2 + V{ } clone set-length ] -unit-test-fails +must-fail [ ] [ 10 V{ } [ set-length ] keep diff --git a/core/hashtables/hashtables-tests.factor b/core/hashtables/hashtables-tests.factor index 40d079402c..acb05be720 100755 --- a/core/hashtables/hashtables-tests.factor +++ b/core/hashtables/hashtables-tests.factor @@ -127,9 +127,9 @@ H{ } "x" set ! Another crash discovered by erg [ ] [ H{ } clone - [ 1 swap set-at ] catch drop - [ 2 swap set-at ] catch drop - [ 3 swap set-at ] catch drop + [ 1 swap set-at ] ignore-errors + [ 2 swap set-at ] ignore-errors + [ 3 swap set-at ] ignore-errors drop ] unit-test diff --git a/core/heaps/heaps-tests.factor b/core/heaps/heaps-tests.factor index de661fad92..92b06b866c 100644 --- a/core/heaps/heaps-tests.factor +++ b/core/heaps/heaps-tests.factor @@ -5,8 +5,8 @@ USING: arrays kernel math namespaces tools.test heaps heaps.private ; IN: temporary -[ heap-pop ] unit-test-fails -[ heap-pop ] unit-test-fails +[ heap-pop ] must-fail +[ heap-pop ] must-fail [ t ] [ heap-empty? ] unit-test [ f ] [ 1 t pick heap-push heap-empty? ] unit-test diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 3e3858d45d..1738a71b7e 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -12,14 +12,14 @@ IN: temporary { 1 2 } [ dup ] unit-test-effect { 1 2 } [ [ dup ] call ] unit-test-effect -[ [ call ] infer ] unit-test-fails +[ [ call ] infer ] must-fail { 2 4 } [ 2dup ] unit-test-effect { 1 0 } [ [ ] [ ] if ] unit-test-effect -[ [ if ] infer ] unit-test-fails -[ [ [ ] if ] infer ] unit-test-fails -[ [ [ 2 ] [ ] if ] infer ] unit-test-fails +[ [ if ] infer ] must-fail +[ [ [ ] if ] infer ] must-fail +[ [ [ 2 ] [ ] if ] infer ] must-fail { 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect { 4 3 } [ @@ -42,7 +42,7 @@ IN: temporary [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer -] unit-test-fails +] must-fail ! Test inference of termination of control flow : termination-test-1 @@ -54,10 +54,10 @@ IN: temporary : infinite-loop infinite-loop ; -[ [ infinite-loop ] infer ] unit-test-fails +[ [ infinite-loop ] infer ] must-fail : no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] if ; -[ [ no-base-case-1 ] infer ] unit-test-fails +[ [ no-base-case-1 ] infer ] must-fail : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; @@ -72,7 +72,7 @@ IN: temporary : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; -[ [ bad-recursion-2 ] infer ] unit-test-fails +[ [ bad-recursion-2 ] infer ] must-fail : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; @@ -192,7 +192,7 @@ DEFER: blah4 [ swap slip ] keep swap bad-combinator ] if ; inline -[ [ [ 1 ] [ ] bad-combinator ] infer ] unit-test-fails +[ [ [ 1 ] [ ] bad-combinator ] infer ] must-fail ! Regression : bad-input# @@ -207,13 +207,13 @@ DEFER: blah4 DEFER: do-crap : more-crap ( obj -- ) dup [ drop ] [ dup do-crap call ] if ; : do-crap ( obj -- ) dup [ more-crap ] [ do-crap ] if ; -[ [ do-crap ] infer ] unit-test-fails +[ [ do-crap ] infer ] must-fail ! This one does not DEFER: do-crap* : more-crap* ( obj -- ) dup [ drop ] [ dup do-crap* call ] if ; : do-crap* ( obj -- ) dup [ do-crap* ] [ more-crap* ] if ; -[ [ do-crap* ] infer ] unit-test-fails +[ [ do-crap* ] infer ] must-fail ! Regression : too-deep ( a b -- c ) @@ -226,7 +226,7 @@ M: fixnum xyz 2array ; M: float xyz [ 3 ] 2apply swapd >r 2array swap r> 2array swap ; -[ t ] [ [ [ xyz ] infer ] catch inference-error? ] unit-test +[ [ xyz ] infer ] [ inference-error? ] must-fail-with ! Doug Coleman discovered this one while working on the ! calendar library @@ -277,78 +277,66 @@ DEFER: #1 : #4 ( a -- ) dup [ drop ] [ dup #4 dup #3 call ] if ; : #1 ( a -- ) dup [ dup #4 dup #3 ] [ ] if drop ; -[ \ #4 word-def infer ] unit-test-fails -[ [ #1 ] infer ] unit-test-fails +[ \ #4 word-def infer ] must-fail +[ [ #1 ] infer ] must-fail ! Similar DEFER: bar : foo ( a b -- c d ) dup [ 2drop f f bar ] [ ] if ; : bar ( a b -- ) [ 2 2 + ] t foo drop call drop ; -[ [ foo ] infer ] unit-test-fails +[ [ foo ] infer ] must-fail -[ 1234 infer ] unit-test-fails +[ 1234 infer ] must-fail ! This used to hang -[ t ] [ - [ [ [ dup call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ dup call ] dup call ] infer ] +[ inference-error? ] must-fail-with : m dup call ; inline -[ t ] [ - [ [ [ m ] m ] infer ] catch inference-error? -] unit-test +[ [ [ m ] m ] infer ] [ inference-error? ] must-fail-with : m' dup curry call ; inline -[ t ] [ - [ [ [ m' ] m' ] infer ] catch inference-error? -] unit-test +[ [ [ m' ] m' ] infer ] [ inference-error? ] must-fail-with : m'' [ dup curry ] ; inline : m''' m'' call call ; inline -[ t ] [ - [ [ [ m''' ] m''' ] infer ] catch inference-error? -] unit-test +[ [ [ m''' ] m''' ] infer ] [ inference-error? ] must-fail-with : m-if t over if ; inline -[ t ] [ - [ [ [ m-if ] m-if ] infer ] catch inference-error? -] unit-test +[ [ [ m-if ] m-if ] infer ] [ inference-error? ] must-fail-with ! This doesn't hang but it's also an example of the ! undedicable case -[ t ] [ - [ [ [ [ drop 3 ] swap call ] dup call ] infer ] catch - inference-error? -] unit-test +[ [ [ [ drop 3 ] swap call ] dup call ] infer ] +[ inference-error? ] must-fail-with ! This form should not have a stack effect : bad-recursion-1 ( a -- b ) dup [ drop bad-recursion-1 5 ] [ ] if ; -[ [ bad-recursion-1 ] infer ] unit-test-fails +[ [ bad-recursion-1 ] infer ] must-fail : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; -[ [ bad-bin ] infer ] unit-test-fails +[ [ bad-bin ] infer ] must-fail -[ t ] [ [ [ r> ] infer ] catch inference-error? ] unit-test +[ [ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ t ] [ [ [ get-slots ] infer ] catch inference-error? ] unit-test +[ [ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect { 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect -[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] unit-test-fails +[ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail ! Test number protocol \ bitor must-infer @@ -459,7 +447,7 @@ DEFER: bar : fooxxx ( a b -- c ) over [ foo ] when ; inline : barxxx fooxxx ; -[ [ barxxx ] infer ] unit-test-fails +[ [ barxxx ] infer ] must-fail ! A typo { 1 0 } [ { [ ] } dispatch ] unit-test-effect diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index 152da8c757..f58e557b10 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -31,4 +31,4 @@ TUPLE: a-tuple x y z ; : set-slots-test-2 { set-a-tuple-x set-a-tuple-x } set-slots ; -[ [ set-slots-test-2 ] infer ] unit-test-fails +[ [ set-slots-test-2 ] infer ] must-fail diff --git a/core/io/streams/duplex/duplex-tests.factor b/core/io/streams/duplex/duplex-tests.factor index 962a46413f..44542e05ce 100755 --- a/core/io/streams/duplex/duplex-tests.factor +++ b/core/io/streams/duplex/duplex-tests.factor @@ -28,13 +28,13 @@ M: unclosable-stream dispose [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test [ t ] [ [ - [ dup dispose ] catch 2drop + [ dup dispose ] [ 2drop ] recover ] keep closing-stream-closed? ] unit-test diff --git a/core/kernel/kernel-tests.factor b/core/kernel/kernel-tests.factor index c294c23738..e37b208ef0 100755 --- a/core/kernel/kernel-tests.factor +++ b/core/kernel/kernel-tests.factor @@ -7,25 +7,22 @@ IN: temporary [ t ] [ [ \ = \ = ] all-equal? ] unit-test ! Don't leak extra roots if error is thrown -[ ] [ 10000 [ [ 3 throw ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ 3 throw ] ignore-errors ] times ] unit-test -[ ] [ 10000 [ [ -1 f ] catch drop ] times ] unit-test +[ ] [ 10000 [ [ -1 f ] ignore-errors ] times ] unit-test ! Make sure we report the correct error on stack underflow -[ { "kernel-error" 11 f f } ] -[ [ clear drop ] catch ] unit-test +[ clear drop ] [ { "kernel-error" 11 f f } = ] must-fail-with [ ] [ :c ] unit-test -[ { "kernel-error" 13 f f } ] -[ [ { } set-retainstack r> ] catch ] unit-test +[ { } set-retainstack r> ] [ { "kernel-error" 13 f f } = ] must-fail-with [ ] [ :c ] unit-test : overflow-d 3 overflow-d ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d ] catch ] unit-test +[ overflow-d ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ :c ] unit-test @@ -33,24 +30,17 @@ IN: temporary : overflow-d-alt (overflow-d-alt) overflow-d-alt ; -[ { "kernel-error" 12 f f } ] -[ [ overflow-d-alt ] catch ] unit-test +[ overflow-d-alt ] [ { "kernel-error" 12 f f } = ] must-fail-with [ ] [ [ :c ] string-out drop ] unit-test : overflow-r 3 >r overflow-r ; -[ { "kernel-error" 14 f f } ] -[ [ overflow-r ] catch ] unit-test +[ overflow-r ] [ { "kernel-error" 14 f f } = ] must-fail-with [ ] [ :c ] unit-test -! : overflow-c overflow-c 3 ; -! -! [ { "kernel-error" 16 f f } ] -! [ [ overflow-c ] catch ] unit-test - -[ -7 ] unit-test-fails +[ -7 ] must-fail [ 2 3 4 1 ] [ 1 2 3 4 roll ] unit-test [ 1 2 3 4 ] [ 2 3 4 1 -roll ] unit-test @@ -61,27 +51,27 @@ IN: temporary [ 4 ] [ 4 6 or ] unit-test [ 6 ] [ f 6 or ] unit-test -[ slip ] unit-test-fails +[ slip ] must-fail [ ] [ :c ] unit-test -[ 1 slip ] unit-test-fails +[ 1 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 slip ] unit-test-fails +[ 1 2 slip ] must-fail [ ] [ :c ] unit-test -[ 1 2 3 slip ] unit-test-fails +[ 1 2 3 slip ] must-fail [ ] [ :c ] unit-test [ 5 ] [ [ 2 2 + ] 1 slip + ] unit-test -[ [ ] keep ] unit-test-fails +[ [ ] keep ] must-fail [ 6 ] [ 2 [ sq ] keep + ] unit-test -[ [ ] 2keep ] unit-test-fails -[ 1 [ ] 2keep ] unit-test-fails +[ [ ] 2keep ] must-fail +[ 1 [ ] 2keep ] must-fail [ 3 1 2 ] [ 1 2 [ 2drop 3 ] 2keep ] unit-test [ 0 ] [ f [ sq ] [ 0 ] if* ] unit-test @@ -100,13 +90,13 @@ IN: temporary [ ] [ callstack set-callstack ] unit-test -[ 3drop datastack ] unit-test-fails +[ 3drop datastack ] must-fail [ ] [ :c ] unit-test ! Doesn't compile; important : foo 5 + 0 [ ] each ; -[ drop foo ] unit-test-fails +[ drop foo ] must-fail [ ] [ :c ] unit-test ! Regression @@ -117,4 +107,4 @@ IN: temporary : loop ( obj obj -- ) H{ } values swap >r dup length swap r> 0 -roll (loop) ; -[ loop ] unit-test-fails +[ loop ] must-fail diff --git a/core/listener/listener-tests.factor b/core/listener/listener-tests.factor index 626c2b3e06..4570b1162a 100755 --- a/core/listener/listener-tests.factor +++ b/core/listener/listener-tests.factor @@ -22,7 +22,7 @@ IN: temporary [ "\\ + 1 2 3 4" parse-interactive "cont" get continue-with - ] catch + ] ignore-errors "USE: debugger :1" eval ] callcc1 ] unit-test @@ -36,7 +36,7 @@ IN: temporary [ "USE: vocabs.loader.test.c" parse-interactive -] unit-test-fails +] must-fail [ ] [ [ diff --git a/core/math/integers/integers-tests.factor b/core/math/integers/integers-tests.factor index 680119a56e..194edb8f7e 100755 --- a/core/math/integers/integers-tests.factor +++ b/core/math/integers/integers-tests.factor @@ -121,8 +121,8 @@ unit-test ! We don't care if this fails or returns 0 (its CPU-specific) ! as long as it doesn't crash -[ ] [ [ 0 0 /i ] catch clear ] unit-test -[ ] [ [ 100000000000000000 0 /i ] catch clear ] unit-test +[ ] [ [ 0 0 /i drop ] ignore-errors ] unit-test +[ ] [ [ 100000000000000000 0 /i drop ] ignore-errors ] unit-test [ -2 ] [ 1 bitnot ] unit-test [ -2 ] [ 1 >bignum bitnot ] unit-test diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 62893e2618..7c30012a19 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -105,6 +105,6 @@ unit-test ! [ dup number>string string>number = ] all? ! ] unit-test -[ 1 1 >base ] unit-test-fails -[ 1 0 >base ] unit-test-fails -[ 1 -1 >base ] unit-test-fails +[ 1 1 >base ] must-fail +[ 1 0 >base ] must-fail +[ 1 -1 >base ] must-fail diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor index f543c08744..d0dfd2c0be 100755 --- a/core/memory/memory-tests.factor +++ b/core/memory/memory-tests.factor @@ -4,7 +4,7 @@ IN: temporary TUPLE: testing x y z ; -[ save-image-and-exit ] unit-test-fails +[ save-image-and-exit ] must-fail [ ] [ num-types get [ diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index f503528a24..eb04e329d9 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -93,12 +93,12 @@ IN: temporary ! Funny bug [ 2 ] [ "IN: temporary : \0. 2 ; \0." eval ] unit-test - [ "IN: temporary : missing-- ( a b ) ;" eval ] unit-test-fails + [ "IN: temporary : missing-- ( a b ) ;" eval ] must-fail ! These should throw errors - [ "HEX: zzz" eval ] unit-test-fails - [ "OCT: 999" eval ] unit-test-fails - [ "BIN: --0" eval ] unit-test-fails + [ "HEX: zzz" eval ] must-fail + [ "OCT: 999" eval ] must-fail + [ "BIN: --0" eval ] must-fail ! Another funny bug [ t ] [ @@ -205,12 +205,10 @@ IN: temporary "a" source-files get delete-at - [ t ] [ - [ - "IN: temporary : x ; : y 3 throw ; this is an error" - "a" parse-stream - ] catch parse-error? - ] unit-test + [ + "IN: temporary : x ; : y 3 throw ; this is an error" + "a" parse-stream + ] [ parse-error? ] must-fail-with [ t ] [ "y" "temporary" lookup >boolean @@ -307,62 +305,50 @@ IN: temporary "killer?" "temporary" lookup >boolean ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" - "removing-the-predicate" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: another-pred-test ; GENERIC: another-pred-test?" + "removing-the-predicate" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" - "redefining-a-class-1" parse-stream - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; TUPLE: class-redef-test ;" + "redefining-a-class-1" parse-stream + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test" "redefining-a-class-2" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" - "redefining-a-class-3" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary TUPLE: class-redef-test ; SYMBOL: class-redef-test : class-redef-test ;" + "redefining-a-class-3" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ;" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with [ ] [ "IN: temporary TUPLE: class-fwd-test ; SYMBOL: class-fwd-test" "redefining-a-class-3" parse-stream drop ] unit-test - [ t ] [ - [ - "IN: temporary \\ class-fwd-test" - "redefining-a-class-3" parse-stream drop - ] catch [ no-word? ] is? - ] unit-test + [ + "IN: temporary \\ class-fwd-test" + "redefining-a-class-3" parse-stream drop + ] [ [ no-word? ] is? ] must-fail-with - [ t ] [ - [ - "IN: temporary : foo ; TUPLE: foo ;" - "redefining-a-class-4" parse-stream drop - ] catch [ redefine-error? ] is? - ] unit-test + [ + "IN: temporary : foo ; TUPLE: foo ;" + "redefining-a-class-4" parse-stream drop + ] [ [ redefine-error? ] is? ] must-fail-with ] with-file-vocabs [ diff --git a/core/quotations/quotations-tests.factor b/core/quotations/quotations-tests.factor index f1cc6cd828..d357fb70ff 100644 --- a/core/quotations/quotations-tests.factor +++ b/core/quotations/quotations-tests.factor @@ -15,4 +15,4 @@ IN: temporary [ [ "hi" ] ] [ "hi" 1quotation ] unit-test -[ 1 \ + curry ] unit-test-fails +[ 1 \ + curry ] must-fail diff --git a/core/sequences/sequences-tests.factor b/core/sequences/sequences-tests.factor index 73ae4737ba..40b2fef85e 100755 --- a/core/sequences/sequences-tests.factor +++ b/core/sequences/sequences-tests.factor @@ -83,8 +83,8 @@ unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] [ 4 ] append ] unit-test [ [ 1 2 3 4 ] ] [ [ 1 2 3 ] { 4 } append ] unit-test -[ "a" -1 append ] unit-test-fails -[ -1 "a" append ] unit-test-fails +[ "a" -1 append ] must-fail +[ -1 "a" append ] must-fail [ [ ] ] [ 1 [ ] remove ] unit-test [ [ ] ] [ 1 [ 1 ] remove ] unit-test @@ -119,7 +119,7 @@ unit-test [ V{ 0 1 4 5 } ] [ 6 >vector 2 4 pick delete-slice ] unit-test -[ 6 >vector 2 8 pick delete-slice ] unit-test-fails +[ 6 >vector 2 8 pick delete-slice ] must-fail [ V{ } ] [ 6 >vector 0 6 pick delete-slice ] unit-test @@ -173,7 +173,7 @@ unit-test [ V{ "C" } V{ "c" } ] [ { "a" "b" "C" } { "a" "b" "c" } drop-prefix [ >vector ] 2apply ] unit-test -[ -1 1 "abc" ] unit-test-fails +[ -1 1 "abc" ] must-fail [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] 2apply ] unit-test @@ -195,8 +195,8 @@ unit-test ! Pathological case [ "ihbye" ] [ "hi" "bye" append ] unit-test -[ -10 "hi" "bye" copy ] unit-test-fails -[ 10 "hi" "bye" copy ] unit-test-fails +[ -10 "hi" "bye" copy ] must-fail +[ 10 "hi" "bye" copy ] must-fail [ V{ 1 2 3 5 6 } ] [ 3 V{ 1 2 3 4 5 6 } clone [ delete-nth ] keep @@ -228,13 +228,13 @@ unit-test [ SBUF" \0\0\0" ] [ 3 SBUF" " new ] unit-test [ 0 ] [ f length ] unit-test -[ f first ] unit-test-fails +[ f first ] must-fail [ 3 ] [ 3 10 nth ] unit-test [ 3 ] [ 3 10 nth-unsafe ] unit-test -[ -3 10 nth ] unit-test-fails -[ 11 10 nth ] unit-test-fails +[ -3 10 nth ] must-fail +[ 11 10 nth ] must-fail -[ -1./0. 0 delete-nth ] unit-test-fails +[ -1./0. 0 delete-nth ] must-fail [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] left-trim ] unit-test [ "" ] [ "" [ CHAR: \s = ] right-trim ] unit-test diff --git a/core/splitting/splitting-tests.factor b/core/splitting/splitting-tests.factor index 3ca78248ab..2b6107e08b 100644 --- a/core/splitting/splitting-tests.factor +++ b/core/splitting/splitting-tests.factor @@ -1,7 +1,7 @@ USING: splitting tools.test ; IN: temporary -[ { 1 2 3 } 0 group ] unit-test-fails +[ { 1 2 3 } 0 group ] must-fail [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 985c025827..90e74275ff 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -4,7 +4,7 @@ IN: temporary [ CHAR: b ] [ 1 >bignum "abc" nth ] unit-test -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test @@ -31,7 +31,7 @@ IN: temporary [ t ] [ "abc" "abd" <=> 0 < ] unit-test [ t ] [ "z" "abd" <=> 0 > ] unit-test -[ f ] [ [ 0 10 "hello" subseq ] catch not ] unit-test +[ 0 10 "hello" subseq ] must-fail [ "Replacing+spaces+with+plus" ] [ @@ -43,8 +43,8 @@ unit-test [ "05" ] [ "5" 2 CHAR: 0 pad-left ] unit-test [ "666" ] [ "666" 2 CHAR: 0 pad-left ] unit-test -[ 1 "" nth ] unit-test-fails -[ -6 "hello" nth ] unit-test-fails +[ 1 "" nth ] must-fail +[ -6 "hello" nth ] must-fail [ t ] [ "hello world" dup >vector >string = ] unit-test @@ -55,8 +55,7 @@ unit-test [ "\u001234bc\0\0\0" ] [ 6 "\u001234bc" resize-string ] unit-test ! Random tester found this -[ { "kernel-error" 3 12 -7 } ] -[ [ 2 -7 resize-string ] catch ] unit-test +[ 2 -7 resize-string ] [ { "kernel-error" 3 12 -7 } = ] must-fail-with ! Make sure 24-bit strings work "hello world" "s" set diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index b1b2f86a47..379b10ce88 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -9,4 +9,4 @@ IN: temporary yield [ ] [ 0.3 sleep ] unit-test -[ "hey" sleep ] unit-test-fails +[ "hey" sleep ] must-fail diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index 627ee5562f..dede1a2136 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -55,7 +55,7 @@ C: point "IN: temporary TUPLE: point z y ;" eval -[ "p" get point-x ] unit-test-fails +[ "p" get point-x ] must-fail [ 200 ] [ "p" get point-y ] unit-test [ 300 ] [ "p" get "point-z" "temporary" lookup execute ] unit-test @@ -97,7 +97,7 @@ TUPLE: delegate-clone ; [ f ] [ \ tuple \ delegate-clone class< ] unit-test ! Compiler regression -[ t ] [ [ t length ] catch no-method-object ] unit-test +[ t length ] [ no-method-object t eq? ] must-fail-with [ "" ] [ "TUPLE: constructor-test ; C: constructor-test" eval word word-name ] unit-test @@ -204,15 +204,15 @@ SYMBOL: not-a-tuple-class [ "IN: temporary C: not-a-tuple-class" eval -] unit-test-fails +] must-fail [ t ] [ "not-a-tuple-class" "temporary" lookup symbol? ] unit-test ! Missing check -[ not-a-tuple-class construct-boa ] unit-test-fails -[ not-a-tuple-class construct-empty ] unit-test-fails +[ not-a-tuple-class construct-boa ] must-fail +[ not-a-tuple-class construct-empty ] must-fail TUPLE: erg's-reshape-problem a b c d ; @@ -234,8 +234,6 @@ C: erg's-reshape-problem [ t ] [ 1 cons-test-3 array-capacity "a" get array-capacity = ] unit-test -[ t ] [ - [ - "IN: temporary SYMBOL: not-a-class C: not-a-class" eval - ] catch [ check-tuple? ] is? -] unit-test +[ + "IN: temporary SYMBOL: not-a-class C: not-a-class" eval +] [ [ check-tuple? ] is? ] must-fail-with diff --git a/core/vectors/vectors-tests.factor b/core/vectors/vectors-tests.factor index 4c57c238b4..b56cee1b34 100755 --- a/core/vectors/vectors-tests.factor +++ b/core/vectors/vectors-tests.factor @@ -3,25 +3,25 @@ sequences sequences.private strings tools.test vectors continuations random growable classes ; IN: temporary -[ ] [ 10 [ [ -1000000 ] catch drop ] times ] unit-test +[ ] [ 10 [ [ -1000000 ] ignore-errors ] times ] unit-test [ 3 ] [ [ t f t ] length ] unit-test [ 3 ] [ V{ t f t } length ] unit-test -[ -3 V{ } nth ] unit-test-fails -[ 3 V{ } nth ] unit-test-fails -[ 3 54.3 nth ] unit-test-fails +[ -3 V{ } nth ] must-fail +[ 3 V{ } nth ] must-fail +[ 3 54.3 nth ] must-fail -[ "hey" [ 1 2 ] set-length ] unit-test-fails -[ "hey" V{ 1 2 } set-length ] unit-test-fails +[ "hey" [ 1 2 ] set-length ] must-fail +[ "hey" V{ 1 2 } set-length ] must-fail [ 3 ] [ 3 0 [ set-length ] keep length ] unit-test [ "yo" ] [ "yo" 4 1 [ set-nth ] keep 4 swap nth ] unit-test -[ 1 V{ } nth ] unit-test-fails -[ -1 V{ } set-length ] unit-test-fails +[ 1 V{ } nth ] must-fail +[ -1 V{ } set-length ] must-fail [ V{ } ] [ [ ] >vector ] unit-test [ V{ 1 2 } ] [ [ 1 2 ] >vector ] unit-test @@ -64,8 +64,8 @@ IN: temporary [ V{ 2 3 } ] [ "funny-stack" get pop ] unit-test [ V{ 1 5 } ] [ "funny-stack" get peek ] unit-test [ V{ 1 5 } ] [ "funny-stack" get pop ] unit-test -[ "funny-stack" get pop ] unit-test-fails -[ "funny-stack" get pop ] unit-test-fails +[ "funny-stack" get pop ] must-fail +[ "funny-stack" get pop ] must-fail [ ] [ "funky" "funny-stack" get push ] unit-test [ "funky" ] [ "funny-stack" get pop ] unit-test diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 560affa566..764f14e45f 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -18,16 +18,6 @@ debugger compiler.units ; [ t ] [ "kernel" f >vocab-link "kernel" vocab = ] unit-test -! This vocab should not exist, but just in case... -[ ] [ [ "core" forget-vocab ] with-compilation-unit ] unit-test - -2 [ - [ T{ no-vocab f "core" } ] - [ [ "core" require ] catch ] unit-test -] times - -[ f ] [ "core" vocab ] unit-test - [ t ] [ "kernel" vocab-files "kernel" vocab vocab-files @@ -59,7 +49,7 @@ IN: temporary 0 "count-me" set-global 2 [ - [ "vocabs.loader.test.a" require ] unit-test-fails + [ "vocabs.loader.test.a" require ] must-fail [ f ] [ "vocabs.loader.test.a" vocab-source-loaded? ] unit-test @@ -97,7 +87,7 @@ IN: temporary ] with-compilation-unit ] unit-test -[ "vocabs.loader.test.b" require ] unit-test-fails +[ "vocabs.loader.test.b" require ] must-fail [ 1 ] [ "count-me" get-global ] unit-test diff --git a/core/words/words-tests.factor b/core/words/words-tests.factor index 92f5284c49..f29d21cd9f 100755 --- a/core/words/words-tests.factor +++ b/core/words/words-tests.factor @@ -110,7 +110,7 @@ M: array freakish ; [ t ] [ \ bar \ freakish usage member? ] unit-test DEFER: x -[ t ] [ [ x ] catch undefined? ] unit-test +[ x ] [ undefined? ] must-fail-with [ ] [ "no-loc" "temporary" create drop ] unit-test [ f ] [ "no-loc" "temporary" lookup where ] unit-test @@ -141,10 +141,8 @@ SYMBOL: quot-uses-b [ { + } ] [ \ quot-uses-b uses ] unit-test -[ t ] [ - [ "IN: temporary : undef-test ; << undef-test >>" eval ] catch - [ undefined? ] is? -] unit-test +[ "IN: temporary : undef-test ; << undef-test >>" eval ] +[ [ undefined? ] is? ] must-fail-with [ ] [ "IN: temporary GENERIC: symbol-generic" eval diff --git a/extra/bitfields/bitfields-tests.factor b/extra/bitfields/bitfields-tests.factor index 6c82ec0323..8a3bb1f043 100644 --- a/extra/bitfields/bitfields-tests.factor +++ b/extra/bitfields/bitfields-tests.factor @@ -10,12 +10,12 @@ SAFE-BITFIELD: foo bar:5 baz:10 111 bing:2 ; [ 855 ] [ 21 852 3 855 swap with-foo-baz foo-baz ] unit-test [ 1 ] [ 21 852 3 1 swap with-foo-bing foo-bing ] unit-test -[ 100 0 0 ] unit-test-fails -[ 0 5000 0 ] unit-test-fails -[ 0 0 10 ] unit-test-fails +[ 100 0 0 ] must-fail +[ 0 5000 0 ] must-fail +[ 0 0 10 ] must-fail -[ 100 0 with-foo-bar ] unit-test-fails -[ 5000 0 with-foo-baz ] unit-test-fails -[ 10 0 with-foo-bing ] unit-test-fails +[ 100 0 with-foo-bar ] must-fail +[ 5000 0 with-foo-baz ] must-fail +[ 10 0 with-foo-bing ] must-fail [ BIN: 00101100000000111111 ] [ BIN: 101 BIN: 1000000001 BIN: 11 ] unit-test diff --git a/extra/bootstrap/io/io.factor b/extra/bootstrap/io/io.factor index 4d5440e546..065f7dd5c4 100755 --- a/extra/bootstrap/io/io.factor +++ b/extra/bootstrap/io/io.factor @@ -10,5 +10,3 @@ IN: bootstrap.io { [ wince? ] [ "windows.ce" ] } } cond append require ] when - -"vocabs.monitor" require diff --git a/extra/calendar/calendar-tests.factor b/extra/calendar/calendar-tests.factor index fbb60b2d49..3b0cfc8455 100644 --- a/extra/calendar/calendar-tests.factor +++ b/extra/calendar/calendar-tests.factor @@ -1,14 +1,14 @@ USING: arrays calendar kernel math sequences tools.test continuations system ; -[ "invalid timestamp" ] [ [ 2004 12 32 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 2 30 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2003 2 29 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 -2 9 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 0 0 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 24 0 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 60 0 0 make-timestamp ] catch ] unit-test -[ "invalid timestamp" ] [ [ 2004 12 1 23 59 60 0 0 make-timestamp ] catch ] unit-test +[ 2004 12 32 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 2 30 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2003 2 29 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 -2 9 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 0 0 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 24 0 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 60 0 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with +[ 2004 12 1 23 59 60 0 make-timestamp ] [ "invalid timestamp" = ] must-fail-with [ f ] [ 1900 leap-year? ] unit-test [ t ] [ 1904 leap-year? ] unit-test diff --git a/extra/circular/circular-tests.factor b/extra/circular/circular-tests.factor index 01504a0e8a..8ca4574885 100644 --- a/extra/circular/circular-tests.factor +++ b/extra/circular/circular-tests.factor @@ -9,7 +9,7 @@ circular strings ; [ CHAR: t ] [ "test" 0 swap nth ] unit-test [ "test" ] [ "test" >string ] unit-test -[ "test" 5 swap nth ] unit-test-fails +[ "test" 5 swap nth ] must-fail [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test @@ -18,7 +18,7 @@ circular strings ; [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test [ "fob" ] [ "foo" CHAR: b 2 pick set-nth >string ] unit-test -[ "foo" CHAR: b 3 rot set-nth ] unit-test-fails +[ "foo" CHAR: b 3 rot set-nth ] must-fail [ "boo" ] [ "foo" CHAR: b 3 pick set-nth-unsafe >string ] unit-test [ "ornact" ] [ "factor" 4 over change-circular-start CHAR: n 2 pick set-nth >string ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index deeb105758..235f441b8b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -8,26 +8,25 @@ IN: temporary [ 50 ] [ 100 [1,b] [ odd? ] count ] unit-test [ 328350 ] [ 100 [ sq ] sigma ] unit-test -: infers? [ infer drop ] curry catch not ; - [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test { 6 2 } [ 1 2 [ 5 + ] dip ] unit-test { 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test -{ t } [ [ [ 99 ] 1 2 3 4 5 5 nslip ] infers? ] unit-test + +[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test -{ t } [ [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] infers? ] unit-test +[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer { 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + ] 2 map-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + ] 2 map-withn ] must-infer { { 6 7 } } [ 1 2 { 3 4 } [ + + ] 2 map-withn ] unit-test { { 16 17 18 19 20 } } [ 1 2 3 4 { 6 7 8 9 10 } [ + + + + ] 4 map-withn ] unit-test -{ t } [ [ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] infers? ] unit-test +[ 1 2 { 3 4 } [ + + drop ] 2 each-withn ] must-infer { 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test [ 1 1 2 2 3 3 ] [ 1 2 3 [ dup ] 3apply ] unit-test [ 1 4 9 ] [ 1 2 3 [ sq ] 3apply ] unit-test -[ t ] [ [ [ sq ] 3apply ] infers? ] unit-test +[ [ sq ] 3apply ] must-infer [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test -[ t ] [ [ [ dup 2^ 2array ] 5 napply ] infers? ] unit-test +[ [ dup 2^ 2array ] 5 napply ] must-infer ! && diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index dafbafbc5b..f04811b72a 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -146,7 +146,7 @@ ARTICLE: { "concurrency" "exceptions" } "Exceptions" "A process can handle exceptions using the standard Factor exception handling mechanism. If an exception is uncaught the process will terminate. For example:" { $code "[ 1 0 / \"This will not print\" print ] spawn" } "Processes can be linked so that a parent process can receive the exception that caused the child process to terminate. In this way 'supervisor' processes can be created that are notified when child processes terminate and possibly restart them.\n\nThe easiest way to form this link is using " { $link spawn-link } ". This will create a unidirectional link, such that if an uncaught exception causes the child to terminate, the parent process can catch it:" -{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] catch [ \"Exception caught.\" print ] when" } +{ $code "[\n [ 1 0 / \"This will not print\" print ] spawn-link drop\n receive\n] [ \"Exception caught.\" print ] recover" } "Exceptions are only raised in the parent when the parent does a " { $link receive } " or " { $link receive-if } ". This is because the exception is sent from the child to the parent as a message." ; ARTICLE: { "concurrency" "futures" } "Futures" diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index a9d4b39854..2f9b6605d7 100644 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -67,15 +67,12 @@ IN: temporary ] unit-test -[ "crash" ] [ +[ [ - [ - "crash" throw - ] spawn-link drop - receive - ] - catch -] unit-test + "crash" throw + ] spawn-link drop + receive +] [ "crash" = ] must-fail-with [ 50 ] [ [ 50 ] future ?future @@ -115,7 +112,7 @@ SYMBOL: value ! this is fixed (via a timeout). ! [ ! [ "this should propogate" throw ] future ?future -! ] unit-test-fails +! ] must-fail [ ] [ [ "this should not propogate" throw ] future drop diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index bc0d01956f..8d842f15d0 100644 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -166,7 +166,7 @@ M: process send ( message process -- ) PRIVATE> : spawn-link ( quot -- process ) - [ catch [ rethrow-linked ] when* ] curry + [ [ rethrow-linked ] recover ] curry [ ((spawn)) ] curry (spawn-link) ; inline "parent-test" parse-stream drop - ] catch [ :1 ] when + ] [ :1 ] recover ] unit-test [ "xxx" ] [ "yyy" article-parent ] unit-test diff --git a/extra/inverse/inverse-tests.factor b/extra/inverse/inverse-tests.factor index a61be734fc..31e7c5f78a 100644 --- a/extra/inverse/inverse-tests.factor +++ b/extra/inverse/inverse-tests.factor @@ -3,7 +3,7 @@ math.functions math.constants ; IN: inverse-tests [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test -[ { 3 4 } [ dup 2array ] undo ] unit-test-fails +[ { 3 4 } [ dup 2array ] undo ] must-fail TUPLE: foo bar baz ; @@ -15,7 +15,7 @@ C: foo [ t ] [ { 3 3 } [ 2same ] matches? ] unit-test [ f ] [ { 3 4 } [ 2same ] matches? ] unit-test -[ [ 2same ] matches? ] unit-test-fails +[ [ 2same ] matches? ] must-fail : something ( array -- num ) { @@ -25,9 +25,9 @@ C: foo [ 5 ] [ { 1 2 2 } something ] unit-test [ 6 ] [ { 2 3 } something ] unit-test -[ { 1 } something ] unit-test-fails +[ { 1 } something ] must-fail -[ 1 2 [ eq? ] undo ] unit-test-fails +[ 1 2 [ eq? ] undo ] must-fail : f>c ( *fahrenheit -- *celsius ) 32 - 1.8 / ; diff --git a/extra/io/buffers/buffers-tests.factor b/extra/io/buffers/buffers-tests.factor index 6fcdc86423..c9203d9ef8 100755 --- a/extra/io/buffers/buffers-tests.factor +++ b/extra/io/buffers/buffers-tests.factor @@ -75,5 +75,5 @@ sequences tools.test namespaces ; "b" get buffer-free 100 "b" set -[ 1000 "b" get n>buffer ] unit-test-fails +[ 1000 "b" get n>buffer ] must-fail "b" get buffer-free diff --git a/extra/io/mmap/mmap-tests.factor b/extra/io/mmap/mmap-tests.factor index a01481ecdc..f0547961bc 100644 --- a/extra/io/mmap/mmap-tests.factor +++ b/extra/io/mmap/mmap-tests.factor @@ -1,9 +1,9 @@ USING: io io.mmap io.files kernel tools.test continuations sequences ; IN: temporary -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors [ ] [ "mmap-test-file.txt" resource-path [ "12345" write ] with-stream ] unit-test [ ] [ "mmap-test-file.txt" resource-path dup file-length [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test [ 5 ] [ "mmap-test-file.txt" resource-path dup file-length [ length ] with-mapped-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" resource-path file-contents ] unit-test -[ "mmap-test-file.txt" resource-path delete-file ] catch drop +[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors diff --git a/extra/io/unix/launcher/launcher-tests.factor b/extra/io/unix/launcher/launcher-tests.factor index fec97baa5a..eb3038e1b5 100755 --- a/extra/io/unix/launcher/launcher-tests.factor +++ b/extra/io/unix/launcher/launcher-tests.factor @@ -1,8 +1,8 @@ IN: temporary USING: io.unix.launcher tools.test ; -[ "" tokenize-command ] unit-test-fails -[ " " tokenize-command ] unit-test-fails +[ "" tokenize-command ] must-fail +[ " " tokenize-command ] must-fail [ { "a" } ] [ "a" tokenize-command ] unit-test [ { "abc" } ] [ "abc" tokenize-command ] unit-test [ { "abc" } ] [ "abc " tokenize-command ] unit-test @@ -14,8 +14,8 @@ USING: io.unix.launcher tools.test ; [ { "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test [ { "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test [ { "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test -[ "'abc def' \"hey" tokenize-command ] unit-test-fails -[ "'abc def" tokenize-command ] unit-test-fails +[ "'abc def' \"hey" tokenize-command ] must-fail +[ "'abc def" tokenize-command ] must-fail [ { "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test [ diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 9c4aced03f..55f5f01abc 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -3,7 +3,7 @@ USING: kernel io.backend io.monitors io.monitors.private io.files io.buffers io.nonblocking io.unix.backend io.unix.select io.unix.launcher unix.linux.inotify assocs namespaces threads -continuations init math alien.c-types alien ; +continuations init math alien.c-types alien vocabs.loader ; IN: io.unix.linux TUPLE: linux-io ; @@ -134,4 +134,6 @@ M: linux-io init-io ( -- ) T{ linux-io } set-io-backend -[ start-wait-thread ] "io.unix.linux" add-init-hook \ No newline at end of file +[ start-wait-thread ] "io.unix.linux" add-init-hook + +"vocabs.monitor" require \ No newline at end of file diff --git a/extra/io/unix/unix-tests.factor b/extra/io/unix/unix-tests.factor index 8a621f8f48..5a93257949 100755 --- a/extra/io/unix/unix-tests.factor +++ b/extra/io/unix/unix-tests.factor @@ -7,7 +7,7 @@ IN: temporary [ [ "unix-domain-socket-test" resource-path delete-file - ] catch drop + ] ignore-errors "unix-domain-socket-test" resource-path [ @@ -36,7 +36,7 @@ yield ! Unix domain datagram sockets [ "unix-domain-datagram-test" resource-path delete-file -] catch drop +] ignore-errors : server-addr "unix-domain-datagram-test" resource-path ; : client-addr "unix-domain-datagram-test-2" resource-path ; @@ -75,7 +75,7 @@ yield [ "unix-domain-datagram-test-2" resource-path delete-file -] catch drop +] ignore-errors client-addr "d" set @@ -110,7 +110,7 @@ client-addr [ "unix-domain-datagram-test-3" resource-path delete-file -] catch drop +] ignore-errors "unix-domain-datagram-test-2" resource-path delete-file @@ -118,29 +118,29 @@ client-addr [ B{ 1 2 3 } "unix-domain-datagram-test-3" "d" get send -] unit-test-fails +] must-fail [ ] [ "d" get dispose ] unit-test ! See what happens on send/receive after close -[ "d" get receive ] unit-test-fails +[ "d" get receive ] must-fail -[ B{ 1 2 } server-addr "d" get send ] unit-test-fails +[ B{ 1 2 } server-addr "d" get send ] must-fail ! Invalid parameter tests [ image [ stdio get accept ] with-stream -] unit-test-fails +] must-fail [ image [ stdio get receive ] with-stream -] unit-test-fails +] must-fail [ image [ B{ 1 2 } server-addr stdio get send ] with-stream -] unit-test-fails +] must-fail diff --git a/extra/io/windows/nt/nt.factor b/extra/io/windows/nt/nt.factor index b957aa2fca..be57a398a2 100755 --- a/extra/io/windows/nt/nt.factor +++ b/extra/io/windows/nt/nt.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USE: vocabs.loader USE: io.windows USE: io.windows.nt.backend USE: io.windows.nt.files @@ -11,3 +12,5 @@ USE: io.windows.mmap USE: io.backend T{ windows-nt-io } set-io-backend + +"vocabs.monitor" require diff --git a/extra/irc/irc.factor b/extra/irc/irc.factor index 5b4355986f..44c682e671 100755 --- a/extra/irc/irc.factor +++ b/extra/irc/irc.factor @@ -189,7 +189,7 @@ SYMBOL: line : with-infinite-loop ( quot timeout -- quot timeout ) "looping" print flush - over catch drop dup sleep with-infinite-loop ; + over [ drop ] recover dup sleep with-infinite-loop ; : start-irc ( irc-client -- ) ! [ [ do-irc ] curry 3000 with-infinite-loop ] with-scope ; diff --git a/extra/math/complex/complex-tests.factor b/extra/math/complex/complex-tests.factor index be512e5052..e8535d0637 100755 --- a/extra/math/complex/complex-tests.factor +++ b/extra/math/complex/complex-tests.factor @@ -2,8 +2,8 @@ USING: kernel math math.constants math.functions tools.test prettyprint ; IN: temporary -[ 1 C{ 0 1 } rect> ] unit-test-fails -[ C{ 0 1 } 1 rect> ] unit-test-fails +[ 1 C{ 0 1 } rect> ] must-fail +[ C{ 0 1 } 1 rect> ] must-fail [ f ] [ C{ 5 12.5 } 5 = ] unit-test [ t ] [ C{ 1.0 2.0 } C{ 1 2 } = ] unit-test diff --git a/extra/math/functions/functions-tests.factor b/extra/math/functions/functions-tests.factor index 439eaace6f..6f4dc42593 100755 --- a/extra/math/functions/functions-tests.factor +++ b/extra/math/functions/functions-tests.factor @@ -73,7 +73,7 @@ IN: temporary [ 3 ] [ 5 7 mod-inv ] unit-test [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test -[ 2 10 mod-inv ] unit-test-fails +[ 2 10 mod-inv ] must-fail [ t ] [ 0 0 ^ fp-nan? ] unit-test [ 1 ] [ 10 0 ^ ] unit-test diff --git a/extra/memoize/memoize-tests.factor b/extra/memoize/memoize-tests.factor index f5a7f85edb..dbd2d3a16a 100644 --- a/extra/memoize/memoize-tests.factor +++ b/extra/memoize/memoize-tests.factor @@ -7,4 +7,4 @@ MEMO: fib ( m -- n ) [ 89 ] [ 10 fib ] unit-test -[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] unit-test-fails +[ "USING: kernel math memoize ; MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index d2af88d02a..a0769dffda 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -52,7 +52,7 @@ METHOD: beats? { thing thing } f ; : play ( obj1 obj2 -- ? ) beats? 2nip ; -[ { } 3 play ] unit-test-fails +[ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test [ t ] [ T{ paper } T{ scissors } play ] unit-test diff --git a/extra/parser-combinators/parser-combinators-tests.factor b/extra/parser-combinators/parser-combinators-tests.factor index fc8cec770b..a1f82391a0 100644 --- a/extra/parser-combinators/parser-combinators-tests.factor +++ b/extra/parser-combinators/parser-combinators-tests.factor @@ -76,7 +76,7 @@ IN: scratchpad [ "begin1" "begin" token some parse -] unit-test-fails +] must-fail { "begin" } [ "begin" "begin" token some parse diff --git a/extra/regexp/regexp-tests.factor b/extra/regexp/regexp-tests.factor index 9c0ed5bd81..f6e7c05910 100755 --- a/extra/regexp/regexp-tests.factor +++ b/extra/regexp/regexp-tests.factor @@ -95,7 +95,7 @@ IN: regexp-tests [ t ] [ "]" "[]]" f matches? ] unit-test [ f ] [ "]" "[^]]" f matches? ] unit-test -! [ "^" "[^]" f matches? ] unit-test-fails +! [ "^" "[^]" f matches? ] must-fail [ t ] [ "^" "[]^]" f matches? ] unit-test [ t ] [ "]" "[]^]" f matches? ] unit-test diff --git a/extra/roman/roman-tests.factor b/extra/roman/roman-tests.factor index e850411726..a15dcef354 100644 --- a/extra/roman/roman-tests.factor +++ b/extra/roman/roman-tests.factor @@ -28,11 +28,11 @@ USING: arrays kernel math roman roman.private sequences tools.test ; [ 1666 ] [ 1666 >roman roman> ] unit-test [ 3444 ] [ 3444 >roman roman> ] unit-test [ 3999 ] [ 3999 >roman roman> ] unit-test -[ 0 >roman ] unit-test-fails -[ 4000 >roman ] unit-test-fails +[ 0 >roman ] must-fail +[ 4000 >roman ] must-fail [ "vi" ] [ "iii" "iii" roman+ ] unit-test [ "viii" ] [ "x" "ii" roman- ] unit-test [ "ix" ] [ "iii" "iii" roman* ] unit-test [ "i" ] [ "iii" "ii" roman/i ] unit-test [ "i" "ii" ] [ "v" "iii" roman/mod ] unit-test -[ "iii" "iii" roman- ] unit-test-fails +[ "iii" "iii" roman- ] must-fail diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 717f463c45..d0bc0a9e52 100644 --- a/extra/sequences/lib/lib-tests.factor +++ b/extra/sequences/lib/lib-tests.factor @@ -38,7 +38,7 @@ math.functions tools.test strings ; [ f ] [ { "asdf" "bsdf" } singleton? ] unit-test [ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test -[ V{ } [ delete-random drop ] keep length ] unit-test-fails +[ V{ } [ delete-random drop ] keep length ] must-fail [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test diff --git a/extra/tetris/board/board-tests.factor b/extra/tetris/board/board-tests.factor index 3a870e621e..bd8789c4d6 100644 --- a/extra/tetris/board/board-tests.factor +++ b/extra/tetris/board/board-tests.factor @@ -5,7 +5,7 @@ colors ; [ { { f f } { f f } { f f } } ] [ 2 3 board-rows ] unit-test [ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test [ f ] [ 2 3 { 1 1 } board-block ] unit-test -[ 2 3 { 2 3 } board-block ] unit-test-fails +[ 2 3 { 2 3 } board-block ] must-fail red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test [ t ] [ 2 3 { 1 1 } block-free? ] unit-test [ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test diff --git a/extra/tools/interpreter/interpreter-tests.factor b/extra/tools/interpreter/interpreter-tests.factor index 3976ada845..e7fe7854fa 100644 --- a/extra/tools/interpreter/interpreter-tests.factor +++ b/extra/tools/interpreter/interpreter-tests.factor @@ -99,7 +99,7 @@ IN: temporary [ [ [ 3 swap continue-with ] callcc1 2 * ] test-interpreter ] unit-test [ { 6 } ] -[ [ [ 3 throw ] catch 2 * ] test-interpreter ] unit-test +[ [ [ 3 throw ] [ 2 * ] recover ] test-interpreter ] unit-test [ { "{ 1 2 3 }\n" } ] [ [ [ { 1 2 3 } . ] string-out ] test-interpreter diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor index 17ff7e1acd..cc77f4910d 100755 --- a/extra/tools/test/inference/inference.factor +++ b/extra/tools/test/inference/inference.factor @@ -10,7 +10,6 @@ IN: tools.test.inference : unit-test-effect ( effect quot -- ) >r 1quotation r> [ infer short-effect ] curry unit-test ; -: must-infer ( word -- ) - dup "declared-effect" word-prop - dup effect-in length swap effect-out length 2array - swap 1quotation unit-test-effect ; +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index aa994e91d2..1037323ddb 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -42,6 +42,9 @@ M: expected-error summary : must-fail ( quot -- ) [ drop t ] must-fail-with ; +: ignore-errors ( quot -- ) + [ drop ] recover ; inline + : run-test ( path -- failures ) [ "temporary" forget-vocab ] with-compilation-unit [ diff --git a/extra/ui/tools/listener/listener-tests.factor b/extra/ui/tools/listener/listener-tests.factor index eab85209cc..56c90f760f 100755 --- a/extra/ui/tools/listener/listener-tests.factor +++ b/extra/ui/tools/listener/listener-tests.factor @@ -25,7 +25,7 @@ timers [ init-timers ] unless [ ] [ "SYMBOL:" "i" get set-editor-string ] unit-test [ ] [ - "i" get [ { "SYMBOL:" } parse-lines ] catch go-to-error + "i" get [ { "SYMBOL:" } parse-lines ] [ go-to-error ] recover ] unit-test [ t ] [ diff --git a/extra/xml/test/errors.factor b/extra/xml/test/errors.factor index 596f1e6c43..c0a60d8a3f 100644 --- a/extra/xml/test/errors.factor +++ b/extra/xml/test/errors.factor @@ -1,7 +1,7 @@ USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ; : xml-error-test ( expected-error xml-string -- ) - swap 1array >quotation swap [ [ string>xml ] catch nip ] curry unit-test ; + [ string>xml ] curry swap [ = ] curry must-fail-with ; T{ no-entity T{ parsing-error f 1 10 } "nbsp" } " " xml-error-test T{ mismatched T{ parsing-error f 1 8 } T{ name f "" "x" "" } T{ name f "" "y" "" } diff --git a/extra/xml/test/test.factor b/extra/xml/test/test.factor index ec59d3564e..0198ebacb7 100644 --- a/extra/xml/test/test.factor +++ b/extra/xml/test/test.factor @@ -17,7 +17,7 @@ SYMBOL: xml-file xml-file get T{ name f "" "this" "http://d.de" } swap at ] unit-test [ t ] [ xml-file get tag-children second contained-tag? ] unit-test -[ t ] [ [ "" string>xml ] catch xml-parse-error? ] unit-test +[ "" string>xml ] [ xml-parse-error? ] must-fail-with [ T{ comment f "This is where the fun begins!" } ] [ xml-file get xml-before [ comment? ] find nip ] unit-test From f7ca140c230af21ad26a00e0320f056783d56a6c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:51:16 -0600 Subject: [PATCH 063/194] Fix compiled-xref --- core/words/words.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/words/words.factor b/core/words/words.factor index f628d68bee..bd49a3d855 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -99,7 +99,7 @@ SYMBOL: compiled-crossref compiled-crossref global [ H{ } assoc-like ] change-at : compiled-xref ( word dependencies -- ) - [ crossref? ] subset + [ drop crossref? ] assoc-subset 2dup "compiled-uses" set-word-prop compiled-crossref get add-vertex* ; From 31b863f8b20da0a8850b2eabcafa0625ff13d035 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 13:51:23 -0600 Subject: [PATCH 064/194] Fix docs load error --- extra/tools/test/test-docs.factor | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) mode change 100644 => 100755 extra/tools/test/test-docs.factor diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor old mode 100644 new mode 100755 index 32825c965d..147e795861 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -10,7 +10,8 @@ $nl $nl "If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" { $subsection unit-test } -{ $subsection unit-test-fails } +{ $subsection must-fail } +{ $subsection must-fail-with } "The following words run test harness files; any test failures are collected and printed at the end:" { $subsection test } { $subsection test-all } ; @@ -21,7 +22,7 @@ HELP: unit-test { $values { "output" "a sequence of expected stack elements" } { "input" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, comparing the resulting stack with " { $snippet "output" } ". Elements are compared using " { $link = } ". Throws an error if the expected stack does not match the resulting stack." } ; -HELP: unit-test-fails +HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; From b18a4632852bee2b421c2e35df254e84e738d1f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 14:59:53 -0600 Subject: [PATCH 065/194] Better inlining heuristic --- core/compiler/test/optimizer.factor | 11 ++++++++++- core/compiler/test/redefine.factor | 2 +- core/optimizer/backend/backend.factor | 22 ++++++++++++++++++---- 3 files changed, 29 insertions(+), 6 deletions(-) diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 091648cbbc..7ee4ebfd1c 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -2,7 +2,7 @@ USING: arrays compiler generic hashtables inference kernel kernel.private math optimizer prettyprint sequences sbufs strings tools.test vectors words sequences.private quotations optimizer.backend classes inference.dataflow tuples.private -continuations ; +continuations growable ; IN: temporary [ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ @@ -291,3 +291,12 @@ TUPLE: silly-tuple a b ; : construct-empty-bug construct-empty ; [ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index e9927f4964..ab472668c3 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -235,7 +235,7 @@ DEFER: flushable-test-2 : bx ax ; [ \ bx forget ] with-compilation-unit -[ f ] [ \ bx \ ax compiled-usage contains? ] unit-test +[ f ] [ \ bx \ ax compiled-usage key? ] unit-test DEFER: defer-redefine-test-2 diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor index e73200b861..788f862849 100755 --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -245,18 +245,32 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; -: flat-length ( seq -- n ) +! A heuristic to avoid excessive inlining +DEFER: (flat-length) + +: word-flat-length ( word -- n ) + dup get over inline? not or + [ drop 1 ] [ dup dup set word-def (flat-length) ] if ; + +: (flat-length) ( seq -- n ) [ - dup quotation? over array? or - [ flat-length ] [ drop 1 ] if + { + { [ dup quotation? ] [ (flat-length) 1+ ] } + { [ dup array? ] [ (flat-length) ] } + { [ dup word? ] [ word-flat-length ] } + { [ t ] [ drop 1 ] } + } cond ] map sum ; +: flat-length ( seq -- n ) + [ word-def (flat-length) ] with-scope ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep method method-word - dup word-def flat-length 5 >= + dup flat-length 10 >= [ 1quotation ] [ word-def ] if ] [ 2drop t t From 8428f66933f1cfb9c20e818667b8ef36eb93b614 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 15:00:10 -0600 Subject: [PATCH 066/194] Fixing unit tests --- core/classes/classes-tests.factor | 6 ++++-- core/generic/generic-tests.factor | 2 +- core/inference/inference-tests.factor | 4 ++-- core/tuples/tuples-tests.factor | 2 +- core/vocabs/loader/loader-tests.factor | 17 +++++++---------- extra/combinators/lib/lib-tests.factor | 2 +- extra/tools/test/test.factor | 2 +- 7 files changed, 17 insertions(+), 18 deletions(-) diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index d78436bd5f..c7024a7490 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -169,8 +169,10 @@ UNION: redefine-bug-2 redefine-bug-1 quotation ; UNION: forget-class-bug-1 integer ; UNION: forget-class-bug-2 forget-class-bug-1 dll ; -FORGET: forget-class-bug-1 -FORGET: forget-class-bug-2 +[ + \ forget-class-bug-1 forget + \ forget-class-bug-2 forget +] with-compilation-unit [ f ] [ forget-class-bug-1 typemap get values [ memq? ] with contains? ] unit-test diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index e4d4160605..e3fdbc7b46 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -155,7 +155,7 @@ M: string my-hook "a string" ; [ "an integer" ] [ 3 my-var set my-hook ] unit-test [ "a string" ] [ my-hook my-var set my-hook ] unit-test -[ 1.0 my-var set my-hook ] [ [ T{ no-method f 1.0 my-hook } = ] must-fail-with +[ 1.0 my-var set my-hook ] [ T{ no-method f 1.0 my-hook } = ] must-fail-with GENERIC: tag-and-f ( x -- x x ) diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index 1738a71b7e..b43226166a 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -326,10 +326,10 @@ DEFER: bar : bad-bin ( a b -- ) 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] if ; [ [ bad-bin ] infer ] must-fail -[ [ [ r> ] infer ] [ inference-error? ] must-fail-with +[ [ r> ] infer ] [ inference-error? ] must-fail-with ! Regression -[ [ [ get-slots ] infer ] [ inference-error? ] must-fail-with +[ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff { 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect diff --git a/core/tuples/tuples-tests.factor b/core/tuples/tuples-tests.factor index dede1a2136..c9656a3b9e 100755 --- a/core/tuples/tuples-tests.factor +++ b/core/tuples/tuples-tests.factor @@ -123,7 +123,7 @@ TUPLE: yo-momma ; [ ] [ \ yo-momma forget ] unit-test [ f ] [ \ yo-momma typemap get values memq? ] unit-test - [ f ] [ \ yo-momma crossref ] unit-test + [ f ] [ \ yo-momma crossref get at ] unit-test ] with-compilation-unit TUPLE: loc-recording ; diff --git a/core/vocabs/loader/loader-tests.factor b/core/vocabs/loader/loader-tests.factor index 764f14e45f..3a8fc37583 100755 --- a/core/vocabs/loader/loader-tests.factor +++ b/core/vocabs/loader/loader-tests.factor @@ -63,14 +63,12 @@ IN: temporary [ 2 ] [ "count-me" get-global ] unit-test -[ t ] [ - [ - "IN: vocabs.loader.test.a v-l-t-a-hello" - - "resource:core/vocabs/loader/test/a/a.factor" - parse-stream - ] catch [ no-word? ] is? -] unit-test +[ + "IN: vocabs.loader.test.a v-l-t-a-hello" + + "resource:core/vocabs/loader/test/a/a.factor" + parse-stream +] [ [ no-word? ] is? ] must-fail-with 0 "count-me" set-global @@ -121,8 +119,7 @@ IN: temporary [ "kernel" vocab where ] unit-test [ t ] [ - [ "vocabs.loader.test.d" require ] catch - [ :1 ] when + [ "vocabs.loader.test.d" require ] [ :1 ] recover "vocabs.loader.test.d" vocab-source-loaded? ] unit-test diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 235f441b8b..20f52b2ea3 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test inference continuations arrays vectors ; +tools.test tools.test.inference continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 1037323ddb..9590f32539 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -37,7 +37,7 @@ M: expected-error summary : must-fail-with ( quot test -- ) >r [ expected-error construct-empty throw ] compose r> [ recover ] 2curry - [ ] swap unit-test ; + [ t ] swap unit-test ; : must-fail ( quot -- ) [ drop t ] must-fail-with ; From 90ed177a9c410eacdf6ddad3a09cf025bcae13fd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 19:23:39 -0600 Subject: [PATCH 067/194] Fixing load-everything and unit tests --- core/dlists/dlists.factor | 5 +++++ core/io/files/files-tests.factor | 3 ++- core/io/files/files.factor | 8 ++++++-- core/parser/parser-tests.factor | 8 ++++++++ core/parser/parser.factor | 10 +++++++--- core/vocabs/loader/loader.factor | 7 ++++--- extra/asn1/asn1-tests.factor | 4 ++-- extra/concurrency/concurrency-tests.factor | 2 ++ extra/concurrency/concurrency.factor | 2 +- extra/hardware-info/windows/ce/ce.factor | 16 ++++++++-------- extra/http/server/templating/templating.factor | 7 ++++--- extra/ldap/libldap/libldap.factor | 8 ++++---- extra/math/constants/constants-docs.factor | 4 ++-- extra/math/constants/constants.factor | 2 +- .../math/matrices/elimination/elimination.factor | 7 +++++-- extra/nehe/5/5.factor | 4 +++- extra/openssl/libcrypto/libcrypto.factor | 2 +- extra/openssl/openssl-tests.factor | 2 +- extra/openssl/openssl.factor | 2 +- .../partial-continuations.factor | 4 ++-- extra/random-tester/random-tester.factor | 6 +++--- extra/regexp/regexp.factor | 2 +- extra/serialize/serialize-tests.factor | 4 +--- extra/state-parser/state-parser-tests.factor | 2 +- extra/tuple-syntax/tuple-syntax-tests.factor | 1 + extra/tuple-syntax/tuple-syntax.factor | 9 +++++---- extra/ui/gadgets/editors/editors.factor | 6 +++--- extra/xmode/utilities/utilities-tests.factor | 4 ++-- 28 files changed, 86 insertions(+), 55 deletions(-) mode change 100644 => 100755 extra/concurrency/concurrency-tests.factor mode change 100644 => 100755 extra/concurrency/concurrency.factor mode change 100644 => 100755 extra/ldap/libldap/libldap.factor mode change 100644 => 100755 extra/nehe/5/5.factor mode change 100644 => 100755 extra/openssl/libcrypto/libcrypto.factor mode change 100644 => 100755 extra/openssl/openssl-tests.factor mode change 100644 => 100755 extra/openssl/openssl.factor mode change 100644 => 100755 extra/partial-continuations/partial-continuations.factor mode change 100644 => 100755 extra/random-tester/random-tester.factor mode change 100644 => 100755 extra/serialize/serialize-tests.factor mode change 100644 => 100755 extra/state-parser/state-parser-tests.factor mode change 100644 => 100755 extra/tuple-syntax/tuple-syntax-tests.factor mode change 100644 => 100755 extra/tuple-syntax/tuple-syntax.factor mode change 100644 => 100755 extra/xmode/utilities/utilities-tests.factor diff --git a/core/dlists/dlists.factor b/core/dlists/dlists.factor index ddec312182..12b1cd51ad 100755 --- a/core/dlists/dlists.factor +++ b/core/dlists/dlists.factor @@ -144,6 +144,11 @@ PRIVATE> : dlist-delete ( obj dlist -- obj/f ) >r [ eq? ] curry r> delete-node-if ; +: dlist-delete-all ( dlist -- ) + f over set-dlist-front + f over set-dlist-back + 0 swap set-dlist-length ; + : dlist-each ( dlist quot -- ) [ dlist-node-obj ] swap compose dlist-each-node ; inline diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index 5d4bb70912..bac9a2e65e 100755 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -2,7 +2,8 @@ IN: temporary USING: tools.test io.files io threads kernel continuations ; [ "passwd" ] [ "/etc/passwd" file-name ] unit-test -[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test +[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test [ ] [ "test-foo.txt" resource-path [ diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9a99090699..5d0cf6bf11 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -64,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ; normalize-directory dup (directory) fixup-directory ; : last-path-separator ( path -- n ? ) - [ length 2 [-] ] keep [ path-separator? ] find-last* ; + [ length 1- ] keep [ path-separator? ] find-last* ; TUPLE: no-parent-directory path ; @@ -83,7 +83,11 @@ TUPLE: no-parent-directory path ; } cond ; : file-name ( path -- string ) - dup last-path-separator [ 1+ tail ] [ drop ] if ; + right-trim-separators { + { [ dup empty? ] [ drop "/" ] } + { [ dup last-path-separator ] [ 1+ tail ] } + { [ t ] [ drop ] } + } cond ; : resource-path ( path -- newpath ) \ resource-path get [ image parent-directory ] unless* diff --git a/core/parser/parser-tests.factor b/core/parser/parser-tests.factor index eb04e329d9..c40bc54335 100755 --- a/core/parser/parser-tests.factor +++ b/core/parser/parser-tests.factor @@ -349,6 +349,14 @@ IN: temporary "IN: temporary : foo ; TUPLE: foo ;" "redefining-a-class-4" parse-stream drop ] [ [ redefine-error? ] is? ] must-fail-with + + [ ] [ + "IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval + ] unit-test + + [ + "IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval + ] must-fail ] with-file-vocabs [ diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 59d18dc734..d54bf1c1f4 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -307,10 +307,14 @@ SYMBOL: lexer-factory ! Parsing word utilities : parse-effect ( -- effect ) - ")" parse-tokens { "--" } split1 dup [ - + ")" parse-tokens "(" over member? [ + "Stack effect declaration must not contain (" throw ] [ - "Stack effect declaration must contain --" throw + { "--" } split1 dup [ + + ] [ + "Stack effect declaration must contain --" throw + ] if ] if ; TUPLE: bad-number ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 64372fe4b7..e42dace945 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -149,12 +149,14 @@ SYMBOL: load-help? dup modified-sources swap modified-docs ; : load-error. ( vocab error -- ) - "While loading " rot dup >vocab-link write-object ":" print - print-error ; + "==== " write >r + dup vocab-name swap f >vocab-link write-object ":" print nl + r> print-error ; TUPLE: require-all-error vocabs ; : require-all-error ( vocabs -- ) + [ vocab-name ] map \ require-all-error construct-boa throw ; M: require-all-error summary @@ -167,7 +169,6 @@ M: require-all-error summary [ [ require ] [ 2array , ] recover ] each ] { } make dup empty? [ drop ] [ - "==== LOAD ERRORS:" print dup [ nl load-error. ] assoc-each keys require-all-error ] if diff --git a/extra/asn1/asn1-tests.factor b/extra/asn1/asn1-tests.factor index 1c9bc79d76..329ba8256d 100755 --- a/extra/asn1/asn1-tests.factor +++ b/extra/asn1/asn1-tests.factor @@ -5,11 +5,11 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ; ] unit-test [ "testing" ] [ - "\u0004\u0007testing" [ asn-syntax read-ber ] with-stream + "\u000004\u000007testing" [ asn-syntax read-ber ] with-stream ] unit-test [ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [ - "0$\u0002\u0001\u0001`\u001f\u0002\u0001\u0003\u0004\rAdministrator\u0080\u000bad_is_bogus" + "0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus" [ asn-syntax read-ber ] with-stream ] unit-test diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor old mode 100644 new mode 100755 index 2f9b6605d7..b6f62d1779 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -6,6 +6,8 @@ namespaces tools.test continuations dlists strings math words match quotations concurrency.private ; IN: temporary +[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test + [ V{ 1 2 3 } ] [ 0 make-mailbox diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor old mode 100644 new mode 100755 index 8d842f15d0..cf44ab125c --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -73,7 +73,7 @@ PRIVATE> : mailbox-get?* ( pred mailbox timeout -- obj ) 2over >r >r (mailbox-block-unless-pred) r> r> - mailbox-data delete-node ; inline + mailbox-data delete-node-if ; inline : mailbox-get? ( pred mailbox -- obj ) f mailbox-get?* ; diff --git a/extra/hardware-info/windows/ce/ce.factor b/extra/hardware-info/windows/ce/ce.factor index 8923d86b03..f671ea9426 100755 --- a/extra/hardware-info/windows/ce/ce.factor +++ b/extra/hardware-info/windows/ce/ce.factor @@ -10,25 +10,25 @@ T{ wince-os } os set-global "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength [ GlobalMemoryStatus ] keep ; -M: wince cpus ( -- n ) 1 ; +M: wince-os cpus ( -- n ) 1 ; -M: wince memory-load ( -- n ) +M: wince-os memory-load ( -- n ) memory-status MEMORYSTATUS-dwMemoryLoad ; -M: wince physical-mem ( -- n ) +M: wince-os physical-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalPhys ; -M: wince available-mem ( -- n ) +M: wince-os available-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailPhys ; -M: wince total-page-file ( -- n ) +M: wince-os total-page-file ( -- n ) memory-status MEMORYSTATUS-dwTotalPageFile ; -M: wince available-page-file ( -- n ) +M: wince-os available-page-file ( -- n ) memory-status MEMORYSTATUS-dwAvailPageFile ; -M: wince total-virtual-mem ( -- n ) +M: wince-os total-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwTotalVirtual ; -M: wince available-virtual-mem ( -- n ) +M: wince-os available-virtual-mem ( -- n ) memory-status MEMORYSTATUS-dwAvailVirtual ; diff --git a/extra/http/server/templating/templating.factor b/extra/http/server/templating/templating.factor index f5de4664a1..dc83562600 100755 --- a/extra/http/server/templating/templating.factor +++ b/extra/http/server/templating/templating.factor @@ -32,17 +32,18 @@ M: template-lexer skip-word DEFER: <% delimiter : check-<% ( lexer -- col ) - "<%" over line-text rot lexer-column start* ; + "<%" over lexer-line-text rot lexer-column start* ; : found-<% ( accum lexer col -- accum ) [ - over line-text >r >r lexer-column r> r> subseq parsed + over lexer-line-text + >r >r lexer-column r> r> subseq parsed \ write-html parsed ] 2keep 2 + swap set-lexer-column ; : still-looking ( accum lexer -- accum ) [ - dup line-text swap lexer-column tail + dup lexer-line-text swap lexer-column tail parsed \ print-html parsed ] keep next-line ; diff --git a/extra/ldap/libldap/libldap.factor b/extra/ldap/libldap/libldap.factor old mode 100644 new mode 100755 index 6113fe5b7e..492aed1a54 --- a/extra/ldap/libldap/libldap.factor +++ b/extra/ldap/libldap/libldap.factor @@ -40,9 +40,9 @@ IN: ldap.libldap : LDAP_RES_UNSOLICITED 0 ; inline ! how many messages to retrieve results for -: LDAP_MSG_ONE HEX: 00 ; inline -: LDAP_MSG_ALL HEX: 01 ; inline -: LDAP_MSG_RECEIVED HEX: 02 ; inline +: LDAP_MSG_ONE HEX: 00 ; inline +: LDAP_MSG_ALL HEX: 01 ; inline +: LDAP_MSG_RECEIVED HEX: 02 ; inline ! the possible result types returned : LDAP_RES_BIND HEX: 61 ; inline @@ -71,7 +71,7 @@ IN: ldap.libldap { HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" } } ; -: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline +: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline C-STRUCT: ldap { "char" "ld_lberoptions" } diff --git a/extra/math/constants/constants-docs.factor b/extra/math/constants/constants-docs.factor index 653444376a..42cdf0e8f1 100755 --- a/extra/math/constants/constants-docs.factor +++ b/extra/math/constants/constants-docs.factor @@ -4,7 +4,7 @@ IN: math.constants ARTICLE: "math-constants" "Constants" "Standard mathematical constants:" { $subsection e } -{ $subsection gamma } +{ $subsection euler } { $subsection phi } { $subsection pi } "Various limits:" @@ -17,7 +17,7 @@ ABOUT: "math-constants" HELP: e { $values { "e" "base of natural logarithm" } } ; -HELP: gamma +HELP: euler { $values { "gamma" "Euler-Mascheroni constant" } } { $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ; diff --git a/extra/math/constants/constants.factor b/extra/math/constants/constants.factor index c4abeca0eb..c207eaa63c 100755 --- a/extra/math/constants/constants.factor +++ b/extra/math/constants/constants.factor @@ -3,7 +3,7 @@ IN: math.constants : e ( -- e ) 2.7182818284590452354 ; inline -: gamma ( -- gamma ) 0.57721566490153286060 ; inline +: euler ( -- gamma ) 0.57721566490153286060 ; inline : phi ( -- phi ) 1.61803398874989484820 ; inline : pi ( -- pi ) 3.14159265358979323846 ; inline : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor index 73f6dd7e96..8ac9771767 100755 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -1,7 +1,7 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.vectors math.matrices namespaces -sequences parser ; +sequences ; IN: math.matrices.elimination SYMBOL: matrix @@ -20,6 +20,9 @@ SYMBOL: matrix : cols ( -- n ) 0 nth-row length ; +: skip ( i seq quot -- n ) + over >r find* drop r> length or ; inline + : first-col ( row# -- n ) #! First non-zero column 0 swap nth-row [ zero? not ] skip ; diff --git a/extra/nehe/5/5.factor b/extra/nehe/5/5.factor old mode 100644 new mode 100755 index a792f04479..31a7d059ae --- a/extra/nehe/5/5.factor +++ b/extra/nehe/5/5.factor @@ -108,10 +108,12 @@ M: nehe5-gadget draw-gadget* ( gadget -- ) : nehe5-update-thread ( gadget -- ) dup nehe5-gadget-quit? [ + drop + ] [ redraw-interval sleep dup relayout-1 nehe5-update-thread - ] unless ; + ] if ; M: nehe5-gadget graft* ( gadget -- ) [ f swap set-nehe5-gadget-quit? ] keep diff --git a/extra/openssl/libcrypto/libcrypto.factor b/extra/openssl/libcrypto/libcrypto.factor old mode 100644 new mode 100755 index 52cb06f62e..8378a11956 --- a/extra/openssl/libcrypto/libcrypto.factor +++ b/extra/openssl/libcrypto/libcrypto.factor @@ -49,7 +49,7 @@ C-STRUCT: bio : BIO_CLOSE HEX: 01 ; inline : RSA_3 HEX: 3 ; inline -: RSA_F4 HEX: 10001 ; inline +: RSA_F4 HEX: 10001 ; inline : BIO_C_SET_SSL 109 ; inline : BIO_C_GET_SSL 110 ; inline diff --git a/extra/openssl/openssl-tests.factor b/extra/openssl/openssl-tests.factor old mode 100644 new mode 100755 index f4576dca19..c40bc5628b --- a/extra/openssl/openssl-tests.factor +++ b/extra/openssl/openssl-tests.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types assocs bit-arrays hashtables io io.files io.sockets kernel mirrors openssl.libcrypto openssl.libssl -namespaces math math.parser openssl prettyprint sequences tools.test unix ; +namespaces math math.parser openssl prettyprint sequences tools.test ; ! ========================================================= ! Some crypto functions (still to be turned into words) diff --git a/extra/openssl/openssl.factor b/extra/openssl/openssl.factor old mode 100644 new mode 100755 index 3b5474ea9f..bfa7f32594 --- a/extra/openssl/openssl.factor +++ b/extra/openssl/openssl.factor @@ -4,7 +4,7 @@ ! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC USING: alien alien.c-types assocs kernel libc namespaces -openssl.libcrypto openssl.libssl sequences unix ; +openssl.libcrypto openssl.libssl sequences ; IN: openssl diff --git a/extra/partial-continuations/partial-continuations.factor b/extra/partial-continuations/partial-continuations.factor old mode 100644 new mode 100755 index 0dce7c2390..b80e3a9ddb --- a/extra/partial-continuations/partial-continuations.factor +++ b/extra/partial-continuations/partial-continuations.factor @@ -6,7 +6,7 @@ USING: kernel continuations arrays sequences quotations ; : breset ( quot -- ) [ 1array swap keep first continue-with ] callcc1 nip ; -: (bshift) ( v r k -- ) +: (bshift) ( v r k -- obj ) >r dup first -rot r> [ rot set-first @@ -19,4 +19,4 @@ USING: kernel continuations arrays sequences quotations ; over >r [ (bshift) ] 2curry swap call r> first continue-with - ] callcc1 2nip ; + ] callcc1 2nip ; inline diff --git a/extra/random-tester/random-tester.factor b/extra/random-tester/random-tester.factor old mode 100644 new mode 100755 index c3a1ecbec4..8704687e34 --- a/extra/random-tester/random-tester.factor +++ b/extra/random-tester/random-tester.factor @@ -17,9 +17,9 @@ TUPLE: random-tester-error ; : test-compiler ! ( data... quot -- ... ) errored off dup quot set - datastack clone >vector dup pop* before set - [ call ] catch drop - datastack clone after set + datastack 1 head* before set + [ call ] [ drop ] recover + datastack after set clear before get [ ] each quot get [ compile-call ] [ errored on ] recover ; diff --git a/extra/regexp/regexp.factor b/extra/regexp/regexp.factor index ef88e84f05..fe1d87d9e9 100755 --- a/extra/regexp/regexp.factor +++ b/extra/regexp/regexp.factor @@ -77,7 +77,7 @@ PRIVATE> : 'hex' ( -- parser ) "x" token 'hex-digit' 2 exactly-n &> - "u" token 'hex-digit' 4 exactly-n &> <|> + "u" token 'hex-digit' 6 exactly-n &> <|> [ hex> ] <@ ; : satisfy-tokens ( assoc -- parser ) diff --git a/extra/serialize/serialize-tests.factor b/extra/serialize/serialize-tests.factor old mode 100644 new mode 100755 index a713840a20..e0ecb5393a --- a/extra/serialize/serialize-tests.factor +++ b/extra/serialize/serialize-tests.factor @@ -10,8 +10,6 @@ TUPLE: serialize-test a b ; C: serialize-test -: CURRY< \ > parse-until first2 curry parsed ; parsing - : objects { f @@ -33,7 +31,7 @@ C: serialize-test B{ 50 13 55 64 1 } ?{ t f t f f t f } F{ 1.0 3.0 4.0 1.0 2.35 0.33 } - CURRY< 1 [ 2 ] > + << 1 [ 2 ] curry parsed >> { { "a" "bc" } { "de" "fg" } } H{ { "a" "bc" } { "de" "fg" } } } ; diff --git a/extra/state-parser/state-parser-tests.factor b/extra/state-parser/state-parser-tests.factor old mode 100644 new mode 100755 index ff8ac91513..4e1ecaddfc --- a/extra/state-parser/state-parser-tests.factor +++ b/extra/state-parser/state-parser-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test state-parser kernel io strings ; +USING: tools.test state-parser kernel io strings ascii ; [ "hello" ] [ "hello" [ rest ] string-parse ] unit-test [ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test diff --git a/extra/tuple-syntax/tuple-syntax-tests.factor b/extra/tuple-syntax/tuple-syntax-tests.factor old mode 100644 new mode 100755 index b16c5b337d..0a9711c446 --- a/extra/tuple-syntax/tuple-syntax-tests.factor +++ b/extra/tuple-syntax/tuple-syntax-tests.factor @@ -1,4 +1,5 @@ USING: tools.test tuple-syntax ; +IN: temporary TUPLE: foo bar baz ; diff --git a/extra/tuple-syntax/tuple-syntax.factor b/extra/tuple-syntax/tuple-syntax.factor old mode 100644 new mode 100755 index 6082f529ac..2f0ba6bde5 --- a/extra/tuple-syntax/tuple-syntax.factor +++ b/extra/tuple-syntax/tuple-syntax.factor @@ -1,4 +1,5 @@ -USING: kernel sequences slots parser words classes ; +USING: kernel sequences slots parser words classes +slots.private ; IN: tuple-syntax ! TUPLE: foo bar baz ; @@ -7,15 +8,15 @@ IN: tuple-syntax : parse-object ( -- object ) scan-word dup parsing? [ V{ } clone swap execute first ] when ; -: parse-slot-writer ( tuple -- slot-setter ) +: parse-slot-writer ( tuple -- slot# ) scan dup "}" = [ 2drop f ] [ 1 head* swap class "slots" word-prop - [ slot-spec-name = ] with find nip slot-spec-writer + [ slot-spec-name = ] with find nip slot-spec-offset ] if ; : parse-slots ( accum tuple -- accum tuple ) dup parse-slot-writer - [ parse-object pick rot execute parse-slots ] when* ; + [ parse-object pick rot set-slot parse-slots ] when* ; : TUPLE{ scan-word construct-empty parse-slots parsed ; parsing diff --git a/extra/ui/gadgets/editors/editors.factor b/extra/ui/gadgets/editors/editors.factor index 00b574f853..e2df6a343b 100755 --- a/extra/ui/gadgets/editors/editors.factor +++ b/extra/ui/gadgets/editors/editors.factor @@ -249,11 +249,11 @@ M: editor gadget-text* editor-string % ; : extend-selection ( editor -- ) dup request-focus dup editor-caret click-loc ; -: mouse-elt ( -- elelement ) +: mouse-elt ( -- element ) hand-click# get { + { 1 T{ one-char-elt } } { 2 T{ one-word-elt } } - { 3 T{ one-line-elt } } - } at T{ one-char-elt } or ; + } at T{ one-line-elt } or ; : drag-direction? ( loc editor -- ? ) editor-mark* <=> 0 < ; diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor old mode 100644 new mode 100755 index 89cb588336..713700bf7a --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -1,6 +1,6 @@ IN: temporary -USING: xmode.utilities tools.test xml xml.data -kernel strings vectors sequences io.files prettyprint assocs ; +USING: xmode.utilities tools.test xml xml.data kernel strings +vectors sequences io.files prettyprint assocs unicode.case ; [ "hi" 3 ] [ { 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find From 2a417f4a9c79f02fa1af909337c2e669910cf42b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 19:36:53 -0600 Subject: [PATCH 068/194] add with-file-in with-file-out with-file-appender --- core/io/files/files.factor | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/core/io/files/files.factor b/core/io/files/files.factor index 9a99090699..8c9bd8f2e9 100755 --- a/core/io/files/files.factor +++ b/core/io/files/files.factor @@ -169,3 +169,12 @@ PRIVATE> : file-contents ( path -- str ) dup swap file-length [ stream-copy ] keep >string ; + +: with-file-in ( path quot -- ) + >r r> with-stream ; inline + +: with-file-out ( path quot -- ) + >r r> with-stream ; inline + +: with-file-appender ( path quot -- ) + >r r> with-stream ; inline From 99411495c2eaa5e4a6a7501cf8c3dbed2bed80b7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 19:49:07 -0600 Subject: [PATCH 069/194] add http-update to work around firewalls --- misc/factor.sh | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/misc/factor.sh b/misc/factor.sh index 26ebd04531..f0eb232821 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -200,6 +200,12 @@ git_pull_factorcode() { check_ret git } +http_git_pull_factorcode() { + echo "Updating the git repository from factorcode.org..." + git pull http://factorcode.org/git/factor.git master + check_ret git +} + cd_factor() { cd factor check_ret cd @@ -271,6 +277,7 @@ install() { bootstrap } + update() { get_config_info git_pull_factorcode @@ -278,6 +285,13 @@ update() { make_factor } +http_update() { + get_config_info + http_git_pull_factorcode + make_clean + make_factor +} + update_bootstrap() { delete_boot_images get_boot_image @@ -310,6 +324,7 @@ case "$1" in self-update) update; make_boot_image; bootstrap;; quick-update) update; refresh_image ;; update) update; update_bootstrap ;; + http-update) http_update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; From 5f997fe2c7c5c071a0f7975170daa6d9f4256aef Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 20:04:09 -0600 Subject: [PATCH 070/194] Make extra/unix load on Windows --- extra/unix/unix.factor | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index d32fc25eab..59141c1940 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -220,7 +220,8 @@ FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; { - { [ linux? ] [ "unix.linux" ] } - { [ bsd? ] [ "unix.bsd" ] } - { [ solaris? ] [ "unix.solaris" ] } -} cond require + { [ linux? ] [ "unix.linux" require ] } + { [ bsd? ] [ "unix.bsd" require ] } + { [ solaris? ] [ "unix.solaris" require ] } + { [ t ] [ ] } +} cond From 93eb74476e776f044283ce61354852037a5c0cb1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 6 Feb 2008 20:04:46 -0600 Subject: [PATCH 071/194] add with-file-in docs, update a couple of usages --- core/io/files/files-docs.factor | 15 +++++++++++++++ extra/tar/tar.factor | 5 ++--- extra/tools/browser/browser.factor | 4 ++-- 3 files changed, 19 insertions(+), 5 deletions(-) diff --git a/core/io/files/files-docs.factor b/core/io/files/files-docs.factor index 0b9a748eb8..99f2d42542 100755 --- a/core/io/files/files-docs.factor +++ b/core/io/files/files-docs.factor @@ -52,6 +52,21 @@ HELP: { $description "Outputs an output stream for writing to the specified pathname. The stream begins writing at the end of the file." } { $errors "Throws an error if the file cannot be opened for writing." } ; +HELP: with-file-in +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for reading and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file is unreadable." } ; + +HELP: with-file-out +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for writing and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + +HELP: with-file-appender +{ $values { "path" "a pathname string" } { "quot" "a quotation" } } +{ $description "Opens a file for appending and calls the quotation using " { $link with-stream } "." } +{ $errors "Throws an error if the file cannot be opened for writing." } ; + HELP: cwd { $values { "path" "a pathname string" } } { $description "Outputs the current working directory of the Factor process." } diff --git a/extra/tar/tar.factor b/extra/tar/tar.factor index 20e997185d..e15d9511a3 100755 --- a/extra/tar/tar.factor +++ b/extra/tar/tar.factor @@ -236,10 +236,9 @@ TUPLE: unimplemented-typeflag header ; ] when* ; : parse-tar ( path -- obj ) - [ + [ "tar-test" resource-path base-dir set global [ nl nl nl "Starting to parse .tar..." print flush ] bind global [ "Expanding to: " write base-dir get . flush ] bind (parse-tar) - ] with-stream ; - + ] with-file-out ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..167c238069 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -10,7 +10,7 @@ IN: tools.browser MEMO: (vocab-file-contents) ( path -- lines ) ?resource-path dup exists? - [ lines ] [ drop f ] if ; + [ file-lines ] [ drop f ] if ; : vocab-file-contents ( vocab name -- seq ) vocab-path+ dup [ (vocab-file-contents) ] when ; @@ -18,7 +18,7 @@ MEMO: (vocab-file-contents) ( path -- lines ) : set-vocab-file-contents ( seq vocab name -- ) dupd vocab-path+ [ ?resource-path - [ [ print ] each ] with-stream + [ [ print ] each ] with-file-out ] [ "The " swap vocab-name " vocabulary was not loaded from the file system" From f3c8bd266b0300a920fd8896372177504aa6984c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 20:05:03 -0600 Subject: [PATCH 072/194] Improved syntax for ratios --- core/math/parser/parser-tests.factor | 10 --- core/math/parser/parser.factor | 89 ++++++++++++++++++--------- extra/math/ratios/ratios-tests.factor | 5 ++ extra/math/ratios/ratios.factor | 1 + 4 files changed, 66 insertions(+), 39 deletions(-) diff --git a/core/math/parser/parser-tests.factor b/core/math/parser/parser-tests.factor index 7c30012a19..226e47090a 100755 --- a/core/math/parser/parser-tests.factor +++ b/core/math/parser/parser-tests.factor @@ -95,16 +95,6 @@ unit-test [ f ] [ "\0." string>number ] unit-test -! [ t ] [ -! { "1.0/0.0" "-1.0/0.0" "0.0/0.0" } -! [ dup string>number number>string = ] all? -! ] unit-test -! -! [ t ] [ -! { 1.0/0.0 -1.0/0.0 0.0/0.0 } -! [ dup number>string string>number = ] all? -! ] unit-test - [ 1 1 >base ] must-fail [ 1 0 >base ] must-fail [ 1 -1 >base ] must-fail diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 7f0404812d..73b4a725d2 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -4,12 +4,6 @@ USING: kernel math.private namespaces sequences strings arrays combinators splitting math assocs ; IN: math.parser -DEFER: base> - -: string>ratio ( str radix -- a/b ) - >r "/" split1 r> tuck base> >r base> r> - 2dup and [ / ] [ 2drop f ] if ; - : digit> ( ch -- n ) H{ { CHAR: 0 0 } @@ -36,30 +30,54 @@ DEFER: base> { CHAR: f 15 } } at ; -: digits>integer ( radix seq -- n ) - 0 rot [ swapd * + ] curry reduce ; - -: valid-digits? ( radix seq -- ? ) - { - { [ dup empty? ] [ 2drop f ] } - { [ f over memq? ] [ 2drop f ] } - { [ t ] [ swap [ < ] curry all? ] } - } cond ; - : string>digits ( str -- digits ) [ digit> ] { } map-as ; -: string>integer ( str radix -- n/f ) - swap "-" ?head >r - string>digits 2dup valid-digits? - [ digits>integer r> [ neg ] when ] [ r> 3drop f ] if ; +DEFER: base> + +) ( str -- n ) radix get base> ; + +: whole-part ( str -- m n ) + "+" split1 >r (base>) r> + dup [ (base>) ] [ drop 0 swap ] if ; + +: string>ratio ( str -- a/b ) + "/" split1 (base>) >r whole-part r> + 3dup and and [ / + ] [ 3drop f ] if ; + +: digits>integer ( seq -- n ) + 0 radix get [ swapd * + ] curry reduce ; + +: valid-digits? ( seq -- ? ) + { + { [ dup empty? ] [ drop f ] } + { [ f over memq? ] [ drop f ] } + { [ t ] [ radix get [ < ] curry all? ] } + } cond ; + +: string>integer ( str -- n/f ) + string>digits dup valid-digits? + [ digits>integer ] [ drop f ] if ; + +PRIVATE> : base> ( str radix -- n/f ) - { - { [ CHAR: / pick member? ] [ string>ratio ] } - { [ CHAR: . pick member? ] [ drop string>float ] } - { [ t ] [ string>integer ] } - } cond ; + [ + "-" ?head >r + { + { [ CHAR: / over member? ] [ string>ratio ] } + { [ CHAR: . over member? ] [ string>float ] } + { [ t ] [ string>integer ] } + } cond + r> [ dup [ neg ] when ] when + ] with-radix ; : string>number ( str -- n/f ) 10 base> ; : bin> ( str -- n/f ) 2 base> ; @@ -74,8 +92,16 @@ DEFER: base> dup >r /mod >digit , dup 0 > [ r> integer, ] [ r> 2drop ] if ; +PRIVATE> + GENERIC# >base 1 ( n radix -- str ) +base) ( n -- str ) radix get >base ; + +PRIVATE> + M: integer >base [ over 0 < [ @@ -87,10 +113,15 @@ M: integer >base M: ratio >base [ - over numerator over >base % - CHAR: / , - swap denominator swap >base % - ] "" make ; + [ + dup 0 < [ "-" % neg ] when + 1 /mod + >r dup zero? [ drop ] [ (>base) % "+" % ] if r> + dup numerator (>base) % + "/" % + denominator (>base) % + ] "" make + ] with-radix ; : fix-float ( str -- newstr ) { diff --git a/extra/math/ratios/ratios-tests.factor b/extra/math/ratios/ratios-tests.factor index 79b0b21d28..858a7b0544 100755 --- a/extra/math/ratios/ratios-tests.factor +++ b/extra/math/ratios/ratios-tests.factor @@ -105,3 +105,8 @@ unit-test [ "33/100" ] [ "66/200" string>number number>string ] unit-test + +[ 3 ] [ "1+1/2" string>number 2 * ] unit-test +[ -3 ] [ "-1+1/2" string>number 2 * ] unit-test +[ "2+1/7" ] [ 1 7 / 2 + number>string ] unit-test +[ "1/8" ] [ 1 8 / number>string ] unit-test diff --git a/extra/math/ratios/ratios.factor b/extra/math/ratios/ratios.factor index 954fd8dd20..5d07bd046f 100755 --- a/extra/math/ratios/ratios.factor +++ b/extra/math/ratios/ratios.factor @@ -48,3 +48,4 @@ M: ratio * 2>fraction * >r * r> / ; M: ratio / scale / ; M: ratio /i scale /i ; M: ratio mod 2dup >r >r /i r> r> rot * - ; +M: ratio /mod [ /i ] 2keep mod ; From 01b1ba0f88836a6543b8b17a8cb83ae0f0cc4c23 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 6 Feb 2008 20:05:52 -0600 Subject: [PATCH 073/194] Temporarily use onigirihouse as the primary --- extra/builder/builder.factor | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 2acdbc3294..5bfd5e01cf 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,7 +69,8 @@ VAR: stamp "git" "pull" "--no-summary" - "git://factorcode.org/git/factor.git" + ! "git://factorcode.org/git/factor.git" + "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status From 7534d84d2769fa7d83a78dfa9ec00bca79db38b5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:15:33 -0600 Subject: [PATCH 074/194] Refactor tools.test --- extra/tools/test/test.factor | 41 +++++++++++++++++++++--------------- 1 file changed, 24 insertions(+), 17 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 9590f32539..d761df35d2 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,35 +61,42 @@ M: expected-error summary dup first print-error "Traceback" swap third write-object ; -: failures. ( path failures -- ) - "Failing tests in " write swap . - [ nl failure. nl ] each ; - -: run-tests ( seq -- ) - dup empty? [ drop "==== NOTHING TO TEST" print ] [ - [ dup run-test ] { } map>assoc - [ second empty? not ] subset +: failures. ( assoc -- ) + dup [ nl dup empty? [ drop "==== ALL TESTS PASSED" print ] [ "==== FAILING TESTS:" print - [ nl failures. ] assoc-each + [ + nl + "Failing tests in " write swap . + [ nl failure. nl ] each + ] assoc-each ] if + ] [ + drop "==== NOTHING TO TEST" print ] if ; -: run-vocab-tests ( vocabs -- ) - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - run-tests ; +: run-vocab-tests ( vocabs -- failures ) + dup empty? [ f ] [ + [ dup run-test ] { } map>assoc + [ second empty? not ] subset + ] if ; -: test ( prefix -- ) +: run-tests ( prefix -- failures ) child-vocabs [ vocab-source-loaded? ] subset + [ vocab-tests-path ] map + [ dup [ ?resource-path exists? ] when ] subset run-vocab-tests ; -: test-all ( -- ) "" test ; +: test ( prefix -- ) + run-tests failures. ; -: test-changes ( -- ) - "" to-refresh dupd do-refresh run-vocab-tests ; +: run-all-tests ( prefix -- failures ) + "" run-tests ; + +: test-all ( -- ) + run-all-tests failures. ; From 2541c62e291ad04de93fadbac7514820bcae657c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:15:47 -0600 Subject: [PATCH 075/194] Fix code for math.parser changes --- core/math/parser/parser.factor | 8 ++++---- core/syntax/syntax-docs.factor | 4 +++- extra/json/reader/reader.factor | 2 +- extra/math/ratios/ratios-docs.factor | 1 + extra/math/text/english/english.factor | 2 +- extra/parser-combinators/simple/simple.factor | 2 +- extra/peg/peg.factor | 2 +- extra/project-euler/024/024.factor | 2 +- extra/project-euler/032/032.factor | 10 +++++----- extra/project-euler/035/035.factor | 2 +- extra/project-euler/037/037.factor | 2 +- extra/project-euler/038/038.factor | 2 +- extra/project-euler/040/040.factor | 2 +- extra/random-tester/safe-words/safe-words.factor | 2 +- 14 files changed, 23 insertions(+), 20 deletions(-) mode change 100644 => 100755 extra/json/reader/reader.factor mode change 100644 => 100755 extra/math/text/english/english.factor mode change 100644 => 100755 extra/peg/peg.factor mode change 100644 => 100755 extra/project-euler/024/024.factor mode change 100644 => 100755 extra/project-euler/032/032.factor mode change 100644 => 100755 extra/project-euler/035/035.factor mode change 100644 => 100755 extra/project-euler/037/037.factor mode change 100644 => 100755 extra/project-euler/038/038.factor mode change 100644 => 100755 extra/project-euler/040/040.factor mode change 100644 => 100755 extra/random-tester/safe-words/safe-words.factor diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index 73b4a725d2..64ce296a0b 100755 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -33,6 +33,9 @@ IN: math.parser : string>digits ( str -- digits ) [ digit> ] { } map-as ; +: digits>integer ( seq radix -- n ) + 0 swap [ swapd * + ] curry reduce ; + DEFER: base> ) >r whole-part r> 3dup and and [ / + ] [ 3drop f ] if ; -: digits>integer ( seq -- n ) - 0 radix get [ swapd * + ] curry reduce ; - : valid-digits? ( seq -- ? ) { { [ dup empty? ] [ drop f ] } @@ -64,7 +64,7 @@ SYMBOL: radix : string>integer ( str -- n/f ) string>digits dup valid-digits? - [ digits>integer ] [ drop f ] if ; + [ radix get digits>integer ] [ drop f ] if ; PRIVATE> diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 2e5b41cd8d..9ccfd2efcd 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -47,11 +47,13 @@ ARTICLE: "syntax-integers" "Integer syntax" "More information on integers can be found in " { $link "integers" } "." ; ARTICLE: "syntax-ratios" "Ratio syntax" -"The printed representation of a ratio is a pair of integers separated by a slash (/). No intermediate whitespace is permitted. Either integer may be signed, however the ratio will be normalized into a form where the denominator is positive and the greatest common divisor of the two terms is 1." +"The printed representation of a ratio is a pair of integers separated by a slash (/), prefixed by an optional whole number part followed by a plus (+). No intermediate whitespace is permitted. Here are some examples:" { $code "75/33" "1/10" "-5/-6" + "1+1/3" + "-10+1/7" } "More information on ratios can be found in " { $link "rationals" } ; diff --git a/extra/json/reader/reader.factor b/extra/json/reader/reader.factor old mode 100644 new mode 100755 index 105989ab93..b136012433 --- a/extra/json/reader/reader.factor +++ b/extra/json/reader/reader.factor @@ -104,7 +104,7 @@ LAZY: 'digit1-9' ( -- parser ) LAZY: 'digit0-9' ( -- parser ) [ digit? ] satisfy [ digit> ] <@ ; -: decimal>integer ( seq -- num ) 10 swap digits>integer ; +: decimal>integer ( seq -- num ) 10 digits>integer ; LAZY: 'int' ( -- parser ) 'zero' diff --git a/extra/math/ratios/ratios-docs.factor b/extra/math/ratios/ratios-docs.factor index d996acaf1f..b780a7c322 100755 --- a/extra/math/ratios/ratios-docs.factor +++ b/extra/math/ratios/ratios-docs.factor @@ -7,6 +7,7 @@ ARTICLE: "rationals" "Rational numbers" "When we add, subtract or multiply any two integers, the result is always an integer. However, dividing a numerator by a denominator that is not an integral divisor of the denominator yields a ratio:" { $example "1210 11 / ." "110" } { $example "100 330 / ." "10/33" } +{ $example "14 10 / ." "1+2/5" } "Ratios are printed and can be input literally in the form above. Ratios are always reduced to lowest terms by factoring out the greatest common divisor of the numerator and denominator. A ratio with a denominator of 1 becomes an integer. Division with a denominator of 0 throws an error." $nl "Ratios behave just like any other number -- all numerical operations work as you would expect." diff --git a/extra/math/text/english/english.factor b/extra/math/text/english/english.factor old mode 100644 new mode 100755 index 645d7e2054..b77ac725ab --- a/extra/math/text/english/english.factor +++ b/extra/math/text/english/english.factor @@ -33,7 +33,7 @@ SYMBOL: and-needed? : 3digit-groups ( n -- seq ) number>string 3 - [ reverse 10 string>integer ] map ; + [ reverse string>number ] map ; : hundreds-place ( n -- str ) 100 /mod swap dup zero? [ diff --git a/extra/parser-combinators/simple/simple.factor b/extra/parser-combinators/simple/simple.factor index 763f823348..745442610c 100755 --- a/extra/parser-combinators/simple/simple.factor +++ b/extra/parser-combinators/simple/simple.factor @@ -8,7 +8,7 @@ IN: parser-combinators.simple [ digit? ] satisfy [ digit> ] <@ ; : 'integer' ( -- parser ) - 'digit' [ 10 swap digits>integer ] <@ ; + 'digit' [ 10 digits>integer ] <@ ; : 'string' ( -- parser ) [ CHAR: " = ] satisfy diff --git a/extra/peg/peg.factor b/extra/peg/peg.factor old mode 100644 new mode 100755 index 41df8735e5..59a8b63c14 --- a/extra/peg/peg.factor +++ b/extra/peg/peg.factor @@ -343,7 +343,7 @@ MEMO: 'digit' ( -- parser ) [ digit? ] satisfy [ digit> ] action ; MEMO: 'integer' ( -- parser ) - 'digit' repeat1 [ 10 swap digits>integer ] action ; + 'digit' repeat1 [ 10 digits>integer ] action ; MEMO: 'string' ( -- parser ) [ diff --git a/extra/project-euler/024/024.factor b/extra/project-euler/024/024.factor old mode 100644 new mode 100755 index c795fc0169..0cc0c39e07 --- a/extra/project-euler/024/024.factor +++ b/extra/project-euler/024/024.factor @@ -23,7 +23,7 @@ IN: project-euler.024 ! -------- : euler024 ( -- answer ) - 999999 10 permutation 10 swap digits>integer ; + 999999 10 permutation 10 digits>integer ; ! [ euler024 ] 100 ave-time ! 0 ms run / 0 ms GC ave time - 100 trials diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor old mode 100644 new mode 100755 index 2baa6f8714..b8b0758974 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -27,21 +27,21 @@ IN: project-euler.032 integer ] map ; + 9 factorial [ 9 permutation [ 1+ ] map 10 digits>integer ] map ; : 1and4 ( n -- ? ) number>string 1 cut-slice 4 cut-slice - [ 10 string>integer ] 3apply [ * ] dip = ; + [ string>number ] 3apply [ * ] dip = ; : 2and3 ( n -- ? ) number>string 2 cut-slice 3 cut-slice - [ 10 string>integer ] 3apply [ * ] dip = ; + [ string>number ] 3apply [ * ] dip = ; : valid? ( n -- ? ) dup 1and4 swap 2and3 or ; : products ( seq -- m ) - [ number>string 4 tail* 10 string>integer ] map ; + [ number>string 4 tail* string>number ] map ; PRIVATE> @@ -65,7 +65,7 @@ PRIVATE> ! multiplicand/multiplier/product : mmp ( pair -- n ) - first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; + first2 2dup * [ number>string ] 3apply 3append string>number ; PRIVATE> diff --git a/extra/project-euler/035/035.factor b/extra/project-euler/035/035.factor old mode 100644 new mode 100755 index 867bbc44ac..29172111c1 --- a/extra/project-euler/035/035.factor +++ b/extra/project-euler/035/035.factor @@ -38,7 +38,7 @@ IN: project-euler.035 : (circular?) ( seq n -- ? ) dup 0 > [ - 2dup rotate 10 swap digits>integer + 2dup rotate 10 digits>integer prime? [ 1- (circular?) ] [ 2drop f ] if ] [ 2drop t diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor old mode 100644 new mode 100755 index f2d5d17c4d..66b1665037 --- a/extra/project-euler/037/037.factor +++ b/extra/project-euler/037/037.factor @@ -32,7 +32,7 @@ IN: project-euler.037 ] if ; : reverse-digits ( n -- m ) - number>string reverse 10 string>integer ; + number>string reverse string>number ; : l-trunc? ( n -- ? ) reverse-digits 10 /i reverse-digits dup 0 > [ diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor old mode 100644 new mode 100755 index cbe6f2363c..2369db25fb --- a/extra/project-euler/038/038.factor +++ b/extra/project-euler/038/038.factor @@ -36,7 +36,7 @@ IN: project-euler.038 : (concat-product) ( accum n multiplier -- m ) pick length 8 > [ - 2drop 10 swap digits>integer + 2drop 10 digits>integer ] [ [ * number>digits over push-all ] 2keep 1+ (concat-product) ] if ; diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor old mode 100644 new mode 100755 index 8984559265..e2df1df2c9 --- a/extra/project-euler/040/040.factor +++ b/extra/project-euler/040/040.factor @@ -37,7 +37,7 @@ IN: project-euler.040 SBUF" " clone 1 -rot (concat-upto) ; : nth-integer ( n str -- m ) - [ 1- ] dip nth 1string 10 string>integer ; + [ 1- ] dip nth 1string string>number ; PRIVATE> diff --git a/extra/random-tester/safe-words/safe-words.factor b/extra/random-tester/safe-words/safe-words.factor old mode 100644 new mode 100755 index 9bc87a9c5a..ab528786bb --- a/extra/random-tester/safe-words/safe-words.factor +++ b/extra/random-tester/safe-words/safe-words.factor @@ -16,7 +16,7 @@ IN: random-tester.safe-words array? integer? complex? value-ref? ref? key-ref? interval? number? wrapper? tuple? - [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? valid-digits? zero? assoc? curry? vector? callstack? ! clear 3.14 [ assoc? ] compile-1 + [-1,1]? between? bignum? both? either? eq? equal? even? fixnum? float? fp-nan? hashtable? interval-contains? interval-subset? interval? key-ref? key? number? odd? pair? power-of-2? ratio? rational? real? subassoc? zero? assoc? curry? vector? callstack? ! clear 3.14 [ assoc? ] compile-1 2^ not ! arrays resize-array From c1dd7cf855c2f863c44f4d8cb0877e3f854f525c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 21:16:52 -0600 Subject: [PATCH 076/194] Fix Doug's bug --- extra/ui/tools/operations/operations.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ui/tools/operations/operations.factor b/extra/ui/tools/operations/operations.factor index 2375730a81..fbb4338b17 100755 --- a/extra/ui/tools/operations/operations.factor +++ b/extra/ui/tools/operations/operations.factor @@ -188,7 +188,7 @@ source-editor "These commands operate on the Factor word named by the token at the caret position." \ selected-word [ selected-word ] -[ search ] +[ dup search [ ] [ no-word ] ?if ] define-operation-map interactor From 9271da5070370a0ea4e2c2bada37ddf0bc53c408 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 22:12:44 -0600 Subject: [PATCH 077/194] More cleanups to require-all and unit tests --- core/vocabs/loader/loader.factor | 23 ++++++++++++----- extra/tools/test/test.factor | 44 ++++++++++++++++---------------- 2 files changed, 39 insertions(+), 28 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index e42dace945..352ef9fe02 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -148,10 +148,17 @@ SYMBOL: load-help? dup update-roots dup modified-sources swap modified-docs ; -: load-error. ( vocab error -- ) - "==== " write >r - dup vocab-name swap f >vocab-link write-object ":" print nl - r> print-error ; +: vocab-heading. ( vocab -- ) + nl + "==== " write + dup vocab-name swap f >vocab-link write-object ":" print + nl ; + +: load-error. ( triple -- ) + dup first vocab-heading. + dup second print-error + drop ; + ! third "Traceback" swap write-object ; TUPLE: require-all-error vocabs ; @@ -166,10 +173,14 @@ M: require-all-error summary dup length 1 = [ first require ] [ [ [ - [ [ require ] [ 2array , ] recover ] each + [ + [ require ] + [ error-continuation get 3array , ] + recover + ] each ] { } make dup empty? [ drop ] [ - dup [ nl load-error. ] assoc-each + dup [ load-error. nl ] each keys require-all-error ] if ] with-compiler-errors diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index d761df35d2..09d497aac7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -11,7 +11,8 @@ SYMBOL: failures : ( error what -- triple ) error-continuation get 3array ; -: failure ( error what -- ) failures get push ; +: failure ( error what -- ) + failures get push ; SYMBOL: this-test @@ -45,16 +46,23 @@ M: expected-error summary : ignore-errors ( quot -- ) [ drop ] recover ; inline -: run-test ( path -- failures ) - [ "temporary" forget-vocab ] with-compilation-unit - [ - V{ } clone [ - failures [ - [ run-file ] [ swap failure ] recover - ] with-variable - ] keep - ] keep - [ forget-source ] with-compilation-unit ; +: (run-test) ( vocab -- ) + dup vocab-source-loaded? [ + vocab-tests-path dup [ + dup ?resource-path exists? [ + [ "temporary" forget-vocab ] with-compilation-unit + dup run-file + [ dup forget-source ] with-compilation-unit + ] when + ] when + ] when drop ; + +: run-test ( vocab -- failures ) + V{ } clone [ + failures [ + (run-test) + ] with-variable + ] keep ; : failure. ( triple -- ) dup second . @@ -70,8 +78,7 @@ M: expected-error summary ] [ "==== FAILING TESTS:" print [ - nl - "Failing tests in " write swap . + swap vocab-heading. [ nl failure. nl ] each ] assoc-each ] if @@ -79,19 +86,12 @@ M: expected-error summary drop "==== NOTHING TO TEST" print ] if ; -: run-vocab-tests ( vocabs -- failures ) - dup empty? [ f ] [ +: run-tests ( prefix -- failures ) + child-vocabs dup empty? [ f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; -: run-tests ( prefix -- failures ) - child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - run-vocab-tests ; - : test ( prefix -- ) run-tests failures. ; From 5ecf3f722587f95232485c21949b9983bdf549fa Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 6 Feb 2008 22:58:41 -0600 Subject: [PATCH 078/194] Improve unit test documentation and update some tests --- core/bootstrap/image/image-tests.factor | 3 +- core/compiler/test/alien.factor | 6 +- core/compiler/test/redefine.factor | 8 +- core/inference/inference-docs.factor | 11 +- core/inference/inference-tests.factor | 115 +++++++++--------- .../transforms/transforms-tests.factor | 2 +- extra/combinators/lib/lib-tests.factor | 2 +- extra/io/launcher/launcher-tests.factor | 2 +- extra/io/server/server-tests.factor | 4 +- extra/tools/test/test-docs.factor | 77 ++++++++++-- extra/tools/test/test.factor | 17 ++- extra/ui/gadgets/books/books-tests.factor | 2 +- extra/ui/gadgets/buttons/buttons-tests.factor | 3 +- extra/ui/gadgets/editors/editors-tests.factor | 5 +- extra/ui/gadgets/gadgets-tests.factor | 2 +- .../gadgets/scrollers/scrollers-tests.factor | 2 +- extra/ui/tools/browser/browser-tests.factor | 3 +- .../tools/interactor/interactor-tests.factor | 2 +- extra/ui/tools/walker/walker-tests.factor | 2 +- .../ui/tools/workspace/workspace-tests.factor | 2 +- 20 files changed, 172 insertions(+), 98 deletions(-) mode change 100644 => 100755 extra/io/server/server-tests.factor diff --git a/core/bootstrap/image/image-tests.factor b/core/bootstrap/image/image-tests.factor index ea533f0d6f..8c618a8f30 100755 --- a/core/bootstrap/image/image-tests.factor +++ b/core/bootstrap/image/image-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: bootstrap.image bootstrap.image.private -tools.test.inference ; +USING: bootstrap.image bootstrap.image.private tools.test ; \ ' must-infer \ write-image must-infer diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index dbdbbfc9fa..4adb1c234b 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -3,7 +3,7 @@ USING: alien alien.c-types alien.syntax compiler kernel namespaces namespaces tools.test sequences inference words arrays parser quotations continuations inference.backend effects namespaces.private io io.streams.string memory system threads -tools.test.inference ; +tools.test ; FUNCTION: void ffi_test_0 ; [ ] [ ffi_test_0 ] unit-test @@ -80,7 +80,7 @@ FUNCTION: tiny ffi_test_17 int x ; : indirect-test-1 "int" { } "cdecl" alien-indirect ; -{ 1 1 } [ indirect-test-1 ] unit-test-effect +{ 1 1 } [ indirect-test-1 ] must-infer-as [ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test @@ -89,7 +89,7 @@ FUNCTION: tiny ffi_test_17 int x ; : indirect-test-2 "int" { "int" "int" } "cdecl" alien-indirect data-gc ; -{ 3 1 } [ indirect-test-2 ] unit-test-effect +{ 3 1 } [ indirect-test-2 ] must-infer-as [ 5 ] [ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine.factor index ab472668c3..9eaf2d1263 100755 --- a/core/compiler/test/redefine.factor +++ b/core/compiler/test/redefine.factor @@ -1,6 +1,6 @@ USING: compiler definitions generic assocs inference math namespaces parser tools.test words kernel sequences arrays io -effects tools.test.inference compiler.units inference.state ; +effects tools.test compiler.units inference.state ; IN: temporary DEFER: x-1 @@ -28,13 +28,13 @@ DEFER: c [ 1 2 1 2 ] [ "USE: temporary b" eval ] unit-test -{ 0 4 } [ b ] unit-test-effect +{ 0 4 } [ b ] must-infer-as [ ] [ "IN: temporary : a 1 2 3 ;" eval ] unit-test [ 1 2 3 1 2 3 ] [ "USE: temporary b" eval ] unit-test -{ 0 6 } [ b ] unit-test-effect +{ 0 6 } [ b ] must-infer-as \ b word-xt "b-xt" set @@ -52,7 +52,7 @@ DEFER: c [ ] [ "IN: temporary : a 1 2 ;" eval ] unit-test -{ 0 4 } [ c ] unit-test-effect +{ 0 4 } [ c ] must-infer-as [ f ] [ "c-xt" get \ c word-xt = ] unit-test diff --git a/core/inference/inference-docs.factor b/core/inference/inference-docs.factor index 5f7e926b6a..68e5920a3d 100755 --- a/core/inference/inference-docs.factor +++ b/core/inference/inference-docs.factor @@ -73,6 +73,12 @@ $nl { $subsection infer-quot-value } "The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; +ARTICLE: "dataflow-graphs" "Inspecting the dataflow graph" +"The dataflow graph used by " { $link "compiler" } " can be obtained:" +{ $subsection dataflow } +"The " { $vocab-link "optimizer.debugger" } " tool prints the dataflow graph in human readable form." +$nl ; + ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the compiler to build a dataflow graph on which optimizations can be performed. Only words for which a stack effect can be inferred will compile." $nl @@ -80,14 +86,15 @@ $nl { $subsection infer. } "Instead of printing the inferred information, it can be returned as objects on the stack:" { $subsection infer } -"The dataflow graph used by " { $link "compiler" } " can be obtained:" -{ $subsection dataflow } +"Static stack effect inference can be combined with unit tests; see " { $link "tools.test.write" } "." +$nl "The following articles describe the implementation of the stack effect inference algorithm:" { $subsection "inference-simple" } { $subsection "inference-combinators" } { $subsection "inference-branches" } { $subsection "inference-recursive" } { $subsection "inference-limitations" } +{ $subsection "dataflow-graphs" } { $subsection "compiler-transforms" } ; ABOUT: "inference" diff --git a/core/inference/inference-tests.factor b/core/inference/inference-tests.factor index b43226166a..c5bc3b5fda 100755 --- a/core/inference/inference-tests.factor +++ b/core/inference/inference-tests.factor @@ -4,23 +4,22 @@ math.parser math.private namespaces namespaces.private parser sequences strings vectors words quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector tuples classes.union classes.predicate -debugger threads.private io.streams.string combinators.private -tools.test.inference ; +debugger threads.private io.streams.string combinators.private ; IN: temporary -{ 0 2 } [ 2 "Hello" ] unit-test-effect -{ 1 2 } [ dup ] unit-test-effect +{ 0 2 } [ 2 "Hello" ] must-infer-as +{ 1 2 } [ dup ] must-infer-as -{ 1 2 } [ [ dup ] call ] unit-test-effect +{ 1 2 } [ [ dup ] call ] must-infer-as [ [ call ] infer ] must-fail -{ 2 4 } [ 2dup ] unit-test-effect +{ 2 4 } [ 2dup ] must-infer-as -{ 1 0 } [ [ ] [ ] if ] unit-test-effect +{ 1 0 } [ [ ] [ ] if ] must-infer-as [ [ if ] infer ] must-fail [ [ [ ] if ] infer ] must-fail [ [ [ 2 ] [ ] if ] infer ] must-fail -{ 4 3 } [ [ rot ] [ -rot ] if ] unit-test-effect +{ 4 3 } [ [ rot ] [ -rot ] if ] must-infer-as { 4 3 } [ [ @@ -28,17 +27,17 @@ IN: temporary ] [ -rot ] if -] unit-test-effect +] must-infer-as -{ 1 1 } [ dup [ ] when ] unit-test-effect -{ 1 1 } [ dup [ dup fixnum* ] when ] unit-test-effect -{ 2 1 } [ [ dup fixnum* ] when ] unit-test-effect +{ 1 1 } [ dup [ ] when ] must-infer-as +{ 1 1 } [ dup [ dup fixnum* ] when ] must-infer-as +{ 2 1 } [ [ dup fixnum* ] when ] must-infer-as -{ 1 0 } [ [ drop ] when* ] unit-test-effect -{ 1 1 } [ [ { { [ ] } } ] unless* ] unit-test-effect +{ 1 0 } [ [ drop ] when* ] must-infer-as +{ 1 1 } [ [ { { [ ] } } ] unless* ] must-infer-as { 0 1 } -[ [ 2 2 fixnum+ ] dup [ ] when call ] unit-test-effect +[ [ 2 2 fixnum+ ] dup [ ] when call ] must-infer-as [ [ [ [ 2 2 fixnum+ ] ] [ [ 2 2 fixnum* ] ] if call ] infer @@ -50,7 +49,7 @@ IN: temporary : termination-test-2 [ termination-test-1 ] [ 3 ] if ; -{ 1 1 } [ termination-test-2 ] unit-test-effect +{ 1 1 } [ termination-test-2 ] must-infer-as : infinite-loop infinite-loop ; @@ -62,12 +61,12 @@ IN: temporary : simple-recursion-1 ( obj -- obj ) dup [ simple-recursion-1 ] [ ] if ; -{ 1 1 } [ simple-recursion-1 ] unit-test-effect +{ 1 1 } [ simple-recursion-1 ] must-infer-as : simple-recursion-2 ( obj -- obj ) dup [ ] [ simple-recursion-2 ] if ; -{ 1 1 } [ simple-recursion-2 ] unit-test-effect +{ 1 1 } [ simple-recursion-2 ] must-infer-as : bad-recursion-2 ( obj -- obj ) dup [ dup first swap second bad-recursion-2 ] [ ] if ; @@ -77,10 +76,10 @@ IN: temporary : funny-recursion ( obj -- obj ) dup [ funny-recursion 1 ] [ 2 ] if drop ; -{ 1 1 } [ funny-recursion ] unit-test-effect +{ 1 1 } [ funny-recursion ] must-infer-as ! Simple combinators -{ 1 2 } [ [ first ] keep second ] unit-test-effect +{ 1 2 } [ [ first ] keep second ] must-infer-as ! Mutual recursion DEFER: foe @@ -103,8 +102,8 @@ DEFER: foe 2drop f ] if ; -{ 2 1 } [ fie ] unit-test-effect -{ 2 1 } [ foe ] unit-test-effect +{ 2 1 } [ fie ] must-infer-as +{ 2 1 } [ foe ] must-infer-as : nested-when ( -- ) t [ @@ -113,7 +112,7 @@ DEFER: foe ] when ] when ; -{ 0 0 } [ nested-when ] unit-test-effect +{ 0 0 } [ nested-when ] must-infer-as : nested-when* ( obj -- ) [ @@ -122,11 +121,11 @@ DEFER: foe ] when* ] when* ; -{ 1 0 } [ nested-when* ] unit-test-effect +{ 1 0 } [ nested-when* ] must-infer-as SYMBOL: sym-test -{ 0 1 } [ sym-test ] unit-test-effect +{ 0 1 } [ sym-test ] must-infer-as : terminator-branch dup [ @@ -135,7 +134,7 @@ SYMBOL: sym-test "foo" throw ] if ; -{ 1 1 } [ terminator-branch ] unit-test-effect +{ 1 1 } [ terminator-branch ] must-infer-as : recursive-terminator ( obj -- ) dup [ @@ -144,7 +143,7 @@ SYMBOL: sym-test "Hi" throw ] if ; -{ 1 0 } [ recursive-terminator ] unit-test-effect +{ 1 0 } [ recursive-terminator ] must-infer-as GENERIC: potential-hang ( obj -- obj ) M: fixnum potential-hang dup [ potential-hang ] when ; @@ -157,24 +156,24 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -{ 1 0 } [ iterate ] unit-test-effect +{ 1 0 } [ iterate ] must-infer-as ! Regression : cat ( obj -- * ) dup [ throw ] [ throw ] if ; : dog ( a b c -- ) dup [ cat ] [ 3drop ] if ; -{ 3 0 } [ dog ] unit-test-effect +{ 3 0 } [ dog ] must-infer-as ! Regression DEFER: monkey : friend ( a b c -- ) dup [ friend ] [ monkey ] if ; : monkey ( a b c -- ) dup [ 3drop ] [ friend ] if ; -{ 3 0 } [ friend ] unit-test-effect +{ 3 0 } [ friend ] must-infer-as ! Regression -- same as above but we infer the second word first DEFER: blah2 : blah ( a b c -- ) dup [ blah ] [ blah2 ] if ; : blah2 ( a b c -- ) dup [ blah ] [ 3drop ] if ; -{ 3 0 } [ blah2 ] unit-test-effect +{ 3 0 } [ blah2 ] must-infer-as ! Regression DEFER: blah4 @@ -182,7 +181,7 @@ DEFER: blah4 dup [ blah3 ] [ dup [ blah4 ] [ blah3 ] if ] if ; : blah4 ( a b c -- ) dup [ blah4 ] [ dup [ 3drop ] [ blah3 ] if ] if ; -{ 3 0 } [ blah4 ] unit-test-effect +{ 3 0 } [ blah4 ] must-infer-as ! Regression : bad-combinator ( obj quot -- ) @@ -199,7 +198,7 @@ DEFER: blah4 dup string? [ 2array throw ] unless over string? [ 2array throw ] unless ; -{ 2 2 } [ bad-input# ] unit-test-effect +{ 2 2 } [ bad-input# ] must-infer-as ! Regression @@ -218,7 +217,7 @@ DEFER: do-crap* ! Regression : too-deep ( a b -- c ) dup [ drop ] [ 2dup too-deep too-deep * ] if ; inline -{ 2 1 } [ too-deep ] unit-test-effect +{ 2 1 } [ too-deep ] must-infer-as ! Error reporting is wrong MATH: xyz @@ -258,17 +257,17 @@ DEFER: C [ dup B C ] } dispatch ; -{ 1 0 } [ A ] unit-test-effect -{ 1 0 } [ B ] unit-test-effect -{ 1 0 } [ C ] unit-test-effect +{ 1 0 } [ A ] must-infer-as +{ 1 0 } [ B ] must-infer-as +{ 1 0 } [ C ] must-infer-as ! I found this bug by thinking hard about the previous one DEFER: Y : X ( a b -- c d ) dup [ swap Y ] [ ] if ; : Y ( a b -- c d ) X ; -{ 2 2 } [ X ] unit-test-effect -{ 2 2 } [ Y ] unit-test-effect +{ 2 2 } [ X ] must-infer-as +{ 2 2 } [ Y ] must-infer-as ! This one comes from UI code DEFER: #1 @@ -332,9 +331,9 @@ DEFER: bar [ [ get-slots ] infer ] [ inference-error? ] must-fail-with ! Test some curry stuff -{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] unit-test-effect +{ 1 1 } [ 3 [ ] curry 4 [ ] curry if ] must-infer-as -{ 2 1 } [ [ ] curry 4 [ ] curry if ] unit-test-effect +{ 2 1 } [ [ ] curry 4 [ ] curry if ] must-infer-as [ [ 3 [ ] curry 1 2 [ ] 2curry if ] infer ] must-fail @@ -381,7 +380,7 @@ DEFER: bar \ assoc-like must-infer \ assoc-clone-like must-infer \ >alist must-infer -{ 1 3 } [ [ 2drop f ] assoc-find ] unit-test-effect +{ 1 3 } [ [ 2drop f ] assoc-find ] must-infer-as ! Test some random library words \ 1quotation must-infer @@ -404,10 +403,10 @@ DEFER: bar \ define-predicate-class must-infer ! Test words with continuations -{ 0 0 } [ [ drop ] callcc0 ] unit-test-effect -{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] unit-test-effect -{ 2 1 } [ [ + ] [ ] [ ] cleanup ] unit-test-effect -{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] unit-test-effect +{ 0 0 } [ [ drop ] callcc0 ] must-infer-as +{ 0 1 } [ [ 4 swap continue-with ] callcc1 ] must-infer-as +{ 2 1 } [ [ + ] [ ] [ ] cleanup ] must-infer-as +{ 2 1 } [ [ + ] [ 3drop 0 ] recover ] must-infer-as \ dispose must-infer @@ -450,13 +449,13 @@ DEFER: bar [ [ barxxx ] infer ] must-fail ! A typo -{ 1 0 } [ { [ ] } dispatch ] unit-test-effect +{ 1 0 } [ { [ ] } dispatch ] must-infer-as DEFER: inline-recursive-2 : inline-recursive-1 ( -- ) inline-recursive-2 ; : inline-recursive-2 ( -- ) inline-recursive-1 ; -{ 0 0 } [ inline-recursive-1 ] unit-test-effect +{ 0 0 } [ inline-recursive-1 ] must-infer-as ! Hooks SYMBOL: my-var @@ -465,22 +464,22 @@ HOOK: my-hook my-var ( -- x ) M: integer my-hook "an integer" ; M: string my-hook "a string" ; -{ 0 1 } [ my-hook ] unit-test-effect +{ 0 1 } [ my-hook ] must-infer-as DEFER: deferred-word : calls-deferred-word [ deferred-word ] [ 3 ] if ; -{ 1 1 } [ calls-deferred-word ] unit-test-effect +{ 1 1 } [ calls-deferred-word ] must-infer-as USE: inference.dataflow -{ 1 0 } [ [ iterate-next ] iterate-nodes ] unit-test-effect +{ 1 0 } [ [ iterate-next ] iterate-nodes ] must-infer-as { 1 0 } [ [ [ iterate-next ] iterate-nodes ] with-node-iterator -] unit-test-effect +] must-infer-as : nilpotent ( quot -- ) t [ [ call ] keep nilpotent ] [ drop ] if ; inline @@ -490,11 +489,11 @@ USE: inference.dataflow { 0 1 } [ [ ] [ call ] keep [ [ call ] keep ] nilpotent ] -unit-test-effect +must-infer-as -{ 0 0 } [ [ ] semisimple ] unit-test-effect +{ 0 0 } [ [ ] semisimple ] must-infer-as -{ 1 0 } [ [ drop ] each-node ] unit-test-effect +{ 1 0 } [ [ drop ] each-node ] must-infer-as DEFER: an-inline-word @@ -510,9 +509,9 @@ DEFER: an-inline-word : an-inline-word ( obj quot -- ) >r normal-word r> call ; inline -{ 1 1 } [ [ 3 * ] an-inline-word ] unit-test-effect +{ 1 1 } [ [ 3 * ] an-inline-word ] must-infer-as -{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] unit-test-effect +{ 0 1 } [ [ 2 ] [ 2 ] [ + ] compose compose call ] must-infer-as TUPLE: custom-error ; @@ -536,4 +535,4 @@ TUPLE: custom-error ; ! This was a false trigger of the undecidable quotation ! recursion bug -{ 2 1 } [ find-last-sep ] unit-test-effect +{ 2 1 } [ find-last-sep ] must-infer-as diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index f58e557b10..0e5c3e231e 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: sequences inference.transforms tools.test math kernel -quotations tools.test.inference inference ; +quotations inference ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 20f52b2ea3..24d70a86c6 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -1,5 +1,5 @@ USING: combinators.lib kernel math math.ranges random sequences -tools.test tools.test.inference continuations arrays vectors ; +tools.test continuations arrays vectors ; IN: temporary [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test diff --git a/extra/io/launcher/launcher-tests.factor b/extra/io/launcher/launcher-tests.factor index b9f8f3e061..6705caa33c 100755 --- a/extra/io/launcher/launcher-tests.factor +++ b/extra/io/launcher/launcher-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test tools.test.inference io.launcher ; +USING: tools.test io.launcher ; \ must-infer diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor old mode 100644 new mode 100755 index 5c37a37380..776bc4b429 --- a/extra/io/server/server-tests.factor +++ b/extra/io/server/server-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test.inference io.server ; +USING: tools.test io.server ; -{ 1 0 } [ [ ] spawn-server ] unit-test-effect +{ 1 0 } [ [ ] spawn-server ] must-infer-as diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index 147e795861..c027073398 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -1,6 +1,36 @@ -USING: help.markup help.syntax kernel ; +USING: help.markup help.syntax kernel quotations io ; IN: tools.test +ARTICLE: "tools.test.write" "Writing unit tests" +"Assert that a quotation outputs a specific set of values:" +{ $subsection unit-test } +"Assert that a quotation throws an error:" +{ $subsection must-fail } +{ $subsection must-fail-with } +"Assert that a quotation or word has a specific static stack effect (see " { $link "inference" } "):" +{ $subsection must-infer } +{ $subsection must-infer-as } ; + +ARTICLE: "tools.test.run" "Running unit tests" +"The following words run test harness files; any test failures are collected and printed at the end:" +{ $subsection test } +{ $subsection test-all } ; + +ARTICLE: "tools.test.failure" "Handling test failures" +"Most of the time the words documented in " { $link "tools.test.run" } " are used because they print all test failures in human-readable form. Sometimes, you want to develop a tool which inspects the test failures and takes some kind of action instead; one example is " { $vocab-link "builder" } "." +$nl +"The following words output an association list mapping vocabulary names to sequences of failures; a failure is an array having the shape " { $snippet "{ error test continuation }" } ", and the elements are as follows:" +{ $list + { { $snippet "error" } " - the error thrown by the unit test" } + { { $snippet "test" } " - a pair " { $snippet "{ output input }" } " containing expected output and a unit test quotation which didn't produce this output" } + { { $snippet "continuation" } " - the traceback at the point of the error" } +} +"The following words run test harness files and output failures:" +{ $subsection run-tests } +{ $subsection run-all-tests } +"The following word prints failures:" +{ $subsection failures. } ; + ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." $nl @@ -8,13 +38,10 @@ $nl $nl "Unit tests for a vocabulary are placed in test files, named " { $snippet { $emphasis "vocab" } "-tests.factor" } " alongside " { $snippet { $emphasis "vocab" } ".factor" } "; see " { $link "vocabs.loader" } " for details." $nl -"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run. Test harness files consist mostly of calls to the following two words:" -{ $subsection unit-test } -{ $subsection must-fail } -{ $subsection must-fail-with } -"The following words run test harness files; any test failures are collected and printed at the end:" -{ $subsection test } -{ $subsection test-all } ; +"If the test harness needs to define words, they should be placed in the " { $snippet "temporary" } " vocabulary so that they can be forgotten after the tests have been run." +{ $subsection "tools.test.write" } +{ $subsection "tools.test.run" } +{ $subsection "tools.test.failure" } ; ABOUT: "tools.test" @@ -26,3 +53,37 @@ HELP: must-fail { $values { "quot" "a quotation run with an empty stack" } } { $description "Runs a quotation with an empty stack, expecting it to throw an error. If the quotation throws an error, this word returns normally. If the quotation does not throw an error, this word " { $emphasis "does" } " raise an error." } { $notes "This word is used to test boundary conditions and fail-fast behavior." } ; + +HELP: must-fail-with +{ $values { "quot" "a quotation run with an empty stack" } { "pred" "a quotation with stack effect " { $snippet "( error -- ? )" } } } +{ $description "Runs a quotation with an empty stack, expecting it to throw an error which must satisfy " { $snippet "pred" } ". If the quotation does not throw an error, or if the error does not match the predicate, the unit test fails." } +{ $notes "This word is used to test error handling code, ensuring that errors thrown by code contain the relevant debugging information." } ; + +HELP: must-infer +{ $values { "word/quot" "a quotation or a word" } } +{ $description "Ensures that the quotation or word has a static stack effect without running it." } +{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; + +HELP: must-infer-as +{ $values { "effect" "a pair with shape " { $snippet "{ inputs outputs }" } } { "quot" quotation } } +{ $description "Ensures that the quotation has the indicated stack effect without running it." } +{ $notes "This word is used to test that code will compile with the optimizing compiler for optimum performance. See " { $link "compiler" } "." } ; + +HELP: test +{ $values { "prefix" "a vocabulary name" } } +{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies." } ; + +HELP: run-tests +{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $description "Runs unit tests for the vocabulary named " { $snippet "prefix" } " and all of its child vocabularies. Outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; + +HELP: test-all +{ $description "Runs unit tests for all loaded vocabularies." } ; + +HELP: run-all-tests +{ $values { "prefix" "a vocabulary name" } { "failures" "an association list of unit test failures" } } +{ $description "Runs unit tests for all loaded vocabularies and outputs unit test failures as documented in " { $link "tools.test.failure" } "." } ; + +HELP: failure. +{ $values { "failures" "an association list of unit test failures" } } +{ $description "Prints unit test failures output by " { $link run-tests } " or " { $link run-all-tests } " to the " { $link stdio } " stream." } ; diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 09d497aac7..0b1a495e90 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -3,7 +3,8 @@ USING: namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.files vocabs tools.time -vocabs.loader source-files compiler.units inspector ; +vocabs.loader source-files compiler.units inspector +inference effects ; IN: tools.test SYMBOL: failures @@ -29,13 +30,23 @@ SYMBOL: this-test { } swap with-datastack swap >array assert= ] 2curry (unit-test) ; +: short-effect ( effect -- pair ) + dup effect-in length swap effect-out length 2array ; + +: must-infer-as ( effect quot -- ) + >r 1quotation r> [ infer short-effect ] curry unit-test ; + +: must-infer ( word/quot -- ) + dup word? [ 1quotation ] when + [ infer drop ] curry [ ] swap unit-test ; + TUPLE: expected-error ; M: expected-error summary drop "The unit test expected the quotation to throw an error" ; -: must-fail-with ( quot test -- ) +: must-fail-with ( quot pred -- ) >r [ expected-error construct-empty throw ] compose r> [ recover ] 2curry [ t ] swap unit-test ; @@ -60,7 +71,7 @@ M: expected-error summary : run-test ( vocab -- failures ) V{ } clone [ failures [ - (run-test) + [ (run-test) ] [ swap failure ] recover ] with-variable ] keep ; diff --git a/extra/ui/gadgets/books/books-tests.factor b/extra/ui/gadgets/books/books-tests.factor index 35016e1669..9e1b0aa985 100755 --- a/extra/ui/gadgets/books/books-tests.factor +++ b/extra/ui/gadgets/books/books-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test.inference ui.gadgets.books ; +USING: tools.test ui.gadgets.books ; \ must-infer diff --git a/extra/ui/gadgets/buttons/buttons-tests.factor b/extra/ui/gadgets/buttons/buttons-tests.factor index 77dfd30d96..224ef9e1ce 100755 --- a/extra/ui/gadgets/buttons/buttons-tests.factor +++ b/extra/ui/gadgets/buttons/buttons-tests.factor @@ -1,7 +1,6 @@ IN: temporary USING: ui.commands ui.gadgets.buttons ui.gadgets.labels -ui.gadgets tools.test namespaces sequences kernel models -tools.test.inference ; +ui.gadgets tools.test namespaces sequences kernel models ; TUPLE: foo-gadget ; diff --git a/extra/ui/gadgets/editors/editors-tests.factor b/extra/ui/gadgets/editors/editors-tests.factor index bc302c1a09..f3a6b9fd5d 100755 --- a/extra/ui/gadgets/editors/editors-tests.factor +++ b/extra/ui/gadgets/editors/editors-tests.factor @@ -1,7 +1,6 @@ USING: ui.gadgets.editors tools.test kernel io io.streams.plain -definitions namespaces ui.gadgets -ui.gadgets.grids prettyprint documents ui.gestures -tools.test.inference tools.test.ui models ; +definitions namespaces ui.gadgets ui.gadgets.grids prettyprint +documents ui.gestures tools.test.ui models ; [ "foo bar" ] [ "editor" set diff --git a/extra/ui/gadgets/gadgets-tests.factor b/extra/ui/gadgets/gadgets-tests.factor index 81b30559df..1e27744f33 100755 --- a/extra/ui/gadgets/gadgets-tests.factor +++ b/extra/ui/gadgets/gadgets-tests.factor @@ -1,6 +1,6 @@ IN: temporary USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test -namespaces models kernel tools.test.inference dlists math +namespaces models kernel dlists math math.parser ui sequences hashtables assocs io arrays prettyprint io.streams.string ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 30ba4a18f3..dd667fdfec 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -3,7 +3,7 @@ USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test kernel models ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences -tools.test.inference tools.test.ui ; +tools.test.ui ; [ ] [ "g" set diff --git a/extra/ui/tools/browser/browser-tests.factor b/extra/ui/tools/browser/browser-tests.factor index 3102ad1bd9..7262c72756 100755 --- a/extra/ui/tools/browser/browser-tests.factor +++ b/extra/ui/tools/browser/browser-tests.factor @@ -1,6 +1,5 @@ IN: temporary -USING: tools.test tools.test.ui ui.tools.browser -tools.test.inference ; +USING: tools.test tools.test.ui ui.tools.browser ; \ must-infer [ ] [ [ ] with-grafted-gadget ] unit-test diff --git a/extra/ui/tools/interactor/interactor-tests.factor b/extra/ui/tools/interactor/interactor-tests.factor index bf9de10a1e..0422c4170a 100755 --- a/extra/ui/tools/interactor/interactor-tests.factor +++ b/extra/ui/tools/interactor/interactor-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: ui.tools.interactor tools.test.inference ; +USING: ui.tools.interactor tools.test ; \ must-infer diff --git a/extra/ui/tools/walker/walker-tests.factor b/extra/ui/tools/walker/walker-tests.factor index a23b629d1e..acf0a39bfb 100755 --- a/extra/ui/tools/walker/walker-tests.factor +++ b/extra/ui/tools/walker/walker-tests.factor @@ -2,7 +2,7 @@ USING: arrays continuations ui.tools.listener ui.tools.walker ui.tools.workspace inspector kernel namespaces sequences threads listener tools.test ui ui.gadgets ui.gadgets.worlds ui.gadgets.packs vectors ui.tools tools.interpreter -tools.interpreter.debug tools.test.inference tools.test.ui ; +tools.interpreter.debug tools.test.ui ; IN: temporary \ must-infer diff --git a/extra/ui/tools/workspace/workspace-tests.factor b/extra/ui/tools/workspace/workspace-tests.factor index 41f0151746..5e3695fed3 100755 --- a/extra/ui/tools/workspace/workspace-tests.factor +++ b/extra/ui/tools/workspace/workspace-tests.factor @@ -1,4 +1,4 @@ IN: temporary -USING: tools.test tools.test.inference ui.tools ; +USING: tools.test ui.tools ; \ must-infer From 78abc143d626838d551592dd61bf1de31e4fe458 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:01:14 -0600 Subject: [PATCH 079/194] Load fix --- core/math/parser/parser-docs.factor | 11 +- .../furnace-pastebin/annotate-paste.furnace | 28 ----- .../furnace-pastebin/annotation.furnace | 11 -- unmaintained/furnace-pastebin/load.factor | 4 - .../furnace-pastebin/new-paste.furnace | 27 ----- .../furnace-pastebin/paste-list.furnace | 7 -- .../furnace-pastebin/paste-summary.furnace | 9 -- unmaintained/furnace-pastebin/pastebin.factor | 110 ------------------ .../furnace-pastebin/show-paste.furnace | 15 --- 9 files changed, 1 insertion(+), 221 deletions(-) delete mode 100644 unmaintained/furnace-pastebin/annotate-paste.furnace delete mode 100644 unmaintained/furnace-pastebin/annotation.furnace delete mode 100644 unmaintained/furnace-pastebin/load.factor delete mode 100644 unmaintained/furnace-pastebin/new-paste.furnace delete mode 100644 unmaintained/furnace-pastebin/paste-list.furnace delete mode 100644 unmaintained/furnace-pastebin/paste-summary.furnace delete mode 100644 unmaintained/furnace-pastebin/pastebin.factor delete mode 100644 unmaintained/furnace-pastebin/show-paste.furnace diff --git a/core/math/parser/parser-docs.factor b/core/math/parser/parser-docs.factor index b0d52ef2ef..1d2a24057c 100644 --- a/core/math/parser/parser-docs.factor +++ b/core/math/parser/parser-docs.factor @@ -25,14 +25,10 @@ $nl ABOUT: "number-strings" HELP: digits>integer -{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "n" integer } } +{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } } { $description "Converts a sequence of digits (with most significant digit first) into an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; -HELP: valid-digits? -{ $values { "radix" "an integer between 2 and 36" } { "seq" "a sequence of integers" } { "?" "a boolean" } } -{ $description "Tests if this sequence of integers represents a valid integer in the given radix." } ; - HELP: >digit { $values { "n" "an integer between 0 and 35" } { "ch" "a character" } } { $description "Outputs a character representation of a digit." } @@ -43,11 +39,6 @@ HELP: digit> { $description "Converts a character representation of a digit to an integer." } { $notes "This is one of the factors of " { $link string>number } "." } ; -HELP: string>integer -{ $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "an integer or " { $link f } } } -{ $description "Creates an integer from a string representation." } -{ $notes "The " { $link base> } " word is more general." } ; - HELP: base> { $values { "str" string } { "radix" "an integer between 2 and 36" } { "n/f" "a real number or " { $link f } } } { $description "Creates a real number from a string representation with the given radix. The radix is ignored for floating point literals; they are always taken to be in base 10." diff --git a/unmaintained/furnace-pastebin/annotate-paste.furnace b/unmaintained/furnace-pastebin/annotate-paste.furnace deleted file mode 100644 index 24f0d4ea94..0000000000 --- a/unmaintained/furnace-pastebin/annotate-paste.furnace +++ /dev/null @@ -1,28 +0,0 @@ -<% USING: namespaces math io ; %> - -

Annotate

- -
- - - -string write %>" /> - - - - - - - - - - - - - - - -
Summary:
Your name:
Contents:
- - -
diff --git a/unmaintained/furnace-pastebin/annotation.furnace b/unmaintained/furnace-pastebin/annotation.furnace deleted file mode 100644 index ed1bdac845..0000000000 --- a/unmaintained/furnace-pastebin/annotation.furnace +++ /dev/null @@ -1,11 +0,0 @@ -<% USING: namespaces io ; %> - -

Annotation: <% "summary" get write %>

- - - - - -
Annotation by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
- -
<% "contents" get write %>
diff --git a/unmaintained/furnace-pastebin/load.factor b/unmaintained/furnace-pastebin/load.factor deleted file mode 100644 index 4f3bdc8db9..0000000000 --- a/unmaintained/furnace-pastebin/load.factor +++ /dev/null @@ -1,4 +0,0 @@ -REQUIRES: libs/concurrency libs/furnace libs/irc libs/store ; - -PROVIDE: apps/furnace-pastebin -{ +files+ { "pastebin.factor" } } ; diff --git a/unmaintained/furnace-pastebin/new-paste.furnace b/unmaintained/furnace-pastebin/new-paste.furnace deleted file mode 100644 index 36f0397b67..0000000000 --- a/unmaintained/furnace-pastebin/new-paste.furnace +++ /dev/null @@ -1,27 +0,0 @@ -
- - - - - - - - - - - - - - - - - - - - - - -
Summary:
Your name:
Channel:
Contents:
- - -
diff --git a/unmaintained/furnace-pastebin/paste-list.furnace b/unmaintained/furnace-pastebin/paste-list.furnace deleted file mode 100644 index 7a25ae2f50..0000000000 --- a/unmaintained/furnace-pastebin/paste-list.furnace +++ /dev/null @@ -1,7 +0,0 @@ -<% USING: namespaces furnace sequences ; %> - - -<% "new-paste-quot" get "New paste" render-link %> - -<% "pastes" get [ "paste-summary" render-template ] each %>
 Summary:Paste by:LinkDate
- diff --git a/unmaintained/furnace-pastebin/paste-summary.furnace b/unmaintained/furnace-pastebin/paste-summary.furnace deleted file mode 100644 index ad54c8d397..0000000000 --- a/unmaintained/furnace-pastebin/paste-summary.furnace +++ /dev/null @@ -1,9 +0,0 @@ -<% USING: namespaces io kernel math furnace ; %> - - -<% "n" get number>string write %> -<% "summary" get write %> -<% "author" get write %> -<% "n" get number>string "show-paste-quot" get curry "Show" render-link %> -<% "date" get print %> - diff --git a/unmaintained/furnace-pastebin/pastebin.factor b/unmaintained/furnace-pastebin/pastebin.factor deleted file mode 100644 index b11129312f..0000000000 --- a/unmaintained/furnace-pastebin/pastebin.factor +++ /dev/null @@ -1,110 +0,0 @@ -IN: furnace:pastebin -USING: calendar concurrency irc kernel namespaces sequences -furnace hashtables math store ; - -TUPLE: paste n summary author channel contents date annotations ; - -TUPLE: annotation summary author contents ; - -C: paste ( summary author channel contents -- paste ) - V{ } clone over set-paste-annotations - [ set-paste-contents ] keep - [ set-paste-channel ] keep - [ set-paste-author ] keep - [ set-paste-summary ] keep ; - -TUPLE: pastebin pastes ; - -C: pastebin ( -- pastebin ) - V{ } clone over set-pastebin-pastes ; - -SYMBOL: store -"pastebin.store" load-store store set-global - pastebin store get store-variable - -: add-paste ( paste pastebin -- ) - now timestamp>http-string pick set-paste-date - dup pastebin-pastes length pick set-paste-n - pastebin-pastes push ; - -: get-paste ( n -- paste ) - pastebin get pastebin-pastes nth ; - -: show-paste ( n -- ) - get-paste "show-paste" "Paste" render-page ; - -\ show-paste { { "n" v-number } } define-action - -: new-paste ( -- ) - f "new-paste" "New paste" render-page ; - -\ new-paste { } define-action - -: make-remote-process - "trifocus.net" 4030 "public-irc" ; - -: alert-new-paste ( paste -- ) - >r make-remote-process r> - f over paste-channel rot [ - dup paste-author % - " pasted " % - CHAR: " , - dup paste-summary % - CHAR: " , - " at " % - "http://wee-url.com/responder/pastebin/show-paste?n=" % - paste-n # - ] "" make swap send ; - -: alert-annotation ( annotation paste -- ) - make-remote-process -rot - f over paste-channel 2swap [ - over annotation-author % - " annotated paste " % - " with \"" % - over annotation-summary % - "\" at " % - "http://wee-url.com/responder/pastebin/show-paste?n=" % - dup paste-n # - 2drop - ] "" make swap send ; - - -: submit-paste ( summary author channel contents -- ) - dup pastebin get-global add-paste - alert-new-paste store get save-store ; - -\ submit-paste { - { "summary" v-required } - { "author" v-required } - { "channel" "#concatenative" v-default } - { "contents" v-required } -} define-action - -: paste-list ( -- ) - [ - [ show-paste ] "show-paste-quot" set - [ new-paste ] "new-paste-quot" set - - pastebin get "paste-list" "Pastebin" render-page - ] with-scope ; - -\ paste-list { } define-action - -\ submit-paste [ paste-list ] define-redirect - -: annotate-paste ( paste# summary author contents -- ) - swap get-paste - [ paste-annotations push ] 2keep - alert-annotation store get save-store ; - -\ annotate-paste { - { "n" v-required v-number } - { "summary" v-required } - { "author" v-required } - { "contents" v-required } -} define-action - -\ annotate-paste [ "n" show-paste ] define-redirect - -"pastebin" "paste-list" "apps/furnace-pastebin" web-app diff --git a/unmaintained/furnace-pastebin/show-paste.furnace b/unmaintained/furnace-pastebin/show-paste.furnace deleted file mode 100644 index b3b4e99b6e..0000000000 --- a/unmaintained/furnace-pastebin/show-paste.furnace +++ /dev/null @@ -1,15 +0,0 @@ -<% USING: namespaces io furnace sequences ; %> - -

Paste: <% "summary" get write %>

- - - - - -
Paste by:<% "author" get write %>
Channel:<% "channel" get write %>
Created:<% "date" get write %>
- -
<% "contents" get write %>
- -<% "annotations" get [ "annotation" render-template ] each %> - -<% model get "annotate-paste" render-template %> From 831b712f848c90d97e5431e25ff47f122c27843e Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:02:26 -0600 Subject: [PATCH 080/194] Move logging code to io.logging --- extra/io/logging/authors.txt | 1 + extra/io/logging/logging-docs.factor | 26 +++++++++++++++ extra/io/logging/logging.factor | 47 ++++++++++++++++++++++++++++ extra/io/logging/summary.txt | 1 + extra/io/server/server-docs.factor | 23 -------------- extra/io/server/server.factor | 41 ++---------------------- 6 files changed, 77 insertions(+), 62 deletions(-) create mode 100644 extra/io/logging/authors.txt create mode 100644 extra/io/logging/logging-docs.factor create mode 100644 extra/io/logging/logging.factor create mode 100644 extra/io/logging/summary.txt diff --git a/extra/io/logging/authors.txt b/extra/io/logging/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/logging/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/logging/logging-docs.factor b/extra/io/logging/logging-docs.factor new file mode 100644 index 0000000000..6cd03ce212 --- /dev/null +++ b/extra/io/logging/logging-docs.factor @@ -0,0 +1,26 @@ +IN: io.logging +USING: help.markup help.syntax io ; + +HELP: log-stream +{ $var-description "Holds an output stream for logging messages." } +{ $see-also log-error log-client with-logging } ; + +HELP: log-message +{ $values { "str" "a string" } } +{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } +{ $see-also log-error log-client } ; + +HELP: log-error +{ $values { "str" "a string" } } +{ $description "Logs an error message." } +{ $see-also log-message log-client } ; + +HELP: log-client +{ $values { "client" "a client socket stream" } } +{ $description "Logs an incoming client connection." } +{ $see-also log-message log-error } ; + +HELP: with-logging +{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } +{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; + diff --git a/extra/io/logging/logging.factor b/extra/io/logging/logging.factor new file mode 100644 index 0000000000..bd9dc0862e --- /dev/null +++ b/extra/io/logging/logging.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel io calendar sequences io.files +io.sockets continuations prettyprint ; +IN: io.logging + +SYMBOL: log-stream + +: to-log-stream ( quot -- ) + log-stream get swap with-stream* ; inline + +: log-message ( str -- ) + [ + "[" write now timestamp>string write "] " write + print flush + ] to-log-stream ; + +: log-error ( str -- ) "Error: " swap append log-message ; + +: log-client ( client -- ) + "Accepted connection from " + swap client-stream-addr unparse append log-message ; + +: log-file ( service -- path ) + ".log" append resource-path ; + +: with-log-stream ( stream quot -- ) + log-stream get [ nip call ] [ + log-stream swap with-variable + ] if ; inline + +: with-log-file ( file quot -- ) + >r r> + [ with-log-stream ] curry + with-disposal ; inline + +: with-log-stdio ( quot -- ) + stdio get swap with-log-stream ; inline + +: with-logging ( service quot -- ) + over [ + >r log-file + "Writing log messages to " write dup print flush r> + with-log-file + ] [ + nip with-log-stdio + ] if ; inline diff --git a/extra/io/logging/summary.txt b/extra/io/logging/summary.txt new file mode 100644 index 0000000000..0edce8f0cf --- /dev/null +++ b/extra/io/logging/summary.txt @@ -0,0 +1 @@ +Basic logging framework for server applications diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor index ea8320f18d..4e4342266a 100644 --- a/extra/io/server/server-docs.factor +++ b/extra/io/server/server-docs.factor @@ -1,29 +1,6 @@ USING: help help.syntax help.markup io ; IN: io.server -HELP: log-stream -{ $var-description "Holds an output stream for logging messages." } -{ $see-also log-error log-client with-logging } ; - -HELP: log-message -{ $values { "str" "a string" } } -{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } -{ $see-also log-error log-client } ; - -HELP: log-error -{ $values { "str" "a string" } } -{ $description "Logs an error message." } -{ $see-also log-message log-client } ; - -HELP: log-client -{ $values { "client" "a client socket stream" } } -{ $description "Logs an incoming client connection." } -{ $see-also log-message log-error } ; - -HELP: with-logging -{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; - HELP: with-client { $values { "quot" "a quotation" } { "client" "a client socket stream" } } { $description "Logs a client connection and spawns a new thread that calls the quotation, with the " { $link stdio } " stream set to the client stream. If the quotation throws an error, the client connection is closed, and the error is printed to the " { $link stdio } " stream at the time the thread was spawned." } ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 3c3d2c20f5..182712c984 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,49 +1,12 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files continuations kernel math -math.parser namespaces parser sequences strings +USING: io io.sockets io.files io.logging continuations kernel +math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar qualified ; QUALIFIED: concurrency IN: io.server -SYMBOL: log-stream - -: with-log-stream ( quot -- ) - log-stream get swap with-stream* ; inline - -: log-message ( str -- ) - [ - "[" write now timestamp>string write "] " write - print flush - ] with-log-stream ; - -: log-error ( str -- ) "Error: " swap append log-message ; - -: log-client ( client -- ) - "Accepted connection from " - swap client-stream-addr unparse append log-message ; - -: log-file ( service -- path ) - ".log" append resource-path ; - -: with-log-file ( file quot -- ) - >r r> - [ log-stream swap with-variable ] curry - with-disposal ; inline - -: with-log-stdio ( quot -- ) - stdio get log-stream rot with-variable ; inline - -: with-logging ( service quot -- ) - over [ - >r log-file - "Writing log messages to " write dup print flush r> - with-log-file - ] [ - nip with-log-stdio - ] if ; inline - : with-client ( quot client -- ) dup log-client [ swap with-stream ] 2curry concurrency:spawn drop ; inline From 6373e350baf86d3814fdd05c3614522db84cd4b4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:02:38 -0600 Subject: [PATCH 081/194] Removed test-changes word --- extra/ui/tools/tools.factor | 4 ---- 1 file changed, 4 deletions(-) diff --git a/extra/ui/tools/tools.factor b/extra/ui/tools/tools.factor index 8e2eeaa0ba..71a7080c86 100755 --- a/extra/ui/tools/tools.factor +++ b/extra/ui/tools/tools.factor @@ -80,14 +80,10 @@ H{ { +nullary+ t } } define-command \ refresh-all H{ { +nullary+ t } { +listener+ t } } define-command -\ test-changes -H{ { +nullary+ t } { +listener+ t } } define-command - workspace "workflow" f { { T{ key-down f { C+ } "n" } workspace-window } { T{ key-down f f "ESC" } hide-popup } { T{ key-down f f "F2" } refresh-all } - { T{ key-down f { A+ } "F2" } test-changes } } define-command-map [ From a06c536123a2b8a1c7785caa591a9bdf1e742cbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:03:27 -0600 Subject: [PATCH 082/194] Cleaned up SMTP implementation and added some features --- extra/smtp/authors.txt | 2 + extra/smtp/server/server.factor | 72 ++++++++++ extra/smtp/smtp-tests.factor | 130 ++++++++++++++---- extra/smtp/smtp.factor | 237 ++++++++++++++++++-------------- 4 files changed, 310 insertions(+), 131 deletions(-) create mode 100644 extra/smtp/server/server.factor diff --git a/extra/smtp/authors.txt b/extra/smtp/authors.txt index 7c29e7c401..159b1e91e9 100644 --- a/extra/smtp/authors.txt +++ b/extra/smtp/authors.txt @@ -1 +1,3 @@ Elie Chaftari +Dirk Vleugels +Slava Pestov diff --git a/extra/smtp/server/server.factor b/extra/smtp/server/server.factor new file mode 100644 index 0000000000..2cfc1e65e4 --- /dev/null +++ b/extra/smtp/server/server.factor @@ -0,0 +1,72 @@ +! Copyright (C) 2007 Elie CHAFTARI +! See http://factorcode.org/license.txt for BSD license. + +! Mock SMTP server for testing purposes. + +! Usage: 4321 smtp-server +! $ telnet 127.0.0.1 4321 +! Trying 127.0.0.1... +! Connected to localhost. +! Escape character is '^]'. +! 220 hello +! EHLO +! 220 and..? +! MAIL FROM: +! 220 OK +! RCPT TO: +! 220 OK +! Hi +! 500 ERROR +! DATA +! 354 Enter message, ending with "." on a line by itself +! Hello I am still waiting for your call +! Thanks +! . +! 220 OK +! QUIT +! bye +! Connection closed by foreign host. + +USING: combinators kernel prettyprint io io.server sequences +namespaces io.sockets continuations ; + +SYMBOL: data-mode + +: process ( -- ) + readln { + { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ + "220 and..?\r\n" write flush t + ] } + { [ dup "QUIT" = ] [ + "bye\r\n" write flush f + ] } + { [ dup "MAIL FROM:" head? ] [ + "220 OK\r\n" write flush t + ] } + { [ dup "RCPT TO:" head? ] [ + "220 OK\r\n" write flush t + ] } + { [ dup "DATA" = ] [ + data-mode on + "354 Enter message, ending with \".\" on a line by itself\r\n" + write flush t + ] } + { [ dup "." = data-mode get and ] [ + data-mode off + "220 OK\r\n" write flush t + ] } + { [ data-mode get ] [ t ] } + { [ t ] [ + "500 ERROR\r\n" write flush t + ] } + } cond nip [ process ] when ; + +: smtp-server ( port -- ) + "Starting SMTP server on port " write dup . flush + "127.0.0.1" swap [ + accept [ + 60000 stdio get set-timeout + "220 hello\r\n" write flush + process + ] with-stream + ] with-disposal ; diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor index 8ab1fd0899..9a357fdc7d 100644 --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,41 +1,111 @@ -! Tested with Apache JAMES version 2.3.1 on localhost -! cram-md5 authentication tested against Exim 4 -! Replace "localhost" with your smtp server -! e.g. "your.smtp.server" initialize +USING: smtp tools.test io.streams.string io.logging threads +smtp.server kernel sequences namespaces ; +IN: temporary -USING: smtp tools.test ; +{ 0 0 } [ [ ] with-smtp-connection ] must-infer-as -"localhost" initialize ! replace localhost with your smtp server +[ "hello\nworld" validate-address ] must-fail -! 8889 set-port ! default port = 25, change for testing purposes +[ "slava@factorcode.org" ] +[ "slava@factorcode.org" validate-address ] unit-test -! 30000 set-read-timeout ! default = 60000 -! f set-esmtp ! when esmtp (extended smtp) is not supported +[ { "hello" "." "world" } validate-message ] must-fail -start +[ "hello\r\nworld\r\n.\r\n" ] [ + { "hello" "world" } [ send-body ] string-out +] unit-test -! "md5 password here" "login" cram-md5-auth +[ + [ + "500 syntax error" check-response + ] with-log-stdio +] must-fail -"root@localhost" mailfrom ! your@mail.address +[ ] [ + [ + "220 success" check-response + ] with-log-stdio +] unit-test -"root@localhost" rcptto ! someone@example.com +[ "220 success" ] [ + "220 success" [ receive-response ] string-in +] unit-test -! { "From: Your Name " -! "To: Destination Address " -! "Subject: test message" -! "Date: Thu, 17 May 2007 18:46:45 +0200" -! "Message-Id: " -! " " -! "This is a test message." -! } send-message +[ "220 the end" ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ receive-response ] string-in + ] with-log-stdio +] unit-test -{ "From: Your Name " - "To: Destination Address " - "Subject: test message" - "Date: Thu, 17 May 2007 18:46:45 +0200" - "Message-Id: " - " " - "This is a test message." -} send-message +[ ] [ + [ + "220-a multiline response\r\n250-another line\r\n220 the end" + [ get-ok ] string-in + ] with-log-stdio +] unit-test -quit \ No newline at end of file +[ + "Subject:\r\nsecurity hole" validate-header +] must-fail + +[ + V{ + { "To" "Slava , Ed " } + { "From" "Doug " } + { "Subject" "Factor rules" } + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + simple-headers >r >r 2 head* r> r> +] unit-test + +[ + { + "To: Slava , Ed " + "From: Doug " + "Subject: Factor rules" + f + f + " " + "Hi guys" + "Bye guys" + } + { "slava@factorcode.org" "dharmatech@factorcode.org" } + "erg@factorcode.org" +] [ + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + prepare-simple-message + >r >r f 3 pick set-nth f 4 pick set-nth r> r> +] unit-test + +[ ] [ [ 4321 smtp-server ] in-thread ] unit-test + +[ ] [ + [ + 4321 smtp-port set + + "Hi guys\nBye guys" + "Factor rules" + { + "Slava " + "Ed " + } + "Doug " + + send-simple-message + ] with-scope +] unit-test \ No newline at end of file diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor index 9116d094de..77bfb6cd82 100644 --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,138 +1,173 @@ -! Copyright (C) 2007 Elie CHAFTARI +! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -! -! cram-md5 auth code contributed by Dirk Vleugels - -USING: alien alien.c-types combinators crypto.common crypto.hmac base64 -kernel io io.sockets namespaces sequences splitting ; +USING: namespaces io kernel io.logging io.sockets sequences +combinators sequences.lib splitting assocs strings math.parser +random system calendar ; IN: smtp -! ========================================================= -! smtp.factor implementation -! ========================================================= +SYMBOL: smtp-domain +SYMBOL: smtp-host "localhost" smtp-host set-global +SYMBOL: smtp-port 25 smtp-port set-global +SYMBOL: read-timeout 60000 read-timeout set-global +SYMBOL: esmtp t esmtp set-global -! Connection default values -: default-port 25 ; inline -: read-timeout 60000 ; inline -: esmtp t ; inline ! t = ehlo -: domain "localhost.localdomain" ; inline +: log-smtp-connection ( host port -- ) + [ + "Establishing SMTP connection to " % swap % ":" % # + ] "" make log-message ; -SYMBOL: sess -SYMBOL: conn -SYMBOL: challenge +: with-smtp-connection ( quot -- ) + [ + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream + ] with-log-stdio ; inline -TUPLE: session address port timeout domain esmtp ; +: crlf "\r\n" write ; -: ( address -- session ) - default-port read-timeout domain esmtp - session construct-boa ; +: helo ( -- ) + esmtp get "EHLO " "HELO " ? write host-name write crlf ; -! ========================================================= -! Initialization routines -! ========================================================= +: validate-address ( string -- string' ) + #! Make sure we send funky stuff to the server by accident. + dup [ "\r\n>" member? ] contains? + [ "Bad e-mail address: " swap append throw ] when ; -: initialize ( address -- ) - sess set ; +: mail-from ( fromaddr -- ) + "MAIL FROM:<" write validate-address write ">" write crlf ; -: set-port ( port -- ) - sess get set-session-port ; +: rcpt-to ( to -- ) + "RCPT TO:<" write validate-address write ">" write crlf ; -: set-read-timeout ( timeout -- ) - sess get set-session-timeout ; +: data ( -- ) + "DATA" write crlf ; -: set-esmtp ( esmtp -- ) - sess get set-session-esmtp ; +: validate-message ( msg -- msg' ) + "." over member? [ "Message cannot contain . on a line by itself" throw ] when ; -: set-domain ( -- ) - host-name sess get set-session-domain ; +: send-body ( body -- ) + validate-message + [ write crlf ] each + "." write crlf ; -: do-start ( -- ) - sess get [ session-address ] keep session-port - dup conn set [ sess get session-timeout swap set-timeout ] - keep stream-readln print ; +: quit ( -- ) + "QUIT" write crlf ; -! ========================================================= -! Command routines -! ========================================================= +: log-response ( string -- ) "SMTP: " swap append log-message ; : check-response ( response -- ) { - { [ dup "220" head? ] [ print ] } - { [ dup "235" swap subseq? ] [ print ] } - { [ dup "250" head? ] [ print ] } - { [ dup "221" head? ] [ print ] } - { [ dup "bye" head? ] [ print ] } + { [ dup "220" head? ] [ log-response ] } + { [ dup "235" swap subseq? ] [ log-response ] } + { [ dup "250" head? ] [ log-response ] } + { [ dup "221" head? ] [ log-response ] } + { [ dup "bye" head? ] [ log-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } - { [ dup "354" head? ] [ print ] } - { [ dup "50" head? ] [ print "syntax error" throw ] } - { [ dup "53" head? ] [ print "invalid authentication data" throw ] } - { [ dup "55" head? ] [ print "fatal error" throw ] } - { [ t ] [ "unknow error" throw ] } + { [ dup "354" head? ] [ log-response ] } + { [ dup "50" head? ] [ log-response "syntax error" throw ] } + { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ t ] [ "unknown error" throw ] } } cond ; -SYMBOL: multiline - : multiline? ( response -- boolean ) - CHAR: - swap index 3 = ; + ?fourth CHAR: - = ; -: process-multiline ( -- response ) - conn get stream-readln dup - multiline get " " append head? [ - print +: process-multiline ( multiline -- response ) + >r readln r> 2dup " " append head? [ + drop dup log-response ] [ - check-response process-multiline + swap check-response process-multiline ] if ; -: recv-response ( -- response ) - conn get stream-readln - dup multiline? [ - dup 3 head multiline set process-multiline - ] [ ] if ; +: receive-response ( -- response ) + readln + dup multiline? [ 3 head process-multiline ] when ; -: get-ok ( command -- ) - >r conn get r> over stream-write stream-flush - recv-response check-response ; +: get-ok ( -- ) flush receive-response check-response ; -: helo ( -- ) - "HELO " sess get session-domain append "\r\n" append get-ok ; +: send-raw-message ( body to from -- ) + [ + helo get-ok + mail-from get-ok + [ rcpt-to get-ok ] each + data get-ok + send-body get-ok + quit get-ok + ] with-smtp-connection ; -: ehlo ( -- ) - "EHLO " sess get session-domain append "\r\n" append get-ok ; +: validate-header ( string -- string' ) + dup [ "\r\n" member? ] contains? + [ "Invalid header string: " swap append throw ] when ; -: mailfrom ( fromaddr -- ) - "MAIL FROM:<" swap append ">\r\n" append get-ok ; +: prepare-header ( key value -- ) + swap + validate-header % + ": " % + validate-header % ; -: rcptto ( to -- ) - "RCPT TO:<" swap append ">\r\n" append get-ok ; +: prepare-headers ( assoc -- ) + [ [ prepare-header ] "" make , ] assoc-each ; -: (cram-md5-auth) ( -- response ) - swap challenge get - string>md5-hmac hex-string - " " swap append append - >base64 ; +: extract-email ( recepient -- email ) + #! This could be much smarter. + " " last-split1 [ ] [ ] ?if "<" ?head drop ">" ?tail drop ; -: cram-md5-auth ( key login -- ) - "AUTH CRAM-MD5\r\n" get-ok - (cram-md5-auth) "\r\n" append get-ok ; - -: data ( -- ) - "DATA\r\n" get-ok ; +: message-id ( -- string ) + [ + "<" % + 2 big-random # + "-" % + millis # + "@" % + smtp-domain get % + ">" % + ] "" make ; -: start ( -- ) - set-domain ! replaces localhost.localdomain with hostname - do-start - sess get session-esmtp [ - ehlo - ] [ - helo - ] if ; +: simple-headers ( subject to from -- headers to from ) + [ + >r dup ", " join "To" set [ extract-email ] map r> + dup "From" set extract-email + rot "Subject" set + now timestamp>rfc822-string "Date" set + message-id "Message-Id" set + ] { } make-assoc -rot ; -: send-message ( msg -- ) - data - "\r\n" join conn get swap "\r\n" append over stream-write - stream-flush ".\r\n" get-ok ; +: prepare-message ( body headers -- body' ) + [ + prepare-headers + " " , + dup string? [ string-lines ] when % + ] { } make ; -: quit ( -- ) - "QUIT\r\n" get-ok ; +: prepare-simple-message ( body subject to from -- body' to from ) + simple-headers >r >r prepare-message r> r> ; + +: send-message ( body headers to from -- ) + >r >r prepare-message r> r> send-raw-message ; + +: send-simple-message ( body subject to from -- ) + prepare-simple-message send-raw-message ; + +! Dirk's old AUTH CRAM-MD5 code. I don't know anything about +! CRAM MD5, and the old code didn't work properly either, so here +! it is in case anyone wants to fix it later. +! +! check-response used to have this clause: +! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] } +! +! and the rest of the code was as follows: +! : (cram-md5-auth) ( -- response ) +! swap challenge get +! string>md5-hmac hex-string +! " " swap append append +! >base64 ; +! +! : cram-md5-auth ( key login -- ) +! "AUTH CRAM-MD5\r\n" get-ok +! (cram-md5-auth) "\r\n" append get-ok ; From 2f46a618a694e4eb8cc2830684b21ba64dba0a84 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:00 -0600 Subject: [PATCH 083/194] Add new word to calendar --- extra/calendar/calendar.factor | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index a1fe0a55ea..32c5c0233c 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -349,13 +349,23 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; +: timestamp>rfc822-string ( timestamp -- str ) + #! RFC822 timestamp format + #! Example: Tue, 15 Nov 1994 08:12:31 +0200 + [ + dup (timestamp>string) + " " write + timestamp-gmt-offset { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg write-00 "00" write ] } + { [ dup 0 > ] [ "+" write write-00 "00" write ] } + } cond + ] string-out ; + : timestamp>http-string ( timestamp -- str ) #! http timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 GMT - >gmt [ - (timestamp>string) - " GMT" write - ] string-out ; + >gmt timestamp>rfc822-string ; : (timestamp>rfc3339) ( timestamp -- ) dup timestamp-year number>string write CHAR: - write1 From dad715e7b0e2fe985eb5b5027632c2ee0d4acaaf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:10 -0600 Subject: [PATCH 084/194] Update for io.logging change --- extra/http/server/responders/responders.factor | 4 ++-- extra/http/server/server.factor | 4 ++-- extra/webapps/planet/planet.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 70503236f6..8f4f146508 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib ; +strings io.server vectors assocs.lib io.logging ; IN: http.server.responders diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor index 99ed41afa3..f8ac503819 100644 --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2003, 2007 Slava Pestov. +! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io strings splitting threads http http.server.responders sequences prettyprint -io.server ; +io.server io.logging ; IN: http.server diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index ede0c579de..b777780e11 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint io.server ; +xml.writer prettyprint io.logging ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -90,7 +90,7 @@ SYMBOL: last-update [ fetch-feed ] [ - swap [ . error. ] with-log-stream f + swap [ . error. ] to-log-stream f ] recover ; : fetch-blogroll ( blogroll -- entries ) From 386d93b6e5a68b3d65a1b342a17cced48c554bdc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:05:28 -0600 Subject: [PATCH 085/194] Moved smtp-server.factor to smtp/server/server.factor --- extra/smtp/smtp-server.factor | 68 ----------------------------------- 1 file changed, 68 deletions(-) delete mode 100644 extra/smtp/smtp-server.factor diff --git a/extra/smtp/smtp-server.factor b/extra/smtp/smtp-server.factor deleted file mode 100644 index e980ee36e6..0000000000 --- a/extra/smtp/smtp-server.factor +++ /dev/null @@ -1,68 +0,0 @@ -! Copyright (C) 2007 Elie CHAFTARI -! See http://factorcode.org/license.txt for BSD license. - -! Usage: 8889 start-server -! $ telnet 127.0.0.1 8889 -! Trying 127.0.0.1... -! Connected to localhost. -! Escape character is '^]'. -! 220 hello -! EHLO -! 220 and..? -! MAIL FROM: -! 220 OK -! RCPT TO: -! 220 OK -! Hi -! 500 ERROR -! DATA -! 354 Enter message, ending with "." on a line by itself -! Hello I am still waiting for your call -! Thanks -! . -! 220 OK -! QUIT -! bye -! Connection closed by foreign host. - -USING: combinators kernel prettyprint io io.server sequences -namespaces ; - -SYMBOL: data-mode - -: process ( -- ) - readln { - { [ [ dup "HELO" head? ] keep "EHLO" head? or ] [ - "220 and..?\r\n" write flush t - ] } - { [ dup "QUIT" = ] [ - "bye\r\n" write flush f - ] } - { [ dup "MAIL FROM:" head? ] [ - "220 OK\r\n" write flush t - ] } - { [ dup "RCPT TO:" head? ] [ - "220 OK\r\n" write flush t - ] } - { [ dup "DATA" = ] [ - data-mode on - "354 Enter message, ending with \".\" on a line by itself\r\n" - write flush t - ] } - { [ dup "." = data-mode get and ] [ - data-mode off - "220 OK\r\n" write flush t - ] } - { [ data-mode get ] [ t ] } - { [ t ] [ - "500 ERROR\r\n" write flush t - ] } - } cond nip [ process ] when ; - -: start-server ( port -- ) - "Starting SMTP server on port " write dup . flush - internet-server "smtp-server" [ - 60000 stdio get set-timeout - "220 hello\r\n" write flush - process - ] with-server ; From b5e1edfeed462036ce9c211006cfca29273bf333 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 01:36:11 -0600 Subject: [PATCH 086/194] Removed obsolete vocab --- extra/tools/test/inference/authors.txt | 1 - extra/tools/test/inference/inference.factor | 15 --------------- 2 files changed, 16 deletions(-) delete mode 100755 extra/tools/test/inference/authors.txt delete mode 100755 extra/tools/test/inference/inference.factor diff --git a/extra/tools/test/inference/authors.txt b/extra/tools/test/inference/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/extra/tools/test/inference/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/extra/tools/test/inference/inference.factor b/extra/tools/test/inference/inference.factor deleted file mode 100755 index cc77f4910d..0000000000 --- a/extra/tools/test/inference/inference.factor +++ /dev/null @@ -1,15 +0,0 @@ -! Copyright (C) 2007 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: effects sequences kernel arrays quotations inference -tools.test words ; -IN: tools.test.inference - -: short-effect - dup effect-in length swap effect-out length 2array ; - -: unit-test-effect ( effect quot -- ) - >r 1quotation r> [ infer short-effect ] curry unit-test ; - -: must-infer ( word/quot -- ) - dup word? [ 1quotation ] when - [ infer drop ] curry [ ] swap unit-test ; From 6204f5698130c8d35056593e60b7c8ac79dab282 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 Feb 2008 13:48:49 -0600 Subject: [PATCH 087/194] fix gmt-offset on windows --- extra/calendar/windows/windows.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index 320400822c..afc040ef75 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -9,5 +9,4 @@ T{ windows-calendar } calendar-backend set-global M: windows-calendar gmt-offset ( -- float ) "TIME_ZONE_INFORMATION" [ GetTimeZoneInformation win32-error=0/f ] keep - [ TIME_ZONE_INFORMATION-Bias ] keep - TIME_ZONE_INFORMATION-DaylightBias + 60 /f neg ; + TIME_ZONE_INFORMATION-Bias 60 / neg ; From e05bb24a697b5721be7ed6d5caa9e1136b05f1ee Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 7 Feb 2008 14:17:07 -0600 Subject: [PATCH 088/194] make rfc822-string print fractional times fix windows gmt-offset yet again -- bad return value --- extra/calendar/calendar.factor | 16 +++++++++++----- extra/calendar/windows/windows.factor | 5 ++++- 2 files changed, 15 insertions(+), 6 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 32c5c0233c..012080d3b7 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -349,17 +349,23 @@ M: timestamp year. ( timestamp -- ) : timestamp>string ( timestamp -- str ) [ (timestamp>string) ] string-out ; +: (write-gmt-offset) ( ratio -- ) + 1 /mod swap write-00 60 * write-00 ; + +: write-gmt-offset ( gmt-offset -- ) + { + { [ dup zero? ] [ drop "GMT" write ] } + { [ dup 0 < ] [ "-" write neg (write-gmt-offset) ] } + { [ dup 0 > ] [ "+" write (write-gmt-offset) ] } + } cond ; + : timestamp>rfc822-string ( timestamp -- str ) #! RFC822 timestamp format #! Example: Tue, 15 Nov 1994 08:12:31 +0200 [ dup (timestamp>string) " " write - timestamp-gmt-offset { - { [ dup zero? ] [ drop "GMT" write ] } - { [ dup 0 < ] [ "-" write neg write-00 "00" write ] } - { [ dup 0 > ] [ "+" write write-00 "00" write ] } - } cond + timestamp-gmt-offset write-gmt-offset ] string-out ; : timestamp>http-string ( timestamp -- str ) diff --git a/extra/calendar/windows/windows.factor b/extra/calendar/windows/windows.factor index afc040ef75..9e34fdac00 100755 --- a/extra/calendar/windows/windows.factor +++ b/extra/calendar/windows/windows.factor @@ -6,7 +6,10 @@ TUPLE: windows-calendar ; T{ windows-calendar } calendar-backend set-global +: TIME_ZONE_ID_INVALID HEX: ffffffff ; inline + M: windows-calendar gmt-offset ( -- float ) "TIME_ZONE_INFORMATION" - [ GetTimeZoneInformation win32-error=0/f ] keep + dup GetTimeZoneInformation + TIME_ZONE_ID_INVALID = [ win32-error ] when TIME_ZONE_INFORMATION-Bias 60 / neg ; From 0570449ffdabeaad6dc49e4489e178200568d1cc Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 15:14:40 -0600 Subject: [PATCH 089/194] Tweak builder --- extra/builder/builder.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 5bfd5e01cf..5e992ccc81 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -69,8 +69,8 @@ VAR: stamp "git" "pull" "--no-summary" - ! "git://factorcode.org/git/factor.git" - "http://dharmatech.onigirihouse.com/factor.git" + "git://factorcode.org/git/factor.git" + ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status From 5310a2cabea0341d33f7096e4e7ff9f043717bc0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:07:43 -0600 Subject: [PATCH 090/194] New logging framework --- .../distributed/distributed.factor | 2 +- .../http/server/responders/responders.factor | 39 +++--- extra/http/server/server.factor | 6 +- extra/io/logging/logging-docs.factor | 26 ---- extra/io/logging/logging.factor | 47 ------- extra/io/logging/summary.txt | 1 - extra/io/server/server.factor | 40 +++--- extra/logging/analysis/analysis.factor | 69 ++++++++++ .../logging => logging/analysis}/authors.txt | 2 +- extra/logging/analysis/summary.txt | 1 + extra/logging/authors.txt | 1 + extra/logging/insomniac/authors.txt | 1 + extra/logging/insomniac/insomniac.factor | 49 +++++++ extra/logging/insomniac/summary.txt | 1 + extra/logging/logging.factor | 122 ++++++++++++++++++ extra/logging/parser/authors.txt | 1 + extra/logging/parser/parser.factor | 66 ++++++++++ extra/logging/parser/summary.txt | 1 + extra/logging/server/authors.txt | 1 + extra/logging/server/server.factor | 101 +++++++++++++++ extra/logging/server/summary.txt | 1 + extra/logging/summary.txt | 1 + extra/raptor/cron/cron.factor | 6 +- extra/smtp/smtp-tests.factor | 2 +- extra/smtp/smtp.factor | 47 ++++--- extra/tools/annotations/annotations.factor | 20 ++- extra/tools/browser/browser.factor | 1 + extra/webapps/file/file.factor | 18 ++- extra/webapps/planet/planet.factor | 20 +-- 29 files changed, 523 insertions(+), 170 deletions(-) mode change 100644 => 100755 extra/concurrency/distributed/distributed.factor mode change 100644 => 100755 extra/http/server/responders/responders.factor mode change 100644 => 100755 extra/http/server/server.factor delete mode 100644 extra/io/logging/logging-docs.factor delete mode 100644 extra/io/logging/logging.factor delete mode 100644 extra/io/logging/summary.txt create mode 100755 extra/logging/analysis/analysis.factor rename extra/{io/logging => logging/analysis}/authors.txt (92%) mode change 100644 => 100755 create mode 100755 extra/logging/analysis/summary.txt create mode 100755 extra/logging/authors.txt create mode 100755 extra/logging/insomniac/authors.txt create mode 100755 extra/logging/insomniac/insomniac.factor create mode 100755 extra/logging/insomniac/summary.txt create mode 100755 extra/logging/logging.factor create mode 100755 extra/logging/parser/authors.txt create mode 100755 extra/logging/parser/parser.factor create mode 100755 extra/logging/parser/summary.txt create mode 100755 extra/logging/server/authors.txt create mode 100755 extra/logging/server/server.factor create mode 100755 extra/logging/server/summary.txt create mode 100755 extra/logging/summary.txt mode change 100644 => 100755 extra/raptor/cron/cron.factor mode change 100644 => 100755 extra/smtp/smtp-tests.factor mode change 100644 => 100755 extra/smtp/smtp.factor diff --git a/extra/concurrency/distributed/distributed.factor b/extra/concurrency/distributed/distributed.factor old mode 100644 new mode 100755 index 9024c0630f..83052b803a --- a/extra/concurrency/distributed/distributed.factor +++ b/extra/concurrency/distributed/distributed.factor @@ -14,7 +14,7 @@ C: node : node-server ( port -- ) internet-server - "concurrency" + "concurrency.distributed" [ handle-node-client ] with-server ; : send-to-node ( msg pid host port -- ) diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor old mode 100644 new mode 100755 index 8f4f146508..e4e0e257c4 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server vectors assocs.lib io.logging ; +strings io.server vectors assocs.lib logging ; IN: http.server.responders @@ -22,7 +22,7 @@ SYMBOL: responders

write

; : error-head ( error -- ) - dup log-error response + response H{ { "Content-Type" V{ "text/html" } } } print-header nl ; : httpd-error ( error -- ) @@ -30,6 +30,8 @@ SYMBOL: responders dup error-head "head" "method" get = [ drop ] [ error-body ] if ; +\ httpd-error ERROR add-error-logging + : bad-request ( -- ) [ ! Make httpd-error print a body @@ -84,17 +86,21 @@ SYMBOL: max-post-request : read-post-request ( header -- str hash ) content-length [ read dup query>hash ] [ f f ] if* ; -: log-headers ( hash -- ) +LOG: log-headers DEBUG + +: interesting-headers ( assoc -- string ) [ - drop { - "user-agent" - "referer" - "x-forwarded-for" - "host" - } member? - ] assoc-subset [ - ": " swap 3append log-message - ] multi-assoc-each ; + [ + drop { + "user-agent" + "referer" + "x-forwarded-for" + "host" + } member? + ] assoc-subset [ + ": " swap 3append % "\n" % + ] multi-assoc-each + ] "" make ; : prepare-url ( url -- url ) #! This is executed in the with-request namespace. @@ -105,7 +111,7 @@ SYMBOL: max-post-request : prepare-header ( -- ) read-header dup "header" set - dup log-headers + dup interesting-headers log-headers read-post-request "response" set "raw-response" set ; ! Responders are called in a new namespace with these @@ -177,9 +183,6 @@ SYMBOL: max-post-request "/" "responder-url" set "default" responder call-responder ; -: log-responder ( path -- ) - "Calling responder " swap append log-message ; - : trim-/ ( url -- url ) #! Trim a leading /, if there is one. "/" ?head drop ; @@ -199,13 +202,15 @@ SYMBOL: max-post-request #! /foo/bar... - default responder used #! /responder/foo/bar - responder foo, argument bar vhost [ - dup log-responder trim-/ "responder/" ?head [ + trim-/ "responder/" ?head [ serve-explicit-responder ] [ serve-default-responder ] if ] bind ; +\ serve-responder DEBUG add-input-logging + : no-such-responder ( -- ) "404 No such responder" httpd-error ; diff --git a/extra/http/server/server.factor b/extra/http/server/server.factor old mode 100644 new mode 100755 index f8ac503819..eca2253e2a --- a/extra/http/server/server.factor +++ b/extra/http/server/server.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io strings splitting threads http http.server.responders sequences prettyprint -io.server io.logging ; +io.server logging ; IN: http.server @@ -36,7 +36,6 @@ IN: http.server [ (handle-request) serve-responder ] with-scope ; : parse-request ( request -- ) - dup log-message " " split1 dup [ " HTTP" split1 drop url>path secure-path dup [ swap handle-request @@ -47,8 +46,9 @@ IN: http.server 2drop bad-request ] if ; +\ parse-request NOTICE add-input-logging + : httpd ( port -- ) - "Starting HTTP server on port " write dup . flush internet-server "http.server" [ 60000 stdio get set-timeout readln [ parse-request ] when* diff --git a/extra/io/logging/logging-docs.factor b/extra/io/logging/logging-docs.factor deleted file mode 100644 index 6cd03ce212..0000000000 --- a/extra/io/logging/logging-docs.factor +++ /dev/null @@ -1,26 +0,0 @@ -IN: io.logging -USING: help.markup help.syntax io ; - -HELP: log-stream -{ $var-description "Holds an output stream for logging messages." } -{ $see-also log-error log-client with-logging } ; - -HELP: log-message -{ $values { "str" "a string" } } -{ $description "Logs a message to the log stream. If " { $link log-stream } " is not set, logs to the " { $link stdio } " stream." } -{ $see-also log-error log-client } ; - -HELP: log-error -{ $values { "str" "a string" } } -{ $description "Logs an error message." } -{ $see-also log-message log-client } ; - -HELP: log-client -{ $values { "client" "a client socket stream" } } -{ $description "Logs an incoming client connection." } -{ $see-also log-message log-error } ; - -HELP: with-logging -{ $values { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Calls the quotation in a new dynamic scope where the " { $link log-stream } " is set to a file stream appending to a log file (if " { $snippet "service" } " is not " { $link f } ") or the " { $link stdio } " stream at the time " { $link with-logging } " is called (if " { $snippet "service" } " is " { $link f } ")." } ; - diff --git a/extra/io/logging/logging.factor b/extra/io/logging/logging.factor deleted file mode 100644 index bd9dc0862e..0000000000 --- a/extra/io/logging/logging.factor +++ /dev/null @@ -1,47 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel io calendar sequences io.files -io.sockets continuations prettyprint ; -IN: io.logging - -SYMBOL: log-stream - -: to-log-stream ( quot -- ) - log-stream get swap with-stream* ; inline - -: log-message ( str -- ) - [ - "[" write now timestamp>string write "] " write - print flush - ] to-log-stream ; - -: log-error ( str -- ) "Error: " swap append log-message ; - -: log-client ( client -- ) - "Accepted connection from " - swap client-stream-addr unparse append log-message ; - -: log-file ( service -- path ) - ".log" append resource-path ; - -: with-log-stream ( stream quot -- ) - log-stream get [ nip call ] [ - log-stream swap with-variable - ] if ; inline - -: with-log-file ( file quot -- ) - >r r> - [ with-log-stream ] curry - with-disposal ; inline - -: with-log-stdio ( quot -- ) - stdio get swap with-log-stream ; inline - -: with-logging ( service quot -- ) - over [ - >r log-file - "Writing log messages to " write dup print flush r> - with-log-file - ] [ - nip with-log-stdio - ] if ; inline diff --git a/extra/io/logging/summary.txt b/extra/io/logging/summary.txt deleted file mode 100644 index 0edce8f0cf..0000000000 --- a/extra/io/logging/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Basic logging framework for server applications diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 182712c984..829da27f6e 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -1,32 +1,34 @@ ! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.files io.logging continuations kernel +USING: io io.sockets io.files logging continuations kernel math math.parser namespaces parser sequences strings prettyprint debugger quotations calendar qualified ; QUALIFIED: concurrency IN: io.server -: with-client ( quot client -- ) - dup log-client - [ swap with-stream ] 2curry concurrency:spawn drop ; inline +LOG: accepted-connection NOTICE + +: with-client ( client quot -- ) + [ + over client-stream-addr accepted-connection + with-stream* + ] curry with-disposal ; inline + +\ with-client NOTICE add-error-logging : accept-loop ( server quot -- ) - [ swap accept with-client ] 2keep accept-loop ; inline + [ + >r accept r> [ with-client ] 2curry concurrency:spawn + ] 2keep accept-loop ; inline : server-loop ( server quot -- ) [ accept-loop ] curry with-disposal ; inline : spawn-server ( addrspec quot -- ) - "Waiting for connections on " pick unparse append - log-message - [ - >r r> server-loop - ] [ - "Cannot spawn server: " print - print-error - 2drop - ] recover ; inline + >r r> server-loop ; inline + +\ spawn-server NOTICE add-error-logging : local-server ( port -- seq ) "localhost" swap t resolve-host ; @@ -39,19 +41,21 @@ IN: io.server [ spawn-server ] curry concurrency:parallel-each ] curry with-logging ; inline -: log-datagram ( addrspec -- ) - "Received datagram from " swap unparse append log-message ; +: received-datagram ( addrspec -- ) drop ; + +\ received-datagram NOTICE add-input-logging : datagram-loop ( quot datagram -- ) [ - [ receive dup log-datagram >r swap call r> ] keep + [ receive dup received-datagram >r swap call r> ] keep pick [ send ] [ 3drop ] keep ] 2keep datagram-loop ; inline : spawn-datagrams ( quot addrspec -- ) - "Waiting for datagrams on " over unparse append log-message [ datagram-loop ] with-disposal ; inline +\ spawn-datagrams NOTICE add-input-logging + : with-datagrams ( seq service quot -- ) [ [ swap spawn-datagrams ] curry concurrency:parallel-each diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor new file mode 100755 index 0000000000..df53a8e70b --- /dev/null +++ b/extra/logging/analysis/analysis.factor @@ -0,0 +1,69 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces words assocs logging sorting +prettyprint io io.styles strings logging.parser ; +IN: logging.analysis + +SYMBOL: word-names +SYMBOL: errors +SYMBOL: word-histogram +SYMBOL: message-histogram + +: analyze-entry ( entry -- ) + dup second ERROR eq? [ dup errors get push ] when + 1 over third word-histogram get at+ + dup third word-names get member? [ + 1 over 1 tail message-histogram get at+ + ] when + drop ; + +: analyze-entries ( entries word-names -- errors word-histogram message-histogram ) + [ + word-names set + V{ } clone errors set + H{ } clone word-histogram set + H{ } clone message-histogram set + + [ + analyze-entry + ] each + + errors get + word-histogram get + message-histogram get + ] with-scope ; + +: histogram. ( assoc quot -- ) + standard-table-style [ + >r >alist sort-values r> [ + [ >r swap r> with-cell pprint-cell ] with-row + ] curry assoc-each + ] tabular-output ; + +: log-entry. + [ + dup first [ write ] with-cell + dup second [ pprint ] with-cell + dup third [ write ] with-cell + fourth "\n" join [ write ] with-cell + ] with-row ; + +: errors. ( errors -- ) + standard-table-style + [ [ log-entry. ] each ] tabular-output ; + +: analysis. ( errors word-histogram message-histogram -- ) + "==== INTERESTING MESSAGES:" print nl + "Total: " write dup values sum . nl + [ + dup second write ": " write third "\n" join write + ] histogram. + nl + "==== WORDS:" print nl + [ write ] histogram. + nl + "==== ERRORS:" print nl + errors. ; + +: log-analysis ( lines word-names -- ) + >r parse-log r> analyze-entries analysis. ; diff --git a/extra/io/logging/authors.txt b/extra/logging/analysis/authors.txt old mode 100644 new mode 100755 similarity index 92% rename from extra/io/logging/authors.txt rename to extra/logging/analysis/authors.txt index 1901f27a24..56f4654064 --- a/extra/io/logging/authors.txt +++ b/extra/logging/analysis/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov diff --git a/extra/logging/analysis/summary.txt b/extra/logging/analysis/summary.txt new file mode 100755 index 0000000000..e614abca96 --- /dev/null +++ b/extra/logging/analysis/summary.txt @@ -0,0 +1 @@ +Analyze logs and produce summaries diff --git a/extra/logging/authors.txt b/extra/logging/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/insomniac/authors.txt b/extra/logging/insomniac/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/insomniac/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor new file mode 100755 index 0000000000..b065dec9d3 --- /dev/null +++ b/extra/logging/insomniac/insomniac.factor @@ -0,0 +1,49 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.analysis logging.server logging smtp io.sockets +kernel io.files io.streams.string namespaces raptor.cron ; +IN: logging.insomniac + +SYMBOL: insomniac-config + +SYMBOL: insomniac-smtp-host +SYMBOL: insomniac-smtp-port +SYMBOL: insomniac-sender +SYMBOL: insomniac-recipients + +: ?log-analysis ( service word-names -- string/f ) + >r log-path 1 log# dup exists? [ + file-lines r> [ log-analysis ] string-out + ] [ + r> 2drop f + ] if ; + +: with-insomniac-smtp ( quot -- ) + [ + insomniac-smtp-host get [ smtp-host set ] when* + insomniac-smtp-port get [ smtp-port set ] when* + call + ] with-scope ; inline + +: email-subject ( service -- string ) + [ "[INSOMNIAC] " % % " on " % host-name % ] "" make ; + +: (email-log-report) ( service word-names -- ) + [ + over >r + ?log-analysis dup [ + r> email-subject + insomniac-recipients get + insomniac-sender get + send-simple-message + ] [ r> 2drop ] if + ] with-insomniac-smtp ; + +: email-log-report ( service word-names -- ) + (email-log-report) ; + +\ email-log-report NOTICE add-error-logging + +: schedule-insomniac ( service word-names -- ) + { 25 } { 6 } f f f -rot + [ email-log-report ] 2curry schedule ; diff --git a/extra/logging/insomniac/summary.txt b/extra/logging/insomniac/summary.txt new file mode 100755 index 0000000000..ddd21fb5b9 --- /dev/null +++ b/extra/logging/insomniac/summary.txt @@ -0,0 +1 @@ +Task which rotates logs and e-mails summaries diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor new file mode 100755 index 0000000000..71ea247567 --- /dev/null +++ b/extra/logging/logging.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: logging.server sequences namespaces concurrency +words kernel arrays shuffle tools.annotations +prettyprint.config prettyprint debugger io.streams.string +splitting continuations effects arrays.lib parser strings +combinators.lib ; +IN: logging + +SYMBOL: DEBUG +SYMBOL: NOTICE +SYMBOL: WARNING +SYMBOL: ERROR +SYMBOL: CRITICAL + +: log-levels + { DEBUG NOTICE NOTICE WARNING ERROR CRITICAL } ; + +: send-to-log-server ( array string -- ) + add* "log-server" get send ; + +SYMBOL: log-service + +: check-log-message + pick string? + pick word? + pick word? and and + [ "Bad parameters to log-message" throw ] unless ; + +: log-message ( msg word level -- ) + check-log-message + log-service get dup [ + >r >r >r string-lines r> word-name r> word-name r> + 4array "log-message" send-to-log-server + ] [ + 4drop + ] if ; + +: rotate-logs ( -- ) + { } "rotate-logs" send-to-log-server ; + +: close-log-files ( -- ) + { } "close-log-files" send-to-log-server ; + +: with-logging ( service quot -- ) + log-service swap with-variable ; inline + +! Aspect-oriented programming idioms + +message ( obj -- inputs>message ) + dup one-string? [ first ] [ + H{ + { string-limit f } + { line-limit 1 } + { nesting-limit 3 } + { margin 0 } + } clone [ unparse ] bind + ] if ; + +PRIVATE> + +: (define-logging) ( word level quot -- ) + >r >r dup r> r> 2curry annotate ; + +: call-logging-quot ( quot word level -- quot' ) + "called" -rot [ log-message ] 3curry swap compose ; + +: add-logging ( word level -- ) + [ call-logging-quot ] (define-logging) ; + +: log-inputs ( n word level -- ) + log-service get [ + >r >r [ ndup ] keep narray inputs>message + r> r> log-message + ] [ + 3drop + ] if ; inline + +: input# stack-effect effect-in length ; + +: input-logging-quot ( quot word level -- quot' ) + over input# -rot [ log-inputs ] 3curry swap compose ; + +: add-input-logging ( word level -- ) + [ input-logging-quot ] (define-logging) ; + +: (log-error) ( object word level -- ) + log-service get [ + >r >r [ print-error ] string-out r> r> log-message + ] [ + 2drop rethrow + ] if ; + +: log-error ( object word -- ) ERROR (log-error) ; + +: log-critical ( object word -- ) CRITICAL (log-error) ; + +: error-logging-quot ( quot word -- quot' ) + dup stack-effect effect-in length + [ >r log-error r> ndrop ] 2curry + [ recover ] 2curry ; + +: add-error-logging ( word level -- ) + [ over >r input-logging-quot r> error-logging-quot ] + (define-logging) ; + +: LOG: + #! Syntax: name level + CREATE + dup reset-generic + dup scan-word + [ >r >r 1array inputs>message r> r> log-message ] 2curry + define ; parsing diff --git a/extra/logging/parser/authors.txt b/extra/logging/parser/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/parser/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor new file mode 100755 index 0000000000..f1cb7aa17e --- /dev/null +++ b/extra/logging/parser/parser.factor @@ -0,0 +1,66 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: parser-combinators memoize kernel sequences +logging arrays words strings vectors io io.files +namespaces combinators combinators.lib logging.server ; +IN: logging.parser + +: string-of satisfy [ >string ] <@ ; + +: 'date' + [ CHAR: ] eq? not ] string-of + "[" "]" surrounded-by ; + +: 'log-level' + log-levels [ + [ word-name token ] keep [ nip ] curry <@ + ] map ; + +: 'word-name' + [ " :" member? not ] string-of ; + +SYMBOL: malformed + +: 'malformed-line' + [ drop t ] string-of [ malformed swap 2array ] <@ ; + +: 'log-message' + [ drop t ] string-of [ 1vector ] <@ ; + +MEMO: 'log-line' ( -- parser ) + 'date' " " token <& + 'log-level' " " token <& <&> + 'word-name' ": " token <& <:&> + 'log-message' <:&> + 'malformed-line' <|> ; + +: parse-log-line ( string -- entry ) + 'log-line' parse-1 ; + +: malformed? ( line -- ? ) + first malformed eq? ; + +: multiline? ( line -- ? ) + first first CHAR: - = ; + +: malformed-line + "Warning: malformed log line:" print + second print ; + +: add-multiline ( line -- ) + building get empty? [ + "Warning: log begins with multiline entry" print drop + ] [ + fourth first building get peek fourth push + ] if ; + +: parse-log ( lines -- entries ) + [ + [ + parse-log-line { + { [ dup malformed? ] [ malformed-line ] } + { [ dup multiline? ] [ add-multiline ] } + { [ t ] [ , ] } + } cond + ] each + ] { } make ; diff --git a/extra/logging/parser/summary.txt b/extra/logging/parser/summary.txt new file mode 100755 index 0000000000..cd5c68b156 --- /dev/null +++ b/extra/logging/parser/summary.txt @@ -0,0 +1 @@ +Log parser diff --git a/extra/logging/server/authors.txt b/extra/logging/server/authors.txt new file mode 100755 index 0000000000..56f4654064 --- /dev/null +++ b/extra/logging/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor new file mode 100755 index 0000000000..cddcea8d70 --- /dev/null +++ b/extra/logging/server/server.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel io calendar sequences io.files +io.sockets continuations prettyprint assocs math.parser +words debugger math combinators concurrency arrays init +math.ranges strings ; +IN: logging.server + +: log-root ( -- string ) + \ log-root get "logs" resource-path or ; + +: log-path ( service -- path ) + log-root swap path+ ; + +: log# ( path n -- path' ) + number>string ".log" append path+ ; + +SYMBOL: log-files + +: open-log-stream ( service -- stream ) + log-path + dup make-directories + 1 log# ; + +: log-stream ( service -- stream ) + log-files get [ open-log-stream ] cache ; + +: (write-message) ( msg word-name level multi? -- ) + [ + "[" write 20 CHAR: - write "] " write + ] [ + "[" write now (timestamp>rfc3339) "] " write + ] if + write bl write ": " write print ; + +: write-message ( msg word-name level -- ) + rot [ empty? not ] subset { + { [ dup empty? ] [ 3drop ] } + { [ dup length 1 = ] [ first -rot f (write-message) ] } + { [ t ] [ + [ first -rot f (write-message) ] 3keep + 1 tail -rot [ t (write-message) ] 2curry each + ] } + } cond ; + +: (log-message) ( msg -- ) + #! msg: { msg word-name level service } + first4 log-stream [ write-message flush ] with-stream* ; + +: try-dispose ( stream -- ) + [ dispose ] curry [ error. ] recover ; + +: close-log-file ( service -- ) + log-files get delete-at* + [ try-dispose ] [ drop ] if ; + +: (close-log-files) ( -- ) + log-files get + dup values [ try-dispose ] each + clear-assoc ; + +: keep-logs 10 ; + +: ?delete-file ( path -- ) + dup exists? [ delete-file ] [ drop ] if ; + +: delete-oldest keep-logs log# ?delete-file ; + +: ?rename-file ( old new -- ) + over exists? [ rename-file ] [ 2drop ] if ; + +: advance-log ( path n -- ) + [ 1- log# ] 2keep log# ?rename-file ; + +: rotate-log ( service -- ) + dup close-log-file + log-path + dup delete-oldest + keep-logs 1 [a,b] [ advance-log ] with each ; + +: (rotate-logs) ( -- ) + (close-log-files) + log-root directory [ drop rotate-log ] assoc-each ; + +: log-server-loop + [ + receive unclip { + { "log-message" [ (log-message) ] } + { "rotate-logs" [ drop (rotate-logs) ] } + { "close-log-files" [ drop (close-log-files) ] } + } case + ] [ error. (close-log-files) ] recover + log-server-loop ; + +: log-server ( -- ) + [ log-server-loop ] spawn "log-server" set-global ; + +[ + H{ } clone log-files set-global + log-server +] "logging" add-init-hook diff --git a/extra/logging/server/summary.txt b/extra/logging/server/summary.txt new file mode 100755 index 0000000000..bebf3465f1 --- /dev/null +++ b/extra/logging/server/summary.txt @@ -0,0 +1 @@ +Distributed concurrency log server diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt new file mode 100755 index 0000000000..dbf29c2112 --- /dev/null +++ b/extra/logging/summary.txt @@ -0,0 +1 @@ +AOP Logging framework with support for log rotation and machine-readable logs diff --git a/extra/raptor/cron/cron.factor b/extra/raptor/cron/cron.factor old mode 100644 new mode 100755 index 8158a03286..e20598d2eb --- a/extra/raptor/cron/cron.factor +++ b/extra/raptor/cron/cron.factor @@ -1,6 +1,6 @@ USING: kernel namespaces threads sequences calendar - combinators.cleave combinators.lib ; + combinators.cleave combinators.lib debugger ; IN: raptor.cron @@ -43,9 +43,9 @@ C: when ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : recurring-job ( when quot -- ) - [ swap when=now? [ call ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ; + [ swap when=now? [ try ] [ drop ] if 60000 sleep ] [ recurring-job ] 2bi ; -: schedule ( when quot -- ) [ recurring-job ] curry curry in-thread ; +: schedule ( when quot -- ) [ recurring-job ] 2curry in-thread ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/extra/smtp/smtp-tests.factor b/extra/smtp/smtp-tests.factor old mode 100644 new mode 100755 index 9a357fdc7d..eda8d7cc1f --- a/extra/smtp/smtp-tests.factor +++ b/extra/smtp/smtp-tests.factor @@ -1,4 +1,4 @@ -USING: smtp tools.test io.streams.string io.logging threads +USING: smtp tools.test io.streams.string threads smtp.server kernel sequences namespaces ; IN: temporary diff --git a/extra/smtp/smtp.factor b/extra/smtp/smtp.factor old mode 100644 new mode 100755 index 77bfb6cd82..211fbbcabd --- a/extra/smtp/smtp.factor +++ b/extra/smtp/smtp.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: namespaces io kernel io.logging io.sockets sequences +USING: namespaces io kernel logging io.sockets sequences combinators sequences.lib splitting assocs strings math.parser random system calendar ; @@ -12,21 +12,18 @@ SYMBOL: smtp-port 25 smtp-port set-global SYMBOL: read-timeout 60000 read-timeout set-global SYMBOL: esmtp t esmtp set-global -: log-smtp-connection ( host port -- ) - [ - "Establishing SMTP connection to " % swap % ":" % # - ] "" make log-message ; +: log-smtp-connection ( host port -- ) 2drop ; + +\ log-smtp-connection NOTICE add-input-logging : with-smtp-connection ( quot -- ) - [ - smtp-host get smtp-port get - 2dup log-smtp-connection - [ - smtp-domain [ host-name or ] change - read-timeout get stdio get set-timeout - call - ] with-stream - ] with-log-stdio ; inline + smtp-host get smtp-port get + 2dup log-smtp-connection + [ + smtp-domain [ host-name or ] change + read-timeout get stdio get set-timeout + call + ] with-stream ; inline : crlf "\r\n" write ; @@ -58,20 +55,20 @@ SYMBOL: esmtp t esmtp set-global : quit ( -- ) "QUIT" write crlf ; -: log-response ( string -- ) "SMTP: " swap append log-message ; +LOG: smtp-response DEBUG : check-response ( response -- ) { - { [ dup "220" head? ] [ log-response ] } - { [ dup "235" swap subseq? ] [ log-response ] } - { [ dup "250" head? ] [ log-response ] } - { [ dup "221" head? ] [ log-response ] } - { [ dup "bye" head? ] [ log-response ] } + { [ dup "220" head? ] [ smtp-response ] } + { [ dup "235" swap subseq? ] [ smtp-response ] } + { [ dup "250" head? ] [ smtp-response ] } + { [ dup "221" head? ] [ smtp-response ] } + { [ dup "bye" head? ] [ smtp-response ] } { [ dup "4" head? ] [ "server busy" throw ] } - { [ dup "354" head? ] [ log-response ] } - { [ dup "50" head? ] [ log-response "syntax error" throw ] } - { [ dup "53" head? ] [ log-response "invalid authentication data" throw ] } - { [ dup "55" head? ] [ log-response "fatal error" throw ] } + { [ dup "354" head? ] [ smtp-response ] } + { [ dup "50" head? ] [ smtp-response "syntax error" throw ] } + { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] } + { [ dup "55" head? ] [ smtp-response "fatal error" throw ] } { [ t ] [ "unknown error" throw ] } } cond ; @@ -80,7 +77,7 @@ SYMBOL: esmtp t esmtp set-global : process-multiline ( multiline -- response ) >r readln r> 2dup " " append head? [ - drop dup log-response + drop dup smtp-response ] [ swap check-response process-multiline ] if ; diff --git a/extra/tools/annotations/annotations.factor b/extra/tools/annotations/annotations.factor index cd0d574083..6dee51cbc0 100755 --- a/extra/tools/annotations/annotations.factor +++ b/extra/tools/annotations/annotations.factor @@ -7,23 +7,31 @@ IN: tools.annotations : reset ( word -- ) dup "unannotated-def" word-prop [ [ - dup "unannotated-def" word-prop define + dup dup "unannotated-def" word-prop define ] with-compilation-unit + f "unannotated-def" set-word-prop ] [ drop ] if ; : annotate ( word quot -- ) + over "unannotated-def" word-prop [ + "Cannot annotate a word twice" throw + ] when [ over dup word-def "unannotated-def" set-word-prop >r dup word-def r> call define ] with-compilation-unit ; inline +: word-inputs ( word -- seq ) + stack-effect [ + >r datastack r> effect-in length tail* + ] [ + datastack + ] if* ; + : entering ( str -- ) "/-- Entering: " write dup . - stack-effect [ - >r datastack r> effect-in length tail* stack. - ] [ - .s - ] if* "\\--" print flush ; + word-inputs stack. + "\\--" print flush ; : leaving ( str -- ) "/-- Leaving: " write dup . diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 7aefbc8aaa..48de69b025 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -127,6 +127,7 @@ MEMO: all-vocabs-seq ( -- seq ) { [ "windows." ?head ] [ t ] } { [ "cocoa" ?head ] [ t ] } { [ ".test" ?tail ] [ t ] } + { [ "raptor" ?head ] [ t ] } { [ dup "tools.deploy.app" = ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/webapps/file/file.factor b/extra/webapps/file/file.factor index 110b90f84a..552f5e0977 100755 --- a/extra/webapps/file/file.factor +++ b/extra/webapps/file/file.factor @@ -3,7 +3,7 @@ USING: calendar html io io.files kernel math math.parser http.server.responders http.server.templating namespaces parser sequences strings assocs hashtables debugger http.mime sorting -html.elements ; +html.elements logging ; IN: webapps.file @@ -58,6 +58,8 @@ SYMBOL: page [ [ dup page set run-template-file ] with-scope ] try drop ; +\ run-page DEBUG add-input-logging + : include-page ( filename -- ) "doc-root" get swap path+ run-page ; @@ -69,6 +71,8 @@ SYMBOL: page dup mime-type dup "application/x-factor-server-page" = [ drop serve-fhtml ] [ serve-static ] if ; +\ serve-file NOTICE add-input-logging + : file. ( name dirp -- ) [ "/" append ] when dup write ; @@ -104,15 +108,15 @@ SYMBOL: page ] if ; : serve-object ( filename -- ) - dup directory? [ serve-directory ] [ serve-file ] if ; + serving-path dup exists? [ + dup directory? [ serve-directory ] [ serve-file ] if + ] [ + drop "404 not found" httpd-error + ] if ; : file-responder ( -- ) "doc-root" get [ - "argument" get serving-path dup exists? [ - serve-object - ] [ - drop "404 not found" httpd-error - ] if + "argument" get serve-object ] [ "404 doc-root not set" httpd-error ] if ; diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index b777780e11..a9fd443fe6 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -2,7 +2,7 @@ USING: sequences rss arrays concurrency kernel sorting html.elements io assocs namespaces math threads vocabs html furnace http.server.templating calendar math.parser splitting continuations debugger system http.server.responders -xml.writer prettyprint io.logging ; +xml.writer prettyprint logging ; IN: webapps.planet : print-posting-summary ( posting -- ) @@ -75,27 +75,19 @@ SYMBOL: cached-postings SYMBOL: last-update -: fetch-feed ( triple -- feed ) - second - "Fetching " over append log-message - dup download-feed feed-entries - "Done fetching " swap append log-message ; - : ( author entry -- entry' ) clone [ ": " swap entry-title 3append ] keep [ set-entry-title ] keep ; -: ?fetch-feed ( triple -- feed/f ) - [ - fetch-feed - ] [ - swap [ . error. ] to-log-stream f - ] recover ; +: fetch-feed ( url -- feed ) + download-feed feed-entries ; + +\ fetch-feed DEBUG add-error-logging : fetch-blogroll ( blogroll -- entries ) dup 0 - swap [ ?fetch-feed ] parallel-map + swap [ fetch-feed ] parallel-map [ [ ] with map ] 2map concat ; : sort-entries ( entries -- entries' ) From 6187a1e5e14978eec4a87e8f2ab094b20a9a8e0b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 17:55:31 -0600 Subject: [PATCH 091/194] Improved http.client, bootstrap.image.{download,upload} --- core/bootstrap/image/image.factor | 34 ++++++++++++------- extra/benchmark/bootstrap2/bootstrap2.factor | 4 +-- extra/bootstrap/image/download/authors.txt | 1 + .../bootstrap/image/download/download.factor | 25 ++++++++++++++ extra/bootstrap/image/download/summary.txt | 1 + extra/bootstrap/image/upload/authors.txt | 1 + extra/bootstrap/image/upload/summary.txt | 1 + extra/bootstrap/image/upload/upload.factor | 25 ++++++++++++++ extra/crypto/sha1/sha1.factor | 11 +++--- extra/http/client/client.factor | 27 +++++++-------- extra/io/server/server.factor | 3 +- extra/rss/rss.factor | 2 +- extra/tools/deploy/backend/backend.factor | 7 ++-- extra/webapps/fjsc/fjsc.factor | 2 +- extra/yahoo/yahoo.factor | 4 +-- 15 files changed, 102 insertions(+), 46 deletions(-) create mode 100644 extra/bootstrap/image/download/authors.txt create mode 100644 extra/bootstrap/image/download/download.factor create mode 100644 extra/bootstrap/image/download/summary.txt create mode 100644 extra/bootstrap/image/upload/authors.txt create mode 100644 extra/bootstrap/image/upload/summary.txt create mode 100644 extra/bootstrap/image/upload/upload.factor diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 3dadee5193..7452e31cf8 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -10,6 +10,23 @@ definitions debugger float-arrays quotations.private combinators.private combinators ; IN: bootstrap.image +: my-arch ( -- arch ) + cpu dup "ppc" = [ os "-" rot 3append ] when ; + +: boot-image-name ( arch -- string ) + "boot." swap ".image" 3append ; + +: my-boot-image-name ( -- string ) + my-arch boot-image-name ; + +: images ( -- seq ) + { + "x86.32" + "x86.64" + "linux-ppc" "macosx-ppc" + ! "arm" + } ; + le write ] curry each ] if ; -: image-name - "boot." architecture get ".image" 3append resource-path ; - : write-image ( image filename -- ) "Writing image to " write dup write "..." print flush [ (write-image) ] with-stream ; @@ -415,16 +429,10 @@ PRIVATE> begin-image "resource:/core/bootstrap/stage1.factor" run-file end-image - image get image-name write-image + image get + architecture get boot-image-name resource-path + write-image ] with-variable ; -: my-arch ( -- arch ) - cpu dup "ppc" = [ os "-" rot 3append ] when ; - : make-images ( -- ) - { - "x86.32" - "x86.64" - "linux-ppc" "macosx-ppc" - ! "arm" - } [ make-image ] each ; + images [ make-image ] each ; diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index bde92a2260..54bc73f4a1 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -1,4 +1,4 @@ -USING: io.files io.launcher system tools.deploy.backend +USING: io.files io.launcher system bootstrap.image namespaces sequences kernel ; IN: benchmark.bootstrap2 @@ -6,7 +6,7 @@ IN: benchmark.bootstrap2 "." resource-path cd [ vm , - "-i=" boot-image-name append , + "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , ] { } make run-process drop ; diff --git a/extra/bootstrap/image/download/authors.txt b/extra/bootstrap/image/download/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/download/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor new file mode 100644 index 0000000000..deed045221 --- /dev/null +++ b/extra/bootstrap/image/download/download.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.image.download +USING: http.client crypto.md5 splitting assocs kernel io.files +bootstrap.image sequences io ; + +: url "http://factorcode.org/images/latest/" ; + +: download-checksums ( -- alist ) + url "checksums.txt" append http-get + string-lines [ " " split1 ] { } map>assoc ; + +: need-new-image? ( image -- ? ) + dup exists? + [ dup file>md5str swap download-checksums at = not ] + [ drop t ] if ; + +: download-image ( arch -- ) + boot-image-name dup need-new-image? [ + "Downloading " write dup write "..." print + url swap append download + ] [ + "Boot image up to date" print + drop + ] if ; diff --git a/extra/bootstrap/image/download/summary.txt b/extra/bootstrap/image/download/summary.txt new file mode 100644 index 0000000000..fc0ed97ff1 --- /dev/null +++ b/extra/bootstrap/image/download/summary.txt @@ -0,0 +1 @@ +Smart image downloader utility which first checks MD5 checksum diff --git a/extra/bootstrap/image/upload/authors.txt b/extra/bootstrap/image/upload/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/bootstrap/image/upload/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/bootstrap/image/upload/summary.txt b/extra/bootstrap/image/upload/summary.txt new file mode 100644 index 0000000000..85497270a2 --- /dev/null +++ b/extra/bootstrap/image/upload/summary.txt @@ -0,0 +1 @@ +Image upload utility diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor new file mode 100644 index 0000000000..a9f5d1dcd4 --- /dev/null +++ b/extra/bootstrap/image/upload/upload.factor @@ -0,0 +1,25 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: bootstrap.image.upload +USING: http.client crypto.md5 splitting assocs kernel io.files +bootstrap.image sequences io namespaces io.launcher math ; + +: destination "slava@factorcode.org:www/images/latest/" ; + +: boot-image-names images [ boot-image-name ] map ; + +: compute-checksums ( -- ) + "checksums.txt" [ + boot-image-names [ dup write bl file>md5str print ] each + ] with-file-out ; + +: upload-images ( -- ) + [ + "scp" , boot-image-names % "checksums.txt" , destination , + ] { } make run-process + wait-for-process zero? [ "Upload failed" throw ] unless ; + +: new-images ( -- ) + make-images compute-checksums upload-images ; + +MAIN: new-images diff --git a/extra/crypto/sha1/sha1.factor b/extra/crypto/sha1/sha1.factor index 94a51288bb..f6dfbcd031 100644 --- a/extra/crypto/sha1/sha1.factor +++ b/extra/crypto/sha1/sha1.factor @@ -48,14 +48,13 @@ SYMBOL: K ! f(t;B,C,D) = (B AND C) OR (B AND D) OR (C AND D) (40 <= t <= 59) ! f(t;B,C,D) = B XOR C XOR D (60 <= t <= 79) : sha1-f ( B C D t -- f_tbcd ) - #! Maybe use dispatch 20 /i { - { [ dup 0 = ] [ drop >r over bitnot r> bitand >r bitand r> bitor ] } - { [ dup 1 = ] [ drop bitxor bitxor ] } - { [ dup 2 = ] [ drop 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } - { [ dup 3 = ] [ drop bitxor bitxor ] } - } cond ; + { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] } + { 1 [ bitxor bitxor ] } + { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] } + { 3 [ bitxor bitxor ] } + } case ; : make-w ( str -- ) #! compute w, steps a-b of RFC 3174, section 6.1 diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index 8e6d8257a4..109bf17c40 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -47,32 +47,31 @@ DEFER: http-get-stream dispose "location" swap peek-at nip http-get-stream ] when ; +: default-timeout 60 1000 * over set-timeout ; + : http-get-stream ( url -- code headers stream ) #! Opens a stream for reading from an HTTP URL. parse-url over parse-host [ [ [ get-request read-response ] with-stream* ] keep + default-timeout ] [ ] [ dispose ] cleanup do-redirect ; -: http-get ( url -- code headers string ) - #! Opens a stream for reading from an HTTP URL. - [ - http-get-stream [ stdio get contents ] with-stream - ] with-scope ; +: success? ( code -- ? ) 200 = ; + +: check-response ( code headers stream -- stream ) + nip swap success? + [ dispose "HTTP download failed" throw ] unless ; + +: http-get ( url -- string ) + http-get-stream check-response contents ; : download-name ( url -- name ) file-name "?" split1 drop "/" ?tail drop ; -: default-timeout 60 1000 * over set-timeout ; - -: success? ( code -- ? ) 200 = ; - : download-to ( url file -- ) #! Downloads the contents of a URL to a file. - >r http-get-stream nip default-timeout swap success? [ - r> stream-copy - ] [ - r> drop dispose "HTTP download failed" throw - ] if ; + >r http-get-stream check-response + r> stream-copy ; : download ( url -- ) dup download-name download-to ; diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor index 829da27f6e..a23984c207 100755 --- a/extra/io/server/server.factor +++ b/extra/io/server/server.factor @@ -19,7 +19,8 @@ LOG: accepted-connection NOTICE : accept-loop ( server quot -- ) [ - >r accept r> [ with-client ] 2curry concurrency:spawn + >r accept r> [ with-client ] 2curry + concurrency:spawn drop ] 2keep accept-loop ; inline : server-loop ( server quot -- ) diff --git a/extra/rss/rss.factor b/extra/rss/rss.factor index be2f648189..0591c60014 100644 --- a/extra/rss/rss.factor +++ b/extra/rss/rss.factor @@ -78,7 +78,7 @@ C: entry : download-feed ( url -- feed ) #! Retrieve an news syndication file, return as a feed tuple. - http-get-stream rot 200 = [ + http-get-stream rot success? [ nip read-feed ] [ 2drop "Error retrieving newsfeed file" throw diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index 95d19712c0..c295f6369d 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -24,12 +24,9 @@ IN: tools.deploy.backend dup duplex-stream-out dispose copy-lines ; -: boot-image-name ( -- string ) - "boot." my-arch ".image" 3append ; - : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. - boot-image-name resource-path exists? + my-boot-image-name resource-path exists? [ my-arch make-image ] unless ; : ?, [ , ] [ drop ] if ; @@ -49,7 +46,7 @@ IN: tools.deploy.backend : staging-command-line ( config -- flags ) [ - "-i=" boot-image-name append , + "-i=" my-boot-image-name append , "-output-image=" over staging-image-name append , diff --git a/extra/webapps/fjsc/fjsc.factor b/extra/webapps/fjsc/fjsc.factor index 19dab4ed1b..55609c72f9 100755 --- a/extra/webapps/fjsc/fjsc.factor +++ b/extra/webapps/fjsc/fjsc.factor @@ -25,7 +25,7 @@ IN: webapps.fjsc : compile-url ( url -- ) #! Compile the factor code at the given url, return the javascript. dup "http:" head? [ "Unable to access remote sites." throw ] when - "http://" "Host" header-param rot 3append http-get 2nip compile "();" write flush ; + "http://" "Host" header-param rot 3append http-get compile "();" write flush ; \ compile-url { { "url" v-required } diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index 2c982306cd..1725c10a44 100644 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -26,6 +26,4 @@ C: result ] "" make ; : search-yahoo ( search num -- seq ) - query http-get 2nip - [ "Search failed" throw ] unless* - string>xml parse-yahoo ; + query http-get string>xml parse-yahoo ; From b08409884e72dc4879942a23c56c10167cf5695f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 18:03:01 -0600 Subject: [PATCH 092/194] Add try-everything for Ed --- core/vocabs/loader/loader-docs.factor | 5 ---- core/vocabs/loader/loader.factor | 34 +++++++++------------------ extra/tools/browser/browser.factor | 14 ++++++++--- extra/tools/test/test-docs.factor | 2 +- extra/tools/test/test.factor | 6 ++--- 5 files changed, 26 insertions(+), 35 deletions(-) diff --git a/core/vocabs/loader/loader-docs.factor b/core/vocabs/loader/loader-docs.factor index f8626f3370..379b300eaa 100755 --- a/core/vocabs/loader/loader-docs.factor +++ b/core/vocabs/loader/loader-docs.factor @@ -124,11 +124,6 @@ HELP: refresh { $values { "prefix" string } } { $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ; -HELP: require-all-error -{ $values { "vocabs" "a sequence of vocabularies" } } -{ $description "Throws a " { $link require-all-error } "." } -{ $error-description "Thrown by " { $link require-all } " if one or more vocabulary failed to load." } ; - HELP: refresh-all { $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 352ef9fe02..4fcb74df66 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -160,37 +160,25 @@ SYMBOL: load-help? drop ; ! third "Traceback" swap write-object ; -TUPLE: require-all-error vocabs ; +: load-failures. ( failures -- ) + [ load-error. nl ] each ; -: require-all-error ( vocabs -- ) - [ vocab-name ] map - \ require-all-error construct-boa throw ; - -M: require-all-error summary - drop "The require-all operation failed" ; - -: require-all ( vocabs -- ) - dup length 1 = [ first require ] [ +: require-all ( vocabs -- failures ) + [ [ [ - [ - [ require ] - [ error-continuation get 3array , ] - recover - ] each - ] { } make - dup empty? [ drop ] [ - dup [ load-error. nl ] each - keys require-all-error - ] if - ] with-compiler-errors - ] if ; + [ require ] + [ error-continuation get 3array , ] + recover + ] each + ] { } make + ] with-compiler-errors ; : do-refresh ( modified-sources modified-docs -- ) 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-all ; + append prune require-all drop ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 48de69b025..87b4ba9939 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -132,11 +132,17 @@ MEMO: all-vocabs-seq ( -- seq ) { [ t ] [ f ] } } cond nip ; -: load-everything ( -- ) +: filter-dangerous ( seq -- seq' ) + [ vocab-name dangerous? not ] subset ; + +: try-everything ( -- failures ) all-vocabs-seq - [ vocab-name dangerous? not ] subset + filter-dangerous require-all ; +: load-everything ( -- ) + try-everything drop ; + : unrooted-child-vocabs ( prefix -- seq ) dup empty? [ CHAR: . add ] unless vocabs @@ -155,7 +161,9 @@ MEMO: all-vocabs-seq ( -- seq ) : load-children ( prefix -- ) all-child-vocabs values concat - require-all ; + filter-dangerous + require-all + drop ; : vocab-status-string ( vocab -- string ) { diff --git a/extra/tools/test/test-docs.factor b/extra/tools/test/test-docs.factor index c027073398..b756f9279e 100755 --- a/extra/tools/test/test-docs.factor +++ b/extra/tools/test/test-docs.factor @@ -29,7 +29,7 @@ $nl { $subsection run-tests } { $subsection run-all-tests } "The following word prints failures:" -{ $subsection failures. } ; +{ $subsection test-failures. } ; ARTICLE: "tools.test" "Unit testing" "A unit test is a piece of code which starts with known input values, then compares the output of a word with an expected output, where the expected output is defined by the word's contract." diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 0b1a495e90..192a248161 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -80,7 +80,7 @@ M: expected-error summary dup first print-error "Traceback" swap third write-object ; -: failures. ( assoc -- ) +: test-failures. ( assoc -- ) dup [ nl dup empty? [ @@ -104,10 +104,10 @@ M: expected-error summary ] if ; : test ( prefix -- ) - run-tests failures. ; + run-tests test-failures. ; : run-all-tests ( prefix -- failures ) "" run-tests ; : test-all ( -- ) - run-all-tests failures. ; + run-all-tests test-failures. ; From 6bbbd3f9043a4162ce70e11acf3a3afc88bda7c9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 18:06:53 -0600 Subject: [PATCH 093/194] Forgot to call load-failures. --- core/vocabs/loader/loader.factor | 2 +- extra/tools/browser/browser.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index 4fcb74df66..a1276341b3 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -178,7 +178,7 @@ SYMBOL: load-help? 2dup [ f swap set-vocab-docs-loaded? ] each [ f swap set-vocab-source-loaded? ] each - append prune require-all drop ; + append prune require-all load-failures. ; : refresh ( prefix -- ) to-refresh do-refresh ; diff --git a/extra/tools/browser/browser.factor b/extra/tools/browser/browser.factor index 87b4ba9939..ae1901ff66 100755 --- a/extra/tools/browser/browser.factor +++ b/extra/tools/browser/browser.factor @@ -163,7 +163,7 @@ MEMO: all-vocabs-seq ( -- seq ) all-child-vocabs values concat filter-dangerous require-all - drop ; + load-failures. ; : vocab-status-string ( vocab -- string ) { From a2e6c372136f35a1d62a8add94293efbd8b52649 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 18:30:20 -0600 Subject: [PATCH 094/194] simplify builder.test --- extra/builder/builder.factor | 9 +++++-- extra/builder/test/test.factor | 48 ++++++++++++++++++++++------------ 2 files changed, 38 insertions(+), 19 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index 5e992ccc81..caa381ba5d 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -1,8 +1,8 @@ -USING: kernel io io.files io.launcher hashtables tools.deploy.backend +USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators ; + combinators bootstrap.image ; IN: builder @@ -82,6 +82,11 @@ VAR: stamp ] if + { + "git" "pull" "--no-summary" + "http://dharmatech.onigirihouse.com/factor.git" "master" + } run-process process-status + "/builds/" stamp> append make-directory "/builds/" stamp> append cd diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index fb9c62e2aa..2a867b1fbc 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,28 +7,42 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test +! : do-load ( -- ) +! [ +! [ load-everything ] +! [ require-all-error-vocabs "../load-everything-log" log-object ] +! recover +! ] +! "../load-everything-time" log-runtime ; + : do-load ( -- ) - [ - [ load-everything ] - [ require-all-error-vocabs "../load-everything-log" log-object ] - recover - ] - "../load-everything-time" log-runtime ; + [ try-everything ] "../load-everything-time" log-runtime + dup empty? + [ drop ] + [ "../load-everything-log" log-object ] + if ; + +! : do-tests ( -- ) +! "" child-vocabs +! [ vocab-source-loaded? ] subset +! [ vocab-tests-path ] map +! [ dup [ ?resource-path exists? ] when ] subset +! [ dup run-test ] { } map>assoc +! [ second empty? not ] subset +! dup empty? +! [ drop ] +! [ +! "../failing-tests" +! [ [ nl failures. ] assoc-each ] +! with-stream +! ] +! if ; : do-tests ( -- ) - "" child-vocabs - [ vocab-source-loaded? ] subset - [ vocab-tests-path ] map - [ dup [ ?resource-path exists? ] when ] subset - [ dup run-test ] { } map>assoc - [ second empty? not ] subset + run-all-tests keys dup empty? [ drop ] - [ - "../failing-tests" - [ [ nl failures. ] assoc-each ] - with-stream - ] + [ "../failing-tests" log-object ] if ; : do-all ( -- ) do-load do-tests ; From 4dfc151c89c04828d0beabf3a701deeaad48146d Mon Sep 17 00:00:00 2001 From: Aaron Schaefer Date: Thu, 7 Feb 2008 19:48:00 -0500 Subject: [PATCH 095/194] Solution to Project Euler problem 79 --- extra/project-euler/079/079.factor | 65 ++++++++++++++++++++++++ extra/project-euler/079/keylog.txt | 50 ++++++++++++++++++ extra/project-euler/project-euler.factor | 4 +- 3 files changed, 117 insertions(+), 2 deletions(-) create mode 100644 extra/project-euler/079/079.factor create mode 100644 extra/project-euler/079/keylog.txt diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor new file mode 100644 index 0000000000..d28484c881 --- /dev/null +++ b/extra/project-euler/079/079.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs hashtables io.files kernel math math.parser namespaces sequences ; +IN: project-euler.079 + +! http://projecteuler.net/index.php?section=problems&id=79 + +! DESCRIPTION +! ----------- + +! A common security method used for online banking is to ask the user for three +! random characters from a passcode. For example, if the passcode was 531278, +! they may asked for the 2nd, 3rd, and 5th characters; the expected reply would +! be: 317. + +! The text file, keylog.txt, contains fifty successful login attempts. + +! Given that the three characters are always asked for in order, analyse the +! file so as to determine the shortest possible secret passcode of unknown +! length. + + +! SOLUTION +! -------- + +edges ( seq -- seq ) + [ + [ string>digits [ 2 head , ] keep 2 tail* , ] each + ] { } make ; + +: find-source ( seq -- elt ) + dup values swap keys [ prune ] 2apply seq-diff + dup empty? [ "Topological sort failed" throw ] [ first ] if ; + +: remove-source ( seq elt -- seq ) + [ swap member? not ] curry subset ; + +: (topological-sort) ( seq -- ) + dup length 1 > [ + dup find-source dup , remove-source (topological-sort) + ] [ + dup empty? [ drop ] [ first [ , ] each ] if + ] if ; + +PRIVATE> + +: topological-sort ( seq -- seq ) + [ [ (topological-sort) ] { } make ] keep + concat prune dupd seq-diff append ; + +: euler079 ( -- answer ) + source-079 >edges topological-sort 10 swap digits>integer ; + +! [ euler079 ] 100 ave-time +! 2 ms run / 0 ms GC ave time - 100 trials + +! TODO: prune and seq-diff are relatively slow; topological sort could be +! cleaned up and generalized much better, but it works for this problem + +MAIN: euler079 diff --git a/extra/project-euler/079/keylog.txt b/extra/project-euler/079/keylog.txt new file mode 100644 index 0000000000..b6f9903128 --- /dev/null +++ b/extra/project-euler/079/keylog.txt @@ -0,0 +1,50 @@ +319 +680 +180 +690 +129 +620 +762 +689 +762 +318 +368 +710 +720 +710 +629 +168 +160 +689 +716 +731 +736 +729 +316 +729 +729 +710 +769 +290 +719 +680 +318 +389 +162 +289 +162 +718 +729 +319 +790 +680 +890 +362 +319 +760 +316 +729 +380 +319 +728 +716 diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index 36a9069d77..c3db60c481 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -14,8 +14,8 @@ USING: definitions io io.files kernel math math.parser project-euler.ave-time project-euler.037 project-euler.038 project-euler.039 project-euler.040 project-euler.041 project-euler.042 project-euler.043 project-euler.044 project-euler.048 project-euler.052 project-euler.067 project-euler.075 - project-euler.097 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.079 project-euler.097 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler Date: Thu, 7 Feb 2008 20:25:03 -0500 Subject: [PATCH 096/194] Fix PE solutions using old math.parser --- extra/project-euler/041/041.factor | 2 +- extra/project-euler/043/043.factor | 6 +++--- extra/project-euler/079/079.factor | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/project-euler/041/041.factor b/extra/project-euler/041/041.factor index 60017f39a1..14084cc01d 100644 --- a/extra/project-euler/041/041.factor +++ b/extra/project-euler/041/041.factor @@ -32,7 +32,7 @@ IN: project-euler.041 : euler041 ( -- answer ) { 7 6 5 4 3 2 1 } all-permutations - [ 10 swap digits>integer ] map [ prime? ] find nip ; + [ 10 digits>integer ] map [ prime? ] find nip ; ! [ euler041 ] 100 ave-time ! 107 ms run / 7 ms GC ave time - 100 trials diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor index abe455e273..54d75c6980 100644 --- a/extra/project-euler/043/043.factor +++ b/extra/project-euler/043/043.factor @@ -36,7 +36,7 @@ IN: project-euler.043 integer swap mod zero? ; + [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ; : interesting? ( seq -- ? ) { @@ -53,7 +53,7 @@ PRIVATE> : euler043 ( -- answer ) 1234567890 number>digits all-permutations - [ interesting? ] subset [ 10 swap digits>integer ] map sum ; + [ interesting? ] subset [ 10 digits>integer ] map sum ; ! [ euler043 ] time ! 125196 ms run / 19548 ms GC time @@ -89,7 +89,7 @@ PRIVATE> PRIVATE> : euler043a ( -- answer ) - interesting-pandigitals [ 10 swap digits>integer ] sigma ; + interesting-pandigitals [ 10 digits>integer ] sigma ; ! [ euler043a ] 100 ave-time ! 19 ms run / 1 ms GC ave time - 100 trials diff --git a/extra/project-euler/079/079.factor b/extra/project-euler/079/079.factor index d28484c881..f068db77ec 100644 --- a/extra/project-euler/079/079.factor +++ b/extra/project-euler/079/079.factor @@ -54,7 +54,7 @@ PRIVATE> concat prune dupd seq-diff append ; : euler079 ( -- answer ) - source-079 >edges topological-sort 10 swap digits>integer ; + source-079 >edges topological-sort 10 digits>integer ; ! [ euler079 ] 100 ave-time ! 2 ms run / 0 ms GC ave time - 100 trials From 1c3efa89d214ad2b4f9f6b468de2519c6bdbae2c Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Thu, 7 Feb 2008 19:50:26 -0600 Subject: [PATCH 097/194] builder improvements (download-image, simpler do-all) --- extra/builder/builder.factor | 12 ++++++------ extra/builder/test/test.factor | 24 ------------------------ 2 files changed, 6 insertions(+), 30 deletions(-) diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor index caa381ba5d..9af79efb29 100755 --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -2,7 +2,7 @@ USING: kernel io io.files io.launcher hashtables system continuations namespaces sequences splitting math.parser prettyprint tools.time calendar bake vars http.client - combinators bootstrap.image ; + combinators bootstrap.image bootstrap.image.download ; IN: builder @@ -70,7 +70,6 @@ VAR: stamp "pull" "--no-summary" "git://factorcode.org/git/factor.git" - ! "http://dharmatech.onigirihouse.com/factor.git" "master" } run-process process-status @@ -85,7 +84,7 @@ VAR: stamp { "git" "pull" "--no-summary" "http://dharmatech.onigirihouse.com/factor.git" "master" - } run-process process-status + } run-process drop "/builds/" stamp> append make-directory "/builds/" stamp> append cd @@ -112,14 +111,15 @@ VAR: stamp "builder: vm compile" throw ] if - [ "http://factorcode.org/images/latest/" boot-image-name append download ] + [ my-arch download-image ] + [ ] [ "builder: image download" email-string ] - recover + cleanup `{ { +arguments+ { ,[ factor-binary ] - ,[ "-i=" boot-image-name append ] + ,[ "-i=" my-boot-image-name append ] "-no-user-init" } } { +stdout+ "../boot-log" } diff --git a/extra/builder/test/test.factor b/extra/builder/test/test.factor index 2a867b1fbc..c887c668e6 100644 --- a/extra/builder/test/test.factor +++ b/extra/builder/test/test.factor @@ -7,14 +7,6 @@ USING: kernel sequences assocs builder continuations vocabs vocabs.loader IN: builder.test -! : do-load ( -- ) -! [ -! [ load-everything ] -! [ require-all-error-vocabs "../load-everything-log" log-object ] -! recover -! ] -! "../load-everything-time" log-runtime ; - : do-load ( -- ) [ try-everything ] "../load-everything-time" log-runtime dup empty? @@ -22,22 +14,6 @@ IN: builder.test [ "../load-everything-log" log-object ] if ; -! : do-tests ( -- ) -! "" child-vocabs -! [ vocab-source-loaded? ] subset -! [ vocab-tests-path ] map -! [ dup [ ?resource-path exists? ] when ] subset -! [ dup run-test ] { } map>assoc -! [ second empty? not ] subset -! dup empty? -! [ drop ] -! [ -! "../failing-tests" -! [ [ nl failures. ] assoc-each ] -! with-stream -! ] -! if ; - : do-tests ( -- ) run-all-tests keys dup empty? From 48b96a9e5bf8734e7b2fb484f533e668fc6ae6ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 19:51:37 -0600 Subject: [PATCH 098/194] Documentation updates, tags updates --- extra/asn1/tags.txt | 1 + extra/db/authors.txt | 1 + extra/db/summary.txt | 1 + extra/db/tags.txt | 1 + extra/furnace/tags.txt | 1 + extra/logging/analysis/analysis-docs.factor | 31 +++++ extra/logging/analysis/analysis.factor | 3 +- extra/logging/analysis/tags.txt | 1 + extra/logging/insomniac/insomniac-docs.factor | 44 ++++++ extra/logging/insomniac/insomniac.factor | 23 ++-- extra/logging/insomniac/tags.txt | 1 + extra/logging/logging-docs.factor | 130 ++++++++++++++++++ extra/logging/logging.factor | 26 ++-- extra/logging/parser/parser-docs.factor | 21 +++ extra/logging/parser/tags.txt | 1 + extra/logging/server/server-docs.factor | 4 + extra/logging/server/server.factor | 12 +- extra/logging/server/tags.txt | 1 + extra/logging/summary.txt | 2 +- extra/logging/tags.txt | 1 + 20 files changed, 277 insertions(+), 29 deletions(-) create mode 100644 extra/asn1/tags.txt create mode 100644 extra/db/authors.txt create mode 100644 extra/db/summary.txt create mode 100644 extra/db/tags.txt create mode 100644 extra/furnace/tags.txt create mode 100644 extra/logging/analysis/analysis-docs.factor create mode 100644 extra/logging/analysis/tags.txt create mode 100644 extra/logging/insomniac/insomniac-docs.factor create mode 100644 extra/logging/insomniac/tags.txt create mode 100644 extra/logging/logging-docs.factor create mode 100644 extra/logging/parser/parser-docs.factor create mode 100644 extra/logging/parser/tags.txt create mode 100644 extra/logging/server/server-docs.factor create mode 100644 extra/logging/server/tags.txt create mode 100644 extra/logging/tags.txt diff --git a/extra/asn1/tags.txt b/extra/asn1/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/asn1/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/db/authors.txt b/extra/db/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/db/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/db/summary.txt b/extra/db/summary.txt new file mode 100644 index 0000000000..daebf38da6 --- /dev/null +++ b/extra/db/summary.txt @@ -0,0 +1 @@ +Relational database abstraction layer diff --git a/extra/db/tags.txt b/extra/db/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/db/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/furnace/tags.txt b/extra/furnace/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/furnace/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/analysis/analysis-docs.factor b/extra/logging/analysis/analysis-docs.factor new file mode 100644 index 0000000000..2919f2bcd4 --- /dev/null +++ b/extra/logging/analysis/analysis-docs.factor @@ -0,0 +1,31 @@ +USING: help.markup help.syntax assocs logging math ; +IN: logging.analysis + +HELP: analyze-entries +{ $values { "entries" "a sequence of log entries" } { "word-names" "a sequence of strings" } { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Analyzes log entries:" + { $list + { "Errors (entries with level " { $link ERROR } " or " { $link CRITICAL } ") are collected into the " { $snippet "errors" } " sequence." } + { "All logging words are tallied into " { $snippet "word-histogram" } " - for example, this can tell you about HTTP server hit counts." } + { "All words listed in " { $snippet "word-names" } " have their messages tallied into " { $snippet "message-histogram" } " - for example, this can tell you about popular URLs on an HTTP server." } + } +} ; + +HELP: analysis. +{ $values { "errors" "a sequence of log entries" } { "word-histogram" assoc } { "message-histogram" assoc } } +{ $description "Prints a logging report output by " { $link analyze-entries } ". Formatted output words are used, so the report looks nice in the UI or if sent to an HTML stream." } ; + +HELP: analyze-log +{ $values { "service" "a log service name" } { "n" integer } { "word-names" "a sequence of strings" } } +{ $description "Analyzes a log file and prints a formatted report. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +ARTICLE: "logging.analysis" "Log analysis" +"The " { $vocab-link "logging.analysis" } " vocabulary builds on the " { $vocab-link "logging.parser" } " vocabulary. It parses log files and produces formatted summary reports. It is used by the " { $vocab-link "logger.insomniac" } " vocabulary to e-mail daily reports." +$nl +"Print log file summary:" +{ $subsection analyze-log } +"Factors:" +{ $subsection analyze-entries } +{ $subsection analysis. } ; + +ABOUT: "logging.analysis" diff --git a/extra/logging/analysis/analysis.factor b/extra/logging/analysis/analysis.factor index df53a8e70b..b530c09b22 100755 --- a/extra/logging/analysis/analysis.factor +++ b/extra/logging/analysis/analysis.factor @@ -11,6 +11,7 @@ SYMBOL: message-histogram : analyze-entry ( entry -- ) dup second ERROR eq? [ dup errors get push ] when + dup second CRITICAL eq? [ dup errors get push ] when 1 over third word-histogram get at+ dup third word-names get member? [ 1 over 1 tail message-histogram get at+ @@ -65,5 +66,5 @@ SYMBOL: message-histogram "==== ERRORS:" print nl errors. ; -: log-analysis ( lines word-names -- ) +: analyze-log ( lines word-names -- ) >r parse-log r> analyze-entries analysis. ; diff --git a/extra/logging/analysis/tags.txt b/extra/logging/analysis/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/analysis/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/insomniac/insomniac-docs.factor b/extra/logging/insomniac/insomniac-docs.factor new file mode 100644 index 0000000000..64ac3b4ff6 --- /dev/null +++ b/extra/logging/insomniac/insomniac-docs.factor @@ -0,0 +1,44 @@ +USING: help.markup help.syntax assocs strings logging +logging.analysis smtp ; +IN: logging.insomniac + +HELP: insomniac-smtp-host +{ $var-description "An SMTP server to use for e-mailing log reports. If not set, the value of " { $link smtp-host } " is used." } ; + +HELP: insomniac-smtp-port +{ $var-description "An SMTP server port to use for e-mailing log reports. If not set, the value of " { $link smtp-port } " is used." } ; + +HELP: insomniac-sender +{ $var-description "The originating e-mail address for mailing log reports. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: insomniac-recipients +{ $var-description "A sequence of e-mail addresses to mail log reports to. Must be set before " { $vocab-link "logging.insomniac" } " is used." } ; + +HELP: ?analyze-log +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } { "string" string } } +{ $description "Analyzes the most recent log and outputs the string analysis, or outputs " { $link f } " if it doesn't exist." } +{ $see-also analyze-log } ; + +HELP: email-log-report +{ $values { "service" "a log service name" } { "word-names" "a sequence of strings" } } +{ $description "E-mails a log report for the given log service. The " { $link insomniac-smtp-host } ", " { $link insomniac-sender } " and " { $link insomniac-recipients } " parameters must be set up first. The " { $snippet "word-names" } " parameter is documented in " { $link analyze-entries } "." } ; + +HELP: schedule-insomniac +{ $values { "alist" "a sequence of pairs of shape " { $snippet "{ service word-names }" } } } +{ $description "Starts a thread which e-mails log reports and rotates logs daily." } ; + +ARTICLE: "logging.insomniac" "Automating log analysis and rotation" +"The " { $vocab-link "logging.insomniac" } " vocabulary builds on the " { $vocab-link "logging.analysis" } " vocabulary. It provides support for e-mailing log reports and rotating logs on a daily basis. E-mails are sent using the " { $vocab-link "smtp" } " vocabulary." +$nl +"Required configuration parameters:" +{ $subsection insomniac-sender } +{ $subsection insomniac-recipients } +"Optional configuration parameters:" +{ $subsection insomniac-smtp-host } +{ $subsection insomniac-smtp-port } +"E-mailing a one-off report:" +{ $subsection email-log-report } +"E-mailing reports and rotating logs on a daily basis:" +{ $subsection schedule-insomniac } ; + +ABOUT: "logging.insomniac" diff --git a/extra/logging/insomniac/insomniac.factor b/extra/logging/insomniac/insomniac.factor index b065dec9d3..d79eca3495 100755 --- a/extra/logging/insomniac/insomniac.factor +++ b/extra/logging/insomniac/insomniac.factor @@ -1,19 +1,17 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: logging.analysis logging.server logging smtp io.sockets -kernel io.files io.streams.string namespaces raptor.cron ; +kernel io.files io.streams.string namespaces raptor.cron assocs ; IN: logging.insomniac -SYMBOL: insomniac-config - SYMBOL: insomniac-smtp-host SYMBOL: insomniac-smtp-port SYMBOL: insomniac-sender SYMBOL: insomniac-recipients -: ?log-analysis ( service word-names -- string/f ) +: ?analyze-log ( service word-names -- string/f ) >r log-path 1 log# dup exists? [ - file-lines r> [ log-analysis ] string-out + file-lines r> [ analyze-log ] string-out ] [ r> 2drop f ] if ; @@ -31,7 +29,7 @@ SYMBOL: insomniac-recipients : (email-log-report) ( service word-names -- ) [ over >r - ?log-analysis dup [ + ?analyze-log dup [ r> email-subject insomniac-recipients get insomniac-sender get @@ -39,11 +37,12 @@ SYMBOL: insomniac-recipients ] [ r> 2drop ] if ] with-insomniac-smtp ; +\ (email-log-report) NOTICE add-error-logging + : email-log-report ( service word-names -- ) - (email-log-report) ; + "logging.insomniac" [ (email-log-report) ] with-logging ; -\ email-log-report NOTICE add-error-logging - -: schedule-insomniac ( service word-names -- ) - { 25 } { 6 } f f f -rot - [ email-log-report ] 2curry schedule ; +: schedule-insomniac ( alist -- ) + { 25 } { 6 } f f f -rot [ + [ email-log-report ] assoc-each rotate-logs + ] 2curry schedule ; diff --git a/extra/logging/insomniac/tags.txt b/extra/logging/insomniac/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/insomniac/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/logging-docs.factor b/extra/logging/logging-docs.factor new file mode 100644 index 0000000000..3b112e0166 --- /dev/null +++ b/extra/logging/logging-docs.factor @@ -0,0 +1,130 @@ +IN: logging +USING: help.markup help.syntax assocs math calendar +logging.server strings words quotations ; + +HELP: DEBUG +{ $description "Log level for debug messages." } ; + +HELP: NOTICE +{ $description "Log level for ordinary messages." } ; + +HELP: ERROR +{ $description "Log level for error messages." } ; + +HELP: CRITICAL +{ $description "Log level for critical errors which require immediate attention." } ; + +ARTICLE: "logging.levels" "Log levels" +"Several log levels are supported, from lowest to highest:" +{ $subsection DEBUG } +{ $subsection NOTICE } +{ $subsection ERROR } +{ $subsection CRITICAL } ; + +ARTICLE: "logging.files" "Log files" +"Each application that wishes to use logging must choose a log service name; the following combinator should wrap the top level of the application:" +{ $subsection with-logging } +"Log messages are written to " { $snippet "log-root/service/1.log" } ", where" +{ $list + { { $snippet "log-root" } " is the Factor source directory by default, but can be overriden with the " { $link log-root } " variable" } + { { $snippet "service" } " is the service name" } +} +"You can get the log path for a service:" +{ $subsection log-path } +{ $subsection log# } +"New log entries are always sent to " { $snippet "1.log" } " but " { $link "logging.rotation" } " moves " { $snippet "1.log" } " to " { $snippet "2.log" } ", " { $snippet "2.log" } " to " { $snippet "3.log" } ", and so on." ; + +HELP: log-message +{ $values { "msg" string } { "word" word } { "level" "a log level" } } +{ $description "Sends a message to the current log. Does nothing if not executing in a dynamic scope established by " { $link with-logging } "." } ; + +HELP: add-logging +{ $values { "word" word } } +{ $description "Causes the word to log a message every time it is called." } ; + +HELP: add-input-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-output-logging +{ $values { "word" word } } +{ $description "Causes the word to log its output values every time it is called. The word must have a stack effect declaration." } ; + +HELP: add-error-logging +{ $values { "word" word } } +{ $description "Causes the word to log its input values and any errors it throws." +$nl +"If the word is not executed in a dynamic scope established by " { $link with-logging } ", its behavior is unchanged, and any errors it throws are passed to the caller." +$nl +"If called from a logging context, its input values are logged, and if it throws an error, the error is logged and the word returns normally. Any inputs are popped from the stack and " { $link f } " is pushed in place of each output." } ; + +HELP: log-error +{ $values { "error" "an error" } { "word" word } } +{ $description "Logs an error." } ; + +HELP: log-critical +{ $values { "critical" "an critical" } { "word" word } } +{ $description "Logs a critical error." } ; + +HELP: LOG: +{ $syntax "LOG: name level" } +{ $values { "name" "a new word name" } { "level" "a log level" } } +{ $description "Creates a word with stack effect " { $snippet "( object -- )" } " which logs its input and does nothing else." } ; + +ARTICLE: "logging.messages" "Logging messages" +"Logging messages explicitly:" +{ $subsection log-message } +{ $subsection log-error } +{ $subsection log-critical } +"A utility for defining words which just log and do nothing else:" +{ $subsection POSTPONE: LOG: } +"Annotating words to log; this uses the " { $link "tools.annotations" } " feature:" +{ $subsection add-input-logging } +{ $subsection add-output-logging } +{ $subsection add-error-logging } ; + +HELP: rotate-logs +{ $description "Rotates all logs. The highest numbered log file in each log directory is deleted, and each file is renamed so that its number increments by one. Subsequent logging calls will create a new #1 log file. This keeps log files from getting too large and makes them easier to search." } ; + +HELP: close-logs +{ $description "Closes all open log streams. Subsequent logging will re-open the streams. This should be used before moving or deleting log files." } ; + +HELP: with-logging +{ $values { "service" "a log service name" } { "quot" quotation } } +{ $description "Calls the quotation a new dynamic scope where all logging calls are sent to the log file for " { $snippet "service" } "." } ; + +ARTICLE: "logging.rotation" "Log rotation" +"Log files should be rotated periodically to prevent unbounded growth." +{ $subsection rotate-logs } +{ $subsection close-logs } +"The " { $vocab-link "logging.insomniac" } " vocabulary automates log rotation." ; + +ARTICLE: "logging.server" "Log implementation" +"The " { $vocab-link "logging.server" } " vocabulary implements a concurrent log server using " { $vocab-link "concurrency" } ". User code never interacts with the server directly, instead ot uses the words in the " { $link "logging" } " vocabulary. The server is used to synchronize access to log files and ensure that log rotation can proceed in an orderly fashion." +$nl +"The " { $link log-message } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (log-message) } +"The " { $link rotate-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (rotate-logs) } +"The " { $link close-logs } " word sends a message to the server which results in the server executing an internal word:" +{ $subsection (close-logs) } ; + +ARTICLE: "logging" "Logging framework" +"The " { $vocab-link "logging" } " vocabulary implements a comprehensive logging framework suitable for server-side production applications." +{ $subsection "logging.files" } +{ $subsection "logging.levels" } +{ $subsection "logging.messages" } +{ $subsection "logging.rotation" } +{ $subsection "logging.parser" } +{ $subsection "logging.analysis" } +{ $subsection "logging.insomniac" } +{ $subsection "logging.server" } ; + +ABOUT: "logging" + +! A workaround for circular dependency prohibition +USING: threads vocabs.loader ; +[ + yield + "logging.insomniac" require +] in-thread diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 71ea247567..d4f0bd1fbf 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -39,8 +39,8 @@ SYMBOL: log-service : rotate-logs ( -- ) { } "rotate-logs" send-to-log-server ; -: close-log-files ( -- ) - { } "close-log-files" send-to-log-server ; +: close-logs ( -- ) + { } "close-logs" send-to-log-server ; : with-logging ( service quot -- ) log-service swap with-variable ; inline @@ -56,7 +56,7 @@ SYMBOL: log-service [ dup first string? ] } && nip ; -: inputs>message ( obj -- inputs>message ) +: stack>message ( obj -- inputs>message ) dup one-string? [ first ] [ H{ { string-limit f } @@ -77,9 +77,9 @@ PRIVATE> : add-logging ( word level -- ) [ call-logging-quot ] (define-logging) ; -: log-inputs ( n word level -- ) +: log-stack ( n word level -- ) log-service get [ - >r >r [ ndup ] keep narray inputs>message + >r >r [ ndup ] keep narray stack>message r> r> log-message ] [ 3drop @@ -88,11 +88,19 @@ PRIVATE> : input# stack-effect effect-in length ; : input-logging-quot ( quot word level -- quot' ) - over input# -rot [ log-inputs ] 3curry swap compose ; + over input# -rot [ log-stack ] 3curry swap compose ; : add-input-logging ( word level -- ) [ input-logging-quot ] (define-logging) ; +: output# stack-effect effect-out length ; + +: output-logging-quot ( quot word level -- quot' ) + over output# -rot [ log-stack ] 3curry compose ; + +: add-output-logging ( word level -- ) + [ output-logging-quot ] (define-logging) ; + : (log-error) ( object word level -- ) log-service get [ >r >r [ print-error ] string-out r> r> log-message @@ -100,9 +108,9 @@ PRIVATE> 2drop rethrow ] if ; -: log-error ( object word -- ) ERROR (log-error) ; +: log-error ( error word -- ) ERROR (log-error) ; -: log-critical ( object word -- ) CRITICAL (log-error) ; +: log-critical ( error word -- ) CRITICAL (log-error) ; : error-logging-quot ( quot word -- quot' ) dup stack-effect effect-in length @@ -118,5 +126,5 @@ PRIVATE> CREATE dup reset-generic dup scan-word - [ >r >r 1array inputs>message r> r> log-message ] 2curry + [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing diff --git a/extra/logging/parser/parser-docs.factor b/extra/logging/parser/parser-docs.factor new file mode 100644 index 0000000000..ee995749be --- /dev/null +++ b/extra/logging/parser/parser-docs.factor @@ -0,0 +1,21 @@ +IN: logging.parser +USING: help.markup help.syntax assocs logging math calendar ; + +HELP: parse-log +{ $values { "lines" "a sequence of strings" } { "entries" "a sequence of log entries" } } +{ $description "Parses a sequence of log entries. Malformed entries are printed out and ignore. The result is a sequence of arrays of the shape " { $snippet "{ timestamp level word-name message }" } ", where" + { $list + { { $snippet "timestamp" } " is a " { $link timestamp } } + { { $snippet "level" } " is a log level; see " { $link "logger.levels" } } + { { $snippet "word-name" } " is a string" } + { { $snippet "message" } " is a string" } + } +} ; + +ARTICLE: "logging.parser" "Log file parser" +"The " { $vocab-link "logging.parser" } " vocabulary parses log files output by the " { $vocab-link "logging" } " vocabulary. It is used by " { $link "logging.analysis" } " and " { $link "logging.insomniac" } " to analyze logs." +$nl +"There is only one primary entry point:" +{ $subsection parse-log } ; + +ABOUT: "logging.parser" diff --git a/extra/logging/parser/tags.txt b/extra/logging/parser/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/parser/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/server/server-docs.factor b/extra/logging/server/server-docs.factor new file mode 100644 index 0000000000..08b99dd1cc --- /dev/null +++ b/extra/logging/server/server-docs.factor @@ -0,0 +1,4 @@ +IN: logging.server +USING: help.syntax ; + +ABOUT: "logging.server" diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..0300208e7e 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -50,11 +50,11 @@ SYMBOL: log-files : try-dispose ( stream -- ) [ dispose ] curry [ error. ] recover ; -: close-log-file ( service -- ) +: close-log ( service -- ) log-files get delete-at* [ try-dispose ] [ drop ] if ; -: (close-log-files) ( -- ) +: (close-logs) ( -- ) log-files get dup values [ try-dispose ] each clear-assoc ; @@ -73,13 +73,13 @@ SYMBOL: log-files [ 1- log# ] 2keep log# ?rename-file ; : rotate-log ( service -- ) - dup close-log-file + dup close-log log-path dup delete-oldest keep-logs 1 [a,b] [ advance-log ] with each ; : (rotate-logs) ( -- ) - (close-log-files) + (close-logs) log-root directory [ drop rotate-log ] assoc-each ; : log-server-loop @@ -87,9 +87,9 @@ SYMBOL: log-files receive unclip { { "log-message" [ (log-message) ] } { "rotate-logs" [ drop (rotate-logs) ] } - { "close-log-files" [ drop (close-log-files) ] } + { "close-logs" [ drop (close-logs) ] } } case - ] [ error. (close-log-files) ] recover + ] [ error. (close-logs) ] recover log-server-loop ; : log-server ( -- ) diff --git a/extra/logging/server/tags.txt b/extra/logging/server/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/server/tags.txt @@ -0,0 +1 @@ +enterprise diff --git a/extra/logging/summary.txt b/extra/logging/summary.txt index dbf29c2112..42246bbd3e 100755 --- a/extra/logging/summary.txt +++ b/extra/logging/summary.txt @@ -1 +1 @@ -AOP Logging framework with support for log rotation and machine-readable logs +Logging framework with support for log rotation and machine-readable logs diff --git a/extra/logging/tags.txt b/extra/logging/tags.txt new file mode 100644 index 0000000000..0aef4feca8 --- /dev/null +++ b/extra/logging/tags.txt @@ -0,0 +1 @@ +enterprise From fb67a7621be9e22a85f76a79d8c0ef10d206b06b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 7 Feb 2008 19:52:40 -0600 Subject: [PATCH 099/194] Cleanup --- extra/logging/server/server.factor | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/extra/logging/server/server.factor b/extra/logging/server/server.factor index cddcea8d70..601237ba81 100755 --- a/extra/logging/server/server.factor +++ b/extra/logging/server/server.factor @@ -25,9 +25,11 @@ SYMBOL: log-files : log-stream ( service -- stream ) log-files get [ open-log-stream ] cache ; +: multiline-header 20 CHAR: - ; foldable + : (write-message) ( msg word-name level multi? -- ) [ - "[" write 20 CHAR: - write "] " write + "[" write multiline-header write "] " write ] [ "[" write now (timestamp>rfc3339) "] " write ] if From 7cdcac3fc97f33d23344985c376bc043ad3b22e2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:09 -0600 Subject: [PATCH 100/194] Add another unit test --- core/compiler/test/optimizer.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor index 7ee4ebfd1c..987aace00a 100755 --- a/core/compiler/test/optimizer.factor +++ b/core/compiler/test/optimizer.factor @@ -300,3 +300,4 @@ TUPLE: silly-tuple a b ; [ f ] [ \ sequence \ hashcode* should-inline? ] unit-test [ t ] [ \ array \ nth-unsafe should-inline? ] unit-test [ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test From f67ab9a6897ea24982c8049e821740864b6e1f77 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:23 -0600 Subject: [PATCH 101/194] Multi-methods work in progress --- .../multi-methods/multi-methods-tests.factor | 12 ++ extra/multi-methods/multi-methods.factor | 117 ++++++++++++------ 2 files changed, 88 insertions(+), 41 deletions(-) diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor index a0769dffda..1c68cbe540 100755 --- a/extra/multi-methods/multi-methods-tests.factor +++ b/extra/multi-methods/multi-methods-tests.factor @@ -84,3 +84,15 @@ METHOD: hook-test { hashtable number } assoc-size ; [ fixnum ] [ 3 hook-test ] unit-test 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test + +MIXIN: busted + +TUPLE: busted-1 ; +TUPLE: busted-2 ; INSTANCE: busted-2 busted +TUPLE: busted-3 ; + +GENERIC: busted-sort + +METHOD: busted-sort { busted-1 busted-2 } ; +METHOD: busted-sort { busted-2 busted-3 } ; +METHOD: busted-sort { busted busted } ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 827d64b95f..9a74cc65e8 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -3,12 +3,12 @@ USING: kernel math sequences vectors classes combinators arrays words assocs parser namespaces definitions prettyprint prettyprint.backend quotations arrays.lib -debugger io compiler.units ; +debugger io compiler.units kernel.private effects ; IN: multi-methods -TUPLE: method loc def ; +GENERIC: generic-prologue ( combination -- quot ) -: { set-method-def } \ method construct ; +GENERIC: method-prologue ( combination -- quot ) : maximal-element ( seq quot -- n elt ) dupd [ @@ -25,6 +25,7 @@ TUPLE: method loc def ; [ { { [ 2dup eq? ] [ 0 ] } + { [ 2dup [ class< ] 2keep swap class< and ] [ 0 ] } { [ 2dup class< ] [ -1 ] } { [ 2dup swap class< ] [ 1 ] } { [ t ] [ 0 ] } @@ -54,8 +55,37 @@ TUPLE: method loc def ; : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: method-defs ( methods -- methods' ) - [ method-def ] assoc-map ; +: make-method-def ( quot classes generic -- quot ) + [ + swap [ declare ] curry % + "multi-combination" word-prop method-prologue % + % + ] [ ] make ; + +TUPLE: method word def classes generic loc ; + +PREDICATE: word method-body "multi-method" word-prop >boolean ; + +M: method-body stack-effect + "multi-method" word-prop method-generic stack-effect ; + +: method-word-name ( classes generic -- string ) + [ + word-name % + "-(" % [ "," % ] [ word-name % ] interleave ")" % + ] "" make ; + +: ( quot classes generic -- word ) + #! We xref here because the "multi-method" word-prop isn't + #! set yet so crossref? yields f. + [ make-method-def ] 2keep + method-word-name f + dup rot define + dup xref ; + +: ( quot classes generic -- method ) + [ ] 3keep f \ method construct-boa + dup method-word over "multi-method" set-word-prop ; TUPLE: no-method arguments generic ; @@ -68,8 +98,11 @@ TUPLE: no-method arguments generic ; ] if ; : multi-dispatch-quot ( methods generic -- quot ) - >r - [ [ >r multi-predicate r> ] assoc-map ] keep argument-count + >r [ + [ + >r multi-predicate r> method-word 1quotation + ] assoc-map + ] keep argument-count r> [ no-method ] 2curry swap reverse alist>quot ; @@ -98,36 +131,36 @@ M: no-method error. methods congruify-methods sorted-methods keys [ niceify-method ] map stack. ; -GENERIC: perform-combination ( word combination -- quot ) - TUPLE: standard-combination ; -: standard-combination ( methods generic -- quot ) - >r congruify-methods sorted-methods r> multi-dispatch-quot ; +M: standard-combination method-prologue drop [ ] ; -M: standard-combination perform-combination - drop [ methods method-defs ] keep standard-combination ; +M: standard-combination generic-prologue drop [ ] ; + +: make-generic ( generic -- quot ) + dup "multi-combination" word-prop generic-prologue swap + [ methods congruify-methods sorted-methods ] keep + multi-dispatch-quot append ; TUPLE: hook-combination var ; -M: hook-combination perform-combination - hook-combination-var [ get ] curry swap methods - [ method-defs [ [ drop ] swap append ] assoc-map ] keep - standard-combination append ; +M: hook-combination method-prologue + drop [ drop ] ; -: make-generic ( word -- ) - dup dup "multi-combination" word-prop perform-combination - define ; +M: hook-combination generic-prologue + hook-combination-var [ get ] curry ; -: init-methods ( word -- ) - dup "multi-methods" word-prop - H{ } assoc-like - "multi-methods" set-word-prop ; +: update-generic ( word -- ) + dup make-generic define ; : define-generic ( word combination -- ) - dupd "multi-combination" set-word-prop - dup init-methods - make-generic ; + over "multi-combination" word-prop over = [ + 2drop + ] [ + dupd "multi-combination" set-word-prop + dup H{ } clone "multi-methods" set-word-prop + update-generic + ] if ; : define-standard-generic ( word -- ) T{ standard-combination } define-generic ; @@ -146,29 +179,31 @@ M: hook-combination perform-combination : with-methods ( word quot -- ) over >r >r "multi-methods" word-prop - r> call r> make-generic ; inline + r> call r> update-generic ; inline -: add-method ( method classes word -- ) +: define-method ( quot classes generic -- ) + >r [ bootstrap-word ] map r> + [ ] 2keep [ set-at ] with-methods ; -: forget-method ( classes word -- ) +: forget-method ( classes generic -- ) [ delete-at ] with-methods ; -: parse-method ( -- method classes word method-spec ) - parse-definition 2 cut - over >r - >r first2 swap r> -rot - r> first2 swap add* >array ; +: method>spec ( method -- spec ) + dup method-classes swap method-generic add* ; + +: parse-method ( -- quot classes generic ) + parse-definition dup 2 tail over second rot first ; : METHOD: location - >r parse-method >r add-method r> r> + >r parse-method [ define-method ] 2keep add* r> remember-definition ; parsing ! For compatibility : M: - scan-word 1array scan-word parse-definition - -rot add-method ; parsing + scan-word 1array scan-word parse-definition + -rot define-method ; parsing ! Definition protocol. We qualify core generics here USE: qualified @@ -202,7 +237,7 @@ PREDICATE: array method-spec unclip generic? >r [ class? ] all? r> and ; syntax:M: method-spec where - dup unclip method method-loc [ ] [ second where ] ?if ; + dup unclip method [ method-loc ] [ second where ] ?if ; syntax:M: method-spec set-where unclip method set-method-loc ; @@ -211,11 +246,11 @@ syntax:M: method-spec definer drop \ METHOD: \ ; ; syntax:M: method-spec definition - unclip method method-def ; + unclip method dup [ method-def ] when ; syntax:M: method-spec synopsis* dup definer. unclip pprint* pprint* ; syntax:M: method-spec forget* - unclip [ delete-at ] with-methods ; + unclip forget-method ; From 492e569b627ed7826b6fd9b4a946fa7c15e379d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:08:52 -0600 Subject: [PATCH 102/194] 'about' now requires first --- extra/help/help.factor | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/extra/help/help.factor b/extra/help/help.factor index aefbf2aba2..77b9f699aa 100755 --- a/extra/help/help.factor +++ b/extra/help/help.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays io kernel namespaces parser prettyprint sequences -words assocs definitions generic quotations effects -slots continuations tuples debugger combinators -vocabs help.stylesheet help.topics help.crossref help.markup -sorting classes ; +words assocs definitions generic quotations effects slots +continuations tuples debugger combinators vocabs help.stylesheet +help.topics help.crossref help.markup sorting classes +vocabs.loader ; IN: help GENERIC: word-help* ( word -- content ) @@ -96,6 +96,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; article-content print-content nl ; : about ( vocab -- ) + dup require dup vocab [ ] [ "No such vocabulary: " swap append throw ] ?if From 52b5c5a0682644327c22d7e10f8fe16d006e67a6 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:48:51 -0600 Subject: [PATCH 103/194] Reorganize compiler tests --- core/alien/c-types/c-types.factor | 2 + core/alien/compiler/compiler-tests.factor | 356 ++++++++++++++++++ core/compiler/compiler-tests.factor | 28 +- .../curry-tests.factor} | 0 core/compiler/test/curry/curry.factor | 0 .../float-tests.factor} | 0 core/compiler/test/float/float.factor | 0 core/compiler/test/generic.factor | 30 -- core/compiler/test/ifte.factor | 131 ------- .../intrinsics-tests.factor} | 0 .../test/intrinsics/intrinsics.factor | 0 .../redefine-tests.factor} | 0 core/compiler/test/redefine/redefine.factor | 0 core/compiler/test/simple.factor | 71 ---- core/compiler/test/simple/simple-tests.factor | 227 +++++++++++ core/compiler/test/simple/simple.factor | 0 .../stack-trace-tests.factor} | 0 .../test/stack-trace/stack-trace.factor | 0 .../templates-early-tests.factor} | 0 .../templates-early/templates-early.factor | 0 .../templates-tests.factor} | 0 core/compiler/test/templates/templates.factor | 0 .../tuples-tests.factor} | 0 core/compiler/test/tuples/tuples.factor | 0 core/inference/class/class-tests.factor | 10 + core/inference/known-words/known-words.factor | 17 + core/inference/transforms/transforms.factor | 4 +- core/math/bitfields/bitfields-tests.factor | 11 +- core/optimizer/optimizer-tests.factor | 303 +++++++++++++++ core/parser/parser.factor | 2 +- 30 files changed, 936 insertions(+), 256 deletions(-) create mode 100755 core/alien/compiler/compiler-tests.factor mode change 100644 => 100755 core/compiler/compiler-tests.factor rename core/compiler/test/{curry.factor => curry/curry-tests.factor} (100%) create mode 100644 core/compiler/test/curry/curry.factor rename core/compiler/test/{float.factor => float/float-tests.factor} (100%) create mode 100644 core/compiler/test/float/float.factor delete mode 100644 core/compiler/test/generic.factor delete mode 100755 core/compiler/test/ifte.factor rename core/compiler/test/{intrinsics.factor => intrinsics/intrinsics-tests.factor} (100%) create mode 100644 core/compiler/test/intrinsics/intrinsics.factor rename core/compiler/test/{redefine.factor => redefine/redefine-tests.factor} (100%) create mode 100644 core/compiler/test/redefine/redefine.factor delete mode 100755 core/compiler/test/simple.factor create mode 100755 core/compiler/test/simple/simple-tests.factor create mode 100644 core/compiler/test/simple/simple.factor rename core/compiler/test/{stack-trace.factor => stack-trace/stack-trace-tests.factor} (100%) create mode 100644 core/compiler/test/stack-trace/stack-trace.factor rename core/compiler/test/{templates-early.factor => templates-early/templates-early-tests.factor} (100%) create mode 100644 core/compiler/test/templates-early/templates-early.factor rename core/compiler/test/{templates.factor => templates/templates-tests.factor} (100%) create mode 100644 core/compiler/test/templates/templates.factor rename core/compiler/test/{tuples.factor => tuples/tuples-tests.factor} (100%) create mode 100644 core/compiler/test/tuples/tuples.factor mode change 100644 => 100755 core/math/bitfields/bitfields-tests.factor create mode 100755 core/optimizer/optimizer-tests.factor diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 6c46cb946a..ed0721a7ff 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,8 @@ math.parser cpu.architecture alien alien.accessors quotations system compiler.units ; IN: alien.c-types +: little-endian? ( -- ? ) 1 *char 1 = ; foldable + TUPLE: c-type boxer prep unboxer getter setter diff --git a/core/alien/compiler/compiler-tests.factor b/core/alien/compiler/compiler-tests.factor new file mode 100755 index 0000000000..c0c3733afa --- /dev/null +++ b/core/alien/compiler/compiler-tests.factor @@ -0,0 +1,356 @@ +IN: temporary +USING: alien alien.c-types alien.syntax compiler kernel +namespaces namespaces tools.test sequences inference words +arrays parser quotations continuations inference.backend effects +namespaces.private io io.streams.string memory system threads +tools.test ; + +FUNCTION: void ffi_test_0 ; +[ ] [ ffi_test_0 ] unit-test + +FUNCTION: int ffi_test_1 ; +[ 3 ] [ ffi_test_1 ] unit-test + +FUNCTION: int ffi_test_2 int x int y ; +[ 5 ] [ 2 3 ffi_test_2 ] unit-test +[ "hi" 3 ffi_test_2 ] must-fail + +FUNCTION: int ffi_test_3 int x int y int z int t ; +[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test + +FUNCTION: float ffi_test_4 ; +[ 1.5 ] [ ffi_test_4 ] unit-test + +FUNCTION: double ffi_test_5 ; +[ 1.5 ] [ ffi_test_5 ] unit-test + +FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; +[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test +[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail +[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail + +C-STRUCT: foo + { "int" "x" } + { "int" "y" } +; + +: make-foo ( x y -- foo ) + "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; + +FUNCTION: int ffi_test_11 int a foo b int c ; + +[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test + +FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; + +[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test + +FUNCTION: foo ffi_test_14 int x int y ; + +[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test + +FUNCTION: char* ffi_test_15 char* x char* y ; + +[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test +[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test +[ 1 2 ffi_test_15 ] must-fail + +C-STRUCT: bar + { "long" "x" } + { "long" "y" } + { "long" "z" } +; + +FUNCTION: bar ffi_test_16 long x long y long z ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z +] unit-test + +C-STRUCT: tiny + { "int" "x" } +; + +FUNCTION: tiny ffi_test_17 int x ; + +[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test + +[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with + +: indirect-test-1 + "int" { } "cdecl" alien-indirect ; + +{ 1 1 } [ indirect-test-1 ] must-infer-as + +[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test + +[ -1 indirect-test-1 ] must-fail + +: indirect-test-2 + "int" { "int" "int" } "cdecl" alien-indirect data-gc ; + +{ 3 1 } [ indirect-test-2 ] must-infer-as + +[ 5 ] +[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] +unit-test + +: indirect-test-3 + "int" { "int" "int" "int" "int" } "stdcall" alien-indirect + data-gc ; + +<< "f-stdcall" f "stdcall" add-library >> + +[ f ] [ "f-stdcall" load-library ] unit-test +[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test + +: ffi_test_18 ( w x y z -- int ) + "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } + alien-invoke data-gc ; + +[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test + +: ffi_test_19 ( x y z -- bar ) + "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } + alien-invoke data-gc ; + +[ 11 6 -7 ] [ + 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z +] unit-test + +FUNCTION: double ffi_test_6 float x float y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test +[ "a" "b" ffi_test_6 ] must-fail + +FUNCTION: double ffi_test_7 double x double y ; +[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test + +FUNCTION: double ffi_test_8 double x float y double z float t int w ; +[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test + +FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; +[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test + +FUNCTION: void ffi_test_20 double x1, double x2, double x3, + double y1, double y2, double y3, + double z1, double z2, double z3 ; + +[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test + +! Make sure XT doesn't get clobbered in stack frame + +: ffi_test_31 + "void" + f "ffi_test_31" + { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } + alien-invoke code-gc 3 ; + +[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test + +FUNCTION: longlong ffi_test_21 long x long y ; + +[ 121932631112635269 ] +[ 123456789 987654321 ffi_test_21 ] unit-test + +FUNCTION: long ffi_test_22 long x longlong y longlong z ; + +[ 987655432 ] +[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test + +[ 1111 f 123456789 ffi_test_22 ] must-fail + +C-STRUCT: rect + { "float" "x" } + { "float" "y" } + { "float" "w" } + { "float" "h" } +; + +: + "rect" + [ set-rect-h ] keep + [ set-rect-w ] keep + [ set-rect-y ] keep + [ set-rect-x ] keep ; + +FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; + +[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test + +[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail + +FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; + +[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test + +! Test odd-size structs +C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; + +FUNCTION: test-struct-1 ffi_test_24 ; + +[ B{ 1 } ] [ ffi_test_24 ] unit-test + +C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; + +FUNCTION: test-struct-2 ffi_test_25 ; + +[ B{ 1 2 } ] [ ffi_test_25 ] unit-test + +C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; + +FUNCTION: test-struct-3 ffi_test_26 ; + +[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test + +C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; + +FUNCTION: test-struct-4 ffi_test_27 ; + +[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test + +C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; + +FUNCTION: test-struct-5 ffi_test_28 ; + +[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test + +C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; + +FUNCTION: test-struct-6 ffi_test_29 ; + +[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test + +C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; + +FUNCTION: test-struct-7 ffi_test_30 ; + +[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test + +C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; + +FUNCTION: double ffi_test_32 test-struct-8 x int y ; + +[ 9.0 ] [ + "test-struct-8" + 1.0 over set-test-struct-8-x + 2.0 over set-test-struct-8-y + 3 ffi_test_32 +] unit-test + +C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; + +FUNCTION: double ffi_test_33 test-struct-9 x int y ; + +[ 9.0 ] [ + "test-struct-9" + 1.0 over set-test-struct-9-x + 2.0 over set-test-struct-9-y + 3 ffi_test_33 +] unit-test + +C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_34 test-struct-10 x int y ; + +[ 9.0 ] [ + "test-struct-10" + 1.0 over set-test-struct-10-x + 2 over set-test-struct-10-y + 3 ffi_test_34 +] unit-test + +C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; + +FUNCTION: double ffi_test_35 test-struct-11 x int y ; + +[ 9.0 ] [ + "test-struct-11" + 1 over set-test-struct-11-x + 2 over set-test-struct-11-y + 3 ffi_test_35 +] unit-test + +C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; + +: make-struct-12 + "test-struct-12" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + +! Test callbacks + +: callback-1 "void" { } "cdecl" [ ] alien-callback ; + +[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test + +[ t ] [ callback-1 alien? ] unit-test + +: callback_test_1 "void" { } "cdecl" alien-indirect ; + +[ ] [ callback-1 callback_test_1 ] unit-test + +: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; + +[ ] [ callback-2 callback_test_1 ] unit-test + +: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; + +[ t ] [ + namestack* + 3 "x" set callback-3 callback_test_1 + namestack* eq? +] unit-test + +[ 5 ] [ + [ + 3 "x" set callback-3 callback_test_1 "x" get + ] with-scope +] unit-test + +: callback-4 + "void" { } "cdecl" [ "Hello world" write ] alien-callback + data-gc ; + +[ "Hello world" ] [ + [ callback-4 callback_test_1 ] string-out +] unit-test + +: callback-5 + "void" { } "cdecl" [ data-gc ] alien-callback ; + +[ "testing" ] [ + "testing" callback-5 callback_test_1 +] unit-test + +: callback-5a + "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; + +! Hack; if we're on ARM, we probably don't have much RAM, so +! skip this test. +cpu "arm" = [ + [ "testing" ] [ + "testing" callback-5a callback_test_1 + ] unit-test +] unless + +: callback-6 + "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; + +[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test + +: callback-7 + "void" { } "cdecl" [ 1000 sleep ] alien-callback ; + +[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test + +[ f ] [ namespace global eq? ] unit-test + +: callback-8 + "void" { } "cdecl" [ + [ continue ] callcc0 + ] alien-callback ; + +[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/compiler/compiler-tests.factor b/core/compiler/compiler-tests.factor old mode 100644 new mode 100755 index bd9b26ce6d..7e4e79437d --- a/core/compiler/compiler-tests.factor +++ b/core/compiler/compiler-tests.factor @@ -1,21 +1,7 @@ -USING: io.files tools.test sequences namespaces kernel -compiler.units ; - -{ - "templates-early" - "simple" - "intrinsics" - "float" - "generic" - "ifte" - "templates" - "optimizer" - "redefine" - "stack-trace" - "alien" - "curry" - "tuples" -} -[ "resource:core/compiler/test/" swap ".factor" 3append ] map -[ run-test ] map -[ failures get push-all ] each +IN: temporary +USING: tools.browser tools.test kernel sequences vocabs ; + +"compiler.test" child-vocabs empty? [ + "compiler.test" load-children + "compiler.test" test +] when diff --git a/core/compiler/test/curry.factor b/core/compiler/test/curry/curry-tests.factor similarity index 100% rename from core/compiler/test/curry.factor rename to core/compiler/test/curry/curry-tests.factor diff --git a/core/compiler/test/curry/curry.factor b/core/compiler/test/curry/curry.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/float.factor b/core/compiler/test/float/float-tests.factor similarity index 100% rename from core/compiler/test/float.factor rename to core/compiler/test/float/float-tests.factor diff --git a/core/compiler/test/float/float.factor b/core/compiler/test/float/float.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/generic.factor b/core/compiler/test/generic.factor deleted file mode 100644 index c54dbd753d..0000000000 --- a/core/compiler/test/generic.factor +++ /dev/null @@ -1,30 +0,0 @@ -IN: temporary -USING: compiler generic tools.test math kernel words arrays -sequences quotations ; - -GENERIC: single-combination-test - -M: object single-combination-test drop ; -M: f single-combination-test nip ; -M: array single-combination-test drop ; -M: integer single-combination-test drop ; - -[ 2 3 ] [ 2 3 t single-combination-test ] unit-test -[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test -[ 2 f ] [ 2 3 f single-combination-test ] unit-test - -DEFER: single-combination-test-2 - -: single-combination-test-4 - dup [ single-combination-test-2 ] when ; - -: single-combination-test-3 - drop 3 ; - -GENERIC: single-combination-test-2 -M: object single-combination-test-2 single-combination-test-3 ; -M: f single-combination-test-2 single-combination-test-4 ; - -[ 3 ] [ t single-combination-test-2 ] unit-test -[ 3 ] [ 3 single-combination-test-2 ] unit-test -[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/ifte.factor b/core/compiler/test/ifte.factor deleted file mode 100755 index 802cad5032..0000000000 --- a/core/compiler/test/ifte.factor +++ /dev/null @@ -1,131 +0,0 @@ -IN: temporary -USING: alien strings compiler tools.test math kernel words -math.private combinators ; - -: dummy-if-1 t [ ] [ ] if ; - -[ ] [ dummy-if-1 ] unit-test - -: dummy-if-2 f [ ] [ ] if ; - -[ ] [ dummy-if-2 ] unit-test - -: dummy-if-3 t [ 1 ] [ 2 ] if ; - -[ 1 ] [ dummy-if-3 ] unit-test - -: dummy-if-4 f [ 1 ] [ 2 ] if ; - -[ 2 ] [ dummy-if-4 ] unit-test - -: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; - -[ 1 ] [ dummy-if-5 ] unit-test - -: dummy-if-6 - dup 1 fixnum<= [ - drop 1 - ] [ - 1 fixnum- dup 1 fixnum- fixnum+ - ] if ; - -[ 17 ] [ 10 dummy-if-6 ] unit-test - -: dead-code-rec - t [ - 3.2 - ] [ - dead-code-rec - ] if ; - -[ 3.2 ] [ dead-code-rec ] unit-test - -: one-rec [ f one-rec ] [ "hi" ] if ; - -[ "hi" ] [ t one-rec ] unit-test - -: after-if-test - t [ ] [ ] if 5 ; - -[ 5 ] [ after-if-test ] unit-test - -DEFER: countdown-b - -: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; -: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; - -[ ] [ 10 countdown-b ] unit-test - -: dummy-when-1 t [ ] when ; - -[ ] [ dummy-when-1 ] unit-test - -: dummy-when-2 f [ ] when ; - -[ ] [ dummy-when-2 ] unit-test - -: dummy-when-3 dup [ dup fixnum* ] when ; - -[ 16 ] [ 4 dummy-when-3 ] unit-test -[ f ] [ f dummy-when-3 ] unit-test - -: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; - -[ 64 f ] [ f 4 dummy-when-4 ] unit-test -[ f t ] [ t f dummy-when-4 ] unit-test - -: dummy-when-5 f [ dup fixnum* ] when ; - -[ f ] [ f dummy-when-5 ] unit-test - -: dummy-unless-1 t [ ] unless ; - -[ ] [ dummy-unless-1 ] unit-test - -: dummy-unless-2 f [ ] unless ; - -[ ] [ dummy-unless-2 ] unit-test - -: dummy-unless-3 dup [ drop 3 ] unless ; - -[ 3 ] [ f dummy-unless-3 ] unit-test -[ 4 ] [ 4 dummy-unless-3 ] unit-test - -! Test cond expansion -[ "even" ] [ - [ - 2 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "odd" ] [ - [ - 3 { - { [ dup 2 mod 0 = ] [ drop "even" ] } - { [ dup 2 mod 1 = ] [ drop "odd" ] } - } cond - ] compile-call -] unit-test - -[ "neither" ] [ - [ - 3 { - { [ dup string? ] [ drop "string" ] } - { [ dup float? ] [ drop "float" ] } - { [ dup alien? ] [ drop "alien" ] } - { [ t ] [ drop "neither" ] } - } cond - ] compile-call -] unit-test - -[ 3 ] [ - [ - 3 { - { [ dup fixnum? ] [ ] } - { [ t ] [ drop t ] } - } cond - ] compile-call -] unit-test diff --git a/core/compiler/test/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics-tests.factor similarity index 100% rename from core/compiler/test/intrinsics.factor rename to core/compiler/test/intrinsics/intrinsics-tests.factor diff --git a/core/compiler/test/intrinsics/intrinsics.factor b/core/compiler/test/intrinsics/intrinsics.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/redefine.factor b/core/compiler/test/redefine/redefine-tests.factor similarity index 100% rename from core/compiler/test/redefine.factor rename to core/compiler/test/redefine/redefine-tests.factor diff --git a/core/compiler/test/redefine/redefine.factor b/core/compiler/test/redefine/redefine.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/simple.factor b/core/compiler/test/simple.factor deleted file mode 100755 index 6f5cb33c1a..0000000000 --- a/core/compiler/test/simple.factor +++ /dev/null @@ -1,71 +0,0 @@ -USING: compiler tools.test kernel kernel.private -combinators.private ; -IN: temporary - -! Test empty word -[ ] [ [ ] compile-call ] unit-test - -! Test literals -[ 1 ] [ [ 1 ] compile-call ] unit-test -[ 31 ] [ [ 31 ] compile-call ] unit-test -[ 255 ] [ [ 255 ] compile-call ] unit-test -[ -1 ] [ [ -1 ] compile-call ] unit-test -[ 65536 ] [ [ 65536 ] compile-call ] unit-test -[ -65536 ] [ [ -65536 ] compile-call ] unit-test -[ "hey" ] [ [ "hey" ] compile-call ] unit-test - -! Calls -: no-op ; - -[ ] [ [ no-op ] compile-call ] unit-test -[ 3 ] [ [ no-op 3 ] compile-call ] unit-test -[ 3 ] [ [ 3 no-op ] compile-call ] unit-test - -: bar 4 ; - -[ 4 ] [ [ bar no-op ] compile-call ] unit-test -[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test -[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test - -[ ] [ no-op ] unit-test - -! Conditionals - -[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test -[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test -[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test - -[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test -[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test - -[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test -[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test - -[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test -[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test -[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test - -! Labels - -: recursive ( ? -- ) [ f recursive ] when ; inline - -[ ] [ t [ recursive ] compile-call ] unit-test - -[ ] [ t recursive ] unit-test - -! Make sure error reporting works - -[ [ dup ] compile-call ] must-fail -[ [ drop ] compile-call ] must-fail - -! Regression - -[ ] [ [ callstack ] compile-call drop ] unit-test - -! Regression - -: empty ; - -[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor new file mode 100755 index 0000000000..3f4f6451a3 --- /dev/null +++ b/core/compiler/test/simple/simple-tests.factor @@ -0,0 +1,227 @@ +USING: compiler tools.test kernel kernel.private +combinators.private math.private math combinators strings +alien arrays ; +IN: temporary + +! Test empty word +[ ] [ [ ] compile-call ] unit-test + +! Test literals +[ 1 ] [ [ 1 ] compile-call ] unit-test +[ 31 ] [ [ 31 ] compile-call ] unit-test +[ 255 ] [ [ 255 ] compile-call ] unit-test +[ -1 ] [ [ -1 ] compile-call ] unit-test +[ 65536 ] [ [ 65536 ] compile-call ] unit-test +[ -65536 ] [ [ -65536 ] compile-call ] unit-test +[ "hey" ] [ [ "hey" ] compile-call ] unit-test + +! Calls +: no-op ; + +[ ] [ [ no-op ] compile-call ] unit-test +[ 3 ] [ [ no-op 3 ] compile-call ] unit-test +[ 3 ] [ [ 3 no-op ] compile-call ] unit-test + +: bar 4 ; + +[ 4 ] [ [ bar no-op ] compile-call ] unit-test +[ 4 3 ] [ [ no-op bar 3 ] compile-call ] unit-test +[ 3 4 ] [ [ 3 no-op bar ] compile-call ] unit-test + +[ ] [ no-op ] unit-test + +! Conditionals + +[ 1 ] [ t [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 2 ] [ f [ [ 1 ] [ 2 ] if ] compile-call ] unit-test +[ 1 3 ] [ t [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test +[ 2 3 ] [ f [ [ 1 ] [ 2 ] if 3 ] compile-call ] unit-test + +[ "hi" ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test +[ "bye" ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch ] compile-call ] unit-test + +[ "hi" 3 ] [ 0 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test +[ "bye" 3 ] [ 1 [ { [ "hi" ] [ "bye" ] } dispatch 3 ] compile-call ] unit-test + +[ 4 1 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 3 1 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch ] compile-call ] unit-test +[ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test + +! Labels + +: recursive ( ? -- ) [ f recursive ] when ; inline + +[ ] [ t [ recursive ] compile-call ] unit-test + +[ ] [ t recursive ] unit-test + +! Make sure error reporting works + +[ [ dup ] compile-call ] must-fail +[ [ drop ] compile-call ] must-fail + +! Regression + +[ ] [ [ callstack ] compile-call drop ] unit-test + +! Regression + +: empty ; + +[ "b" ] [ 1 [ empty { [ "a" ] [ "b" ] } dispatch ] compile-call ] unit-test + +: dummy-if-1 t [ ] [ ] if ; + +[ ] [ dummy-if-1 ] unit-test + +: dummy-if-2 f [ ] [ ] if ; + +[ ] [ dummy-if-2 ] unit-test + +: dummy-if-3 t [ 1 ] [ 2 ] if ; + +[ 1 ] [ dummy-if-3 ] unit-test + +: dummy-if-4 f [ 1 ] [ 2 ] if ; + +[ 2 ] [ dummy-if-4 ] unit-test + +: dummy-if-5 0 dup 1 fixnum<= [ drop 1 ] [ ] if ; + +[ 1 ] [ dummy-if-5 ] unit-test + +: dummy-if-6 + dup 1 fixnum<= [ + drop 1 + ] [ + 1 fixnum- dup 1 fixnum- fixnum+ + ] if ; + +[ 17 ] [ 10 dummy-if-6 ] unit-test + +: dead-code-rec + t [ + 3.2 + ] [ + dead-code-rec + ] if ; + +[ 3.2 ] [ dead-code-rec ] unit-test + +: one-rec [ f one-rec ] [ "hi" ] if ; + +[ "hi" ] [ t one-rec ] unit-test + +: after-if-test + t [ ] [ ] if 5 ; + +[ 5 ] [ after-if-test ] unit-test + +DEFER: countdown-b + +: countdown-a ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-b ] if ; +: countdown-b ( n -- ) dup 0 eq? [ drop ] [ 1 fixnum- countdown-a ] if ; + +[ ] [ 10 countdown-b ] unit-test + +: dummy-when-1 t [ ] when ; + +[ ] [ dummy-when-1 ] unit-test + +: dummy-when-2 f [ ] when ; + +[ ] [ dummy-when-2 ] unit-test + +: dummy-when-3 dup [ dup fixnum* ] when ; + +[ 16 ] [ 4 dummy-when-3 ] unit-test +[ f ] [ f dummy-when-3 ] unit-test + +: dummy-when-4 dup [ dup dup fixnum* fixnum* ] when swap ; + +[ 64 f ] [ f 4 dummy-when-4 ] unit-test +[ f t ] [ t f dummy-when-4 ] unit-test + +: dummy-when-5 f [ dup fixnum* ] when ; + +[ f ] [ f dummy-when-5 ] unit-test + +: dummy-unless-1 t [ ] unless ; + +[ ] [ dummy-unless-1 ] unit-test + +: dummy-unless-2 f [ ] unless ; + +[ ] [ dummy-unless-2 ] unit-test + +: dummy-unless-3 dup [ drop 3 ] unless ; + +[ 3 ] [ f dummy-unless-3 ] unit-test +[ 4 ] [ 4 dummy-unless-3 ] unit-test + +! Test cond expansion +[ "even" ] [ + [ + 2 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "odd" ] [ + [ + 3 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-call +] unit-test + +[ "neither" ] [ + [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + { [ t ] [ drop "neither" ] } + } cond + ] compile-call +] unit-test + +[ 3 ] [ + [ + 3 { + { [ dup fixnum? ] [ ] } + { [ t ] [ drop t ] } + } cond + ] compile-call +] unit-test + +GENERIC: single-combination-test + +M: object single-combination-test drop ; +M: f single-combination-test nip ; +M: array single-combination-test drop ; +M: integer single-combination-test drop ; + +[ 2 3 ] [ 2 3 t single-combination-test ] unit-test +[ 2 3 ] [ 2 3 4 single-combination-test ] unit-test +[ 2 f ] [ 2 3 f single-combination-test ] unit-test + +DEFER: single-combination-test-2 + +: single-combination-test-4 + dup [ single-combination-test-2 ] when ; + +: single-combination-test-3 + drop 3 ; + +GENERIC: single-combination-test-2 +M: object single-combination-test-2 single-combination-test-3 ; +M: f single-combination-test-2 single-combination-test-4 ; + +[ 3 ] [ t single-combination-test-2 ] unit-test +[ 3 ] [ 3 single-combination-test-2 ] unit-test +[ f ] [ f single-combination-test-2 ] unit-test diff --git a/core/compiler/test/simple/simple.factor b/core/compiler/test/simple/simple.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace-tests.factor similarity index 100% rename from core/compiler/test/stack-trace.factor rename to core/compiler/test/stack-trace/stack-trace-tests.factor diff --git a/core/compiler/test/stack-trace/stack-trace.factor b/core/compiler/test/stack-trace/stack-trace.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates-early.factor b/core/compiler/test/templates-early/templates-early-tests.factor similarity index 100% rename from core/compiler/test/templates-early.factor rename to core/compiler/test/templates-early/templates-early-tests.factor diff --git a/core/compiler/test/templates-early/templates-early.factor b/core/compiler/test/templates-early/templates-early.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/templates.factor b/core/compiler/test/templates/templates-tests.factor similarity index 100% rename from core/compiler/test/templates.factor rename to core/compiler/test/templates/templates-tests.factor diff --git a/core/compiler/test/templates/templates.factor b/core/compiler/test/templates/templates.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/compiler/test/tuples.factor b/core/compiler/test/tuples/tuples-tests.factor similarity index 100% rename from core/compiler/test/tuples.factor rename to core/compiler/test/tuples/tuples-tests.factor diff --git a/core/compiler/test/tuples/tuples.factor b/core/compiler/test/tuples/tuples.factor new file mode 100644 index 0000000000..e69de29bb2 diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 3bd90a3aca..17cc3d3cf8 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -263,3 +263,13 @@ cell-bits 32 = [ \ fixnum-shift inlined? ] unit-test ] when + +[ t ] [ + [ B{ 1 0 } *short 0 number= ] + \ number= inlined? +] unit-test + +[ t ] [ + [ B{ 1 0 } *short 0 = ] + \ number= inlined? +] unit-test diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 6be3899acd..69e331a9bf 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -414,64 +414,81 @@ t over set-effect-terminated? \ make-flushable \ alien-signed-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-cell make-flushable \ set-alien-signed-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-cell { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-cell make-flushable \ set-alien-unsigned-cell { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-8 make-flushable \ set-alien-signed-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-8 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-8 make-flushable \ set-alien-unsigned-8 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-signed-4 make-flushable \ set-alien-signed-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-4 { c-ptr integer } { integer } "inferred-effect" set-word-prop +\ alien-unsigned-4 make-flushable \ set-alien-unsigned-4 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-2 make-flushable \ set-alien-signed-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-2 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-2 make-flushable \ set-alien-unsigned-2 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-signed-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-signed-1 make-flushable \ set-alien-signed-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-unsigned-1 { c-ptr integer } { fixnum } "inferred-effect" set-word-prop +\ alien-unsigned-1 make-flushable \ set-alien-unsigned-1 { integer c-ptr integer } { } "inferred-effect" set-word-prop \ alien-float { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-float make-flushable \ set-alien-float { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-double { c-ptr integer } { float } "inferred-effect" set-word-prop +\ alien-double make-flushable \ set-alien-double { float c-ptr integer } { } "inferred-effect" set-word-prop \ alien-cell { c-ptr integer } { simple-c-ptr } "inferred-effect" set-word-prop +\ alien-cell make-flushable \ set-alien-cell { c-ptr c-ptr integer } { } "inferred-effect" set-word-prop \ alien>char-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>char-string make-flushable \ string>char-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>char-alien make-flushable \ alien>u16-string { c-ptr } { string } "inferred-effect" set-word-prop +\ alien>u16-string make-flushable \ string>u16-alien { string } { byte-array } "inferred-effect" set-word-prop +\ string>u16-alien make-flushable \ alien-address { alien } { integer } "inferred-effect" set-word-prop \ alien-address make-flushable diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index ad2bacc789..b1b56ca1a1 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -54,7 +54,9 @@ M: pair (bitfield-quot) ( spec -- quot ) \ bitfield [ bitfield-quot ] 1 define-transform -\ flags [ flags [ ] curry ] 1 define-transform +\ flags [ + [ 0 , [ , \ bitor , ] each ] [ ] make +] 1 define-transform ! Tuple operations : [get-slots] ( slots -- quot ) diff --git a/core/math/bitfields/bitfields-tests.factor b/core/math/bitfields/bitfields-tests.factor old mode 100644 new mode 100755 index c382d3352d..a10c0566f8 --- a/core/math/bitfields/bitfields-tests.factor +++ b/core/math/bitfields/bitfields-tests.factor @@ -1,4 +1,4 @@ -USING: math math.bitfields tools.test kernel ; +USING: math math.bitfields tools.test kernel words ; IN: temporary [ 0 ] [ { } bitfield ] unit-test @@ -6,3 +6,12 @@ IN: temporary [ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test [ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test [ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test + +: a 1 ; inline +: b 2 ; inline + +: foo { a b } flags ; + +[ 3 ] [ foo ] unit-test +[ 3 ] [ { a b } flags ] unit-test +[ t ] [ \ foo compiled? ] unit-test diff --git a/core/optimizer/optimizer-tests.factor b/core/optimizer/optimizer-tests.factor new file mode 100755 index 0000000000..232eb5a83a --- /dev/null +++ b/core/optimizer/optimizer-tests.factor @@ -0,0 +1,303 @@ +USING: arrays compiler generic hashtables inference kernel +kernel.private math optimizer prettyprint sequences sbufs +strings tools.test vectors words sequences.private quotations +optimizer.backend classes inference.dataflow tuples.private +continuations growable ; +IN: temporary + +[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* +] unit-test + +[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ + H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* +] unit-test + +! Test method inlining +[ f ] [ fixnum { } min-class ] unit-test + +[ string ] [ + \ string + [ integer string array reversed sbuf + slice vector quotation ] + sort-classes min-class +] unit-test + +[ fixnum ] [ + \ fixnum + [ fixnum integer object ] + sort-classes min-class +] unit-test + +[ integer ] [ + \ fixnum + [ integer float object ] + sort-classes min-class +] unit-test + +[ object ] [ + \ word + [ integer float object ] + sort-classes min-class +] unit-test + +[ reversed ] [ + \ reversed + [ integer reversed slice ] + sort-classes min-class +] unit-test + +GENERIC: xyz ( obj -- obj ) +M: array xyz xyz ; + +[ t ] [ \ xyz compiled? ] unit-test + +! Test predicate inlining +: pred-test-1 + dup fixnum? [ + dup integer? [ "integer" ] [ "nope" ] if + ] [ + "not a fixnum" + ] if ; + +[ 1 "integer" ] [ 1 pred-test-1 ] unit-test + +TUPLE: pred-test ; + +: pred-test-2 + dup tuple? [ + dup pred-test? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test + +: pred-test-3 + dup pred-test? [ + dup tuple? [ "pred-test" ] [ "nope" ] if + ] [ + "not a tuple" + ] if ; + +[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test + +: inline-test + "nom" = ; + +[ t ] [ "nom" inline-test ] unit-test +[ f ] [ "shayin" inline-test ] unit-test +[ f ] [ 3 inline-test ] unit-test + +: fixnum-declarations >fixnum 24 shift 1234 bitxor ; + +[ ] [ 1000000 fixnum-declarations . ] unit-test + +! regression + +: literal-not-branch 0 not [ ] [ ] if ; + +[ ] [ literal-not-branch ] unit-test + +! regression + +: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline +: bad-kill-2 bad-kill-1 drop ; + +[ 3 ] [ t bad-kill-2 ] unit-test + +! regression +: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline +: the-test ( -- x y ) 2 dup (the-test) ; + +[ 2 0 ] [ the-test ] unit-test + +! regression +: (double-recursion) ( start end -- ) + < [ + 6 1 (double-recursion) + 3 2 (double-recursion) + ] when ; inline + +: double-recursion 0 2 (double-recursion) ; + +[ ] [ double-recursion ] unit-test + +! regression +: double-label-1 ( a b c -- d ) + [ f double-label-1 ] [ swap nth-unsafe ] if ; inline + +: double-label-2 ( a -- b ) + dup array? [ ] [ ] if 0 t double-label-1 ; + +[ 0 ] [ 10 double-label-2 ] unit-test + +! regression +GENERIC: void-generic ( obj -- * ) +: breakage "hi" void-generic ; +[ t ] [ \ breakage compiled? ] unit-test +[ breakage ] must-fail + +! regression +: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline +: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline +: test-2 ( -- ) 5 test-1 ; + +[ f ] [ f test-2 ] unit-test + +: branch-fold-regression-0 ( m -- n ) + t [ ] [ 1+ branch-fold-regression-0 ] if ; inline + +: branch-fold-regression-1 ( -- m ) + 10 branch-fold-regression-0 ; + +[ 10 ] [ branch-fold-regression-1 ] unit-test + +! another regression +: constant-branch-fold-0 "hey" ; foldable +: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline +[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! another regression +: foo f ; +: bar foo 4 4 = and ; +[ f ] [ bar ] unit-test + +! ensure identities are working in some form +[ t ] [ + [ { number } declare 0 + ] dataflow optimize + [ #push? ] node-exists? not +] unit-test + +! compiling with a non-literal class failed +: -regression ; + +[ t ] [ \ -regression compiled? ] unit-test + +GENERIC: foozul ( a -- b ) +M: reversed foozul ; +M: integer foozul ; +M: slice foozul ; + +[ reversed ] [ reversed \ foozul specific-method ] unit-test + +! regression +: constant-fold-2 f ; foldable +: constant-fold-3 4 ; foldable + +[ f t ] [ + [ constant-fold-2 constant-fold-3 4 = ] compile-call +] unit-test + +: constant-fold-4 f ; foldable +: constant-fold-5 f ; foldable + +[ f ] [ + [ constant-fold-4 constant-fold-5 or ] compile-call +] unit-test + +[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test +[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test +[ 0 ] [ 5 [ dup - ] compile-call ] unit-test + +[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test +[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test +[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test + +[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test +[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test + +[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test +[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test +[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test +[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test + +[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test +[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test +[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test + +[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test +[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test + +[ f ] [ 5 [ dup < ] compile-call ] unit-test +[ t ] [ 5 [ dup <= ] compile-call ] unit-test +[ f ] [ 5 [ dup > ] compile-call ] unit-test +[ t ] [ 5 [ dup >= ] compile-call ] unit-test + +[ t ] [ 5 [ dup eq? ] compile-call ] unit-test +[ t ] [ 5 [ dup = ] compile-call ] unit-test +[ t ] [ 5 [ dup number= ] compile-call ] unit-test +[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test + +GENERIC: detect-number ( obj -- obj ) +M: number detect-number ; + +[ 10 f [ 0 + detect-number ] compile-call ] must-fail + +! Regression +[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test + +! Regression +USE: sorting +USE: sorting.private + +: old-binsearch ( elt quot seq -- elt quot i ) + dup length 1 <= [ + slice-from + ] [ + [ midpoint swap call ] 3keep roll dup zero? + [ drop dup slice-from swap midpoint@ + ] + [ partition old-binsearch ] if + ] if ; inline + +[ 10 ] [ + 10 20 >vector + [ [ - ] swap old-binsearch ] compile-call 2nip +] unit-test + +! Regression +TUPLE: silly-tuple a b ; + +[ 1 2 { silly-tuple-a silly-tuple-b } ] [ + T{ silly-tuple f 1 2 } + [ + { silly-tuple-a silly-tuple-b } [ get-slots ] keep + ] compile-call +] unit-test + +! Regression +: empty-compound ; + +: node-successor-f-bug ( x -- * ) + [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; + +[ t ] [ \ node-successor-f-bug compiled? ] unit-test + +: construct-empty-bug construct-empty ; + +[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test + +! Make sure we have sane heuristics +: should-inline? method method-word flat-length 10 <= ; + +[ t ] [ \ fixnum \ shift should-inline? ] unit-test +[ f ] [ \ array \ equal? should-inline? ] unit-test +[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test +[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test +[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test diff --git a/core/parser/parser.factor b/core/parser/parser.factor index d54bf1c1f4..486c589134 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -18,7 +18,7 @@ TUPLE: lexer text line line-text line-length column ; : ( text -- lexer ) 0 { set-lexer-text set-lexer-line } lexer construct - dup lexer-text empty? [ dup next-line ] unless ; + dup next-line ; : location ( -- loc ) file get lexer get lexer-line 2dup and From 59cc83c29614f33bd177ebfb2d8f40fd12fbffb4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:05 -0600 Subject: [PATCH 104/194] Fix bugs in tools.test --- extra/tools/test/test.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 192a248161..2cbdc3d7c7 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -81,7 +81,7 @@ M: expected-error summary "Traceback" swap third write-object ; : test-failures. ( assoc -- ) - dup [ + [ nl dup empty? [ drop @@ -90,15 +90,15 @@ M: expected-error summary "==== FAILING TESTS:" print [ swap vocab-heading. - [ nl failure. nl ] each + [ failure. nl ] each ] assoc-each ] if ] [ - drop "==== NOTHING TO TEST" print - ] if ; + "==== NOTHING TO TEST" print + ] if* ; : run-tests ( prefix -- failures ) - child-vocabs dup empty? [ f ] [ + child-vocabs dup empty? [ drop f ] [ [ dup run-test ] { } map>assoc [ second empty? not ] subset ] if ; From 6df325c16830f55c925fede788e997d8e4288099 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:30 -0600 Subject: [PATCH 105/194] Moved little-endian? to alien.c-types --- extra/io/unix/select/select.factor | 2 -- 1 file changed, 2 deletions(-) mode change 100644 => 100755 extra/io/unix/select/select.factor diff --git a/extra/io/unix/select/select.factor b/extra/io/unix/select/select.factor old mode 100644 new mode 100755 index c28686d2f2..06e257a610 --- a/extra/io/unix/select/select.factor +++ b/extra/io/unix/select/select.factor @@ -9,8 +9,6 @@ TUPLE: select-mx read-fdset write-fdset ; ! Factor's bit-arrays are an array of bytes, OS X expects ! FD_SET to be an array of cells, so we have to account for ! byte order differences on big endian platforms -: little-endian? 1 *char 1 = ; foldable - : munge ( i -- i' ) little-endian? [ BIN: 11000 bitxor ] unless ; inline From b14197fadcb607ffc84f9f05531c11e567cd0561 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 01:49:49 -0600 Subject: [PATCH 106/194] Remove obsolete files --- core/compiler/test/alien.factor | 356 ---------------------------- core/compiler/test/optimizer.factor | 303 ----------------------- 2 files changed, 659 deletions(-) delete mode 100755 core/compiler/test/alien.factor delete mode 100755 core/compiler/test/optimizer.factor diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor deleted file mode 100755 index 4adb1c234b..0000000000 --- a/core/compiler/test/alien.factor +++ /dev/null @@ -1,356 +0,0 @@ -IN: temporary -USING: alien alien.c-types alien.syntax compiler kernel -namespaces namespaces tools.test sequences inference words -arrays parser quotations continuations inference.backend effects -namespaces.private io io.streams.string memory system threads -tools.test ; - -FUNCTION: void ffi_test_0 ; -[ ] [ ffi_test_0 ] unit-test - -FUNCTION: int ffi_test_1 ; -[ 3 ] [ ffi_test_1 ] unit-test - -FUNCTION: int ffi_test_2 int x int y ; -[ 5 ] [ 2 3 ffi_test_2 ] unit-test -[ "hi" 3 ffi_test_2 ] must-fail - -FUNCTION: int ffi_test_3 int x int y int z int t ; -[ 25 ] [ 2 3 4 5 ffi_test_3 ] unit-test - -FUNCTION: float ffi_test_4 ; -[ 1.5 ] [ ffi_test_4 ] unit-test - -FUNCTION: double ffi_test_5 ; -[ 1.5 ] [ ffi_test_5 ] unit-test - -FUNCTION: int ffi_test_9 int a int b int c int d int e int f int g ; -[ 28 ] [ 1 2 3 4 5 6 7 ffi_test_9 ] unit-test -[ "a" 2 3 4 5 6 7 ffi_test_9 ] must-fail -[ 1 2 3 4 5 6 "a" ffi_test_9 ] must-fail - -C-STRUCT: foo - { "int" "x" } - { "int" "y" } -; - -: make-foo ( x y -- foo ) - "foo" [ set-foo-y ] keep [ set-foo-x ] keep ; - -FUNCTION: int ffi_test_11 int a foo b int c ; - -[ 14 ] [ 1 2 3 make-foo 4 ffi_test_11 ] unit-test - -FUNCTION: int ffi_test_13 int a int b int c int d int e int f int g int h int i int j int k ; - -[ 66 ] [ 1 2 3 4 5 6 7 8 9 10 11 ffi_test_13 ] unit-test - -FUNCTION: foo ffi_test_14 int x int y ; - -[ 11 6 ] [ 11 6 ffi_test_14 dup foo-x swap foo-y ] unit-test - -FUNCTION: char* ffi_test_15 char* x char* y ; - -[ "foo" ] [ "xy" "zt" ffi_test_15 ] unit-test -[ "bar" ] [ "xy" "xy" ffi_test_15 ] unit-test -[ 1 2 ffi_test_15 ] must-fail - -C-STRUCT: bar - { "long" "x" } - { "long" "y" } - { "long" "z" } -; - -FUNCTION: bar ffi_test_16 long x long y long z ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_16 dup bar-x over bar-y rot bar-z -] unit-test - -C-STRUCT: tiny - { "int" "x" } -; - -FUNCTION: tiny ffi_test_17 int x ; - -[ 11 ] [ 11 ffi_test_17 tiny-x ] unit-test - -[ [ alien-indirect ] infer ] [ inference-error? ] must-fail-with - -: indirect-test-1 - "int" { } "cdecl" alien-indirect ; - -{ 1 1 } [ indirect-test-1 ] must-infer-as - -[ 3 ] [ "ffi_test_1" f dlsym indirect-test-1 ] unit-test - -[ -1 indirect-test-1 ] must-fail - -: indirect-test-2 - "int" { "int" "int" } "cdecl" alien-indirect data-gc ; - -{ 3 1 } [ indirect-test-2 ] must-infer-as - -[ 5 ] -[ 2 3 "ffi_test_2" f dlsym indirect-test-2 ] -unit-test - -: indirect-test-3 - "int" { "int" "int" "int" "int" } "stdcall" alien-indirect - data-gc ; - -<< "f-stdcall" f "stdcall" add-library >> - -[ f ] [ "f-stdcall" load-library ] unit-test -[ "stdcall" ] [ "f-stdcall" library library-abi ] unit-test - -: ffi_test_18 ( w x y z -- int ) - "int" "f-stdcall" "ffi_test_18" { "int" "int" "int" "int" } - alien-invoke data-gc ; - -[ 25 ] [ 2 3 4 5 ffi_test_18 ] unit-test - -: ffi_test_19 ( x y z -- bar ) - "bar" "f-stdcall" "ffi_test_19" { "long" "long" "long" } - alien-invoke data-gc ; - -[ 11 6 -7 ] [ - 11 6 -7 ffi_test_19 dup bar-x over bar-y rot bar-z -] unit-test - -FUNCTION: double ffi_test_6 float x float y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_6 ] unit-test -[ "a" "b" ffi_test_6 ] must-fail - -FUNCTION: double ffi_test_7 double x double y ; -[ 6.0 ] [ 3.0 2.0 ffi_test_7 ] unit-test - -FUNCTION: double ffi_test_8 double x float y double z float t int w ; -[ 19.0 ] [ 3.0 2.0 1.0 6.0 7 ffi_test_8 ] unit-test - -FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; -[ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test - -FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; - -[ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test - -! Make sure XT doesn't get clobbered in stack frame - -: ffi_test_31 - "void" - f "ffi_test_31" - { "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" } - alien-invoke code-gc 3 ; - -[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test - -FUNCTION: longlong ffi_test_21 long x long y ; - -[ 121932631112635269 ] -[ 123456789 987654321 ffi_test_21 ] unit-test - -FUNCTION: long ffi_test_22 long x longlong y longlong z ; - -[ 987655432 ] -[ 1111 121932631112635269 123456789 ffi_test_22 ] unit-test - -[ 1111 f 123456789 ffi_test_22 ] must-fail - -C-STRUCT: rect - { "float" "x" } - { "float" "y" } - { "float" "w" } - { "float" "h" } -; - -: - "rect" - [ set-rect-h ] keep - [ set-rect-w ] keep - [ set-rect-y ] keep - [ set-rect-x ] keep ; - -FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; - -[ 45 ] [ 1 2 3.0 4.0 5.0 6.0 7 8 9 ffi_test_12 ] unit-test - -[ 1 2 { 1 2 3 } 7 8 9 ffi_test_12 ] must-fail - -FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; - -[ 32.0 ] [ { 1.0 2.0 3.0 } >c-float-array { 4.0 5.0 6.0 } >c-float-array ffi_test_23 ] unit-test - -! Test odd-size structs -C-STRUCT: test-struct-1 { { "char" 1 } "x" } ; - -FUNCTION: test-struct-1 ffi_test_24 ; - -[ B{ 1 } ] [ ffi_test_24 ] unit-test - -C-STRUCT: test-struct-2 { { "char" 2 } "x" } ; - -FUNCTION: test-struct-2 ffi_test_25 ; - -[ B{ 1 2 } ] [ ffi_test_25 ] unit-test - -C-STRUCT: test-struct-3 { { "char" 3 } "x" } ; - -FUNCTION: test-struct-3 ffi_test_26 ; - -[ B{ 1 2 3 } ] [ ffi_test_26 ] unit-test - -C-STRUCT: test-struct-4 { { "char" 4 } "x" } ; - -FUNCTION: test-struct-4 ffi_test_27 ; - -[ B{ 1 2 3 4 } ] [ ffi_test_27 ] unit-test - -C-STRUCT: test-struct-5 { { "char" 5 } "x" } ; - -FUNCTION: test-struct-5 ffi_test_28 ; - -[ B{ 1 2 3 4 5 } ] [ ffi_test_28 ] unit-test - -C-STRUCT: test-struct-6 { { "char" 6 } "x" } ; - -FUNCTION: test-struct-6 ffi_test_29 ; - -[ B{ 1 2 3 4 5 6 } ] [ ffi_test_29 ] unit-test - -C-STRUCT: test-struct-7 { { "char" 7 } "x" } ; - -FUNCTION: test-struct-7 ffi_test_30 ; - -[ B{ 1 2 3 4 5 6 7 } ] [ ffi_test_30 ] unit-test - -C-STRUCT: test-struct-8 { "double" "x" } { "double" "y" } ; - -FUNCTION: double ffi_test_32 test-struct-8 x int y ; - -[ 9.0 ] [ - "test-struct-8" - 1.0 over set-test-struct-8-x - 2.0 over set-test-struct-8-y - 3 ffi_test_32 -] unit-test - -C-STRUCT: test-struct-9 { "float" "x" } { "float" "y" } ; - -FUNCTION: double ffi_test_33 test-struct-9 x int y ; - -[ 9.0 ] [ - "test-struct-9" - 1.0 over set-test-struct-9-x - 2.0 over set-test-struct-9-y - 3 ffi_test_33 -] unit-test - -C-STRUCT: test-struct-10 { "float" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_34 test-struct-10 x int y ; - -[ 9.0 ] [ - "test-struct-10" - 1.0 over set-test-struct-10-x - 2 over set-test-struct-10-y - 3 ffi_test_34 -] unit-test - -C-STRUCT: test-struct-11 { "int" "x" } { "int" "y" } ; - -FUNCTION: double ffi_test_35 test-struct-11 x int y ; - -[ 9.0 ] [ - "test-struct-11" - 1 over set-test-struct-11-x - 2 over set-test-struct-11-y - 3 ffi_test_35 -] unit-test - -C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ; - -: make-struct-12 - "test-struct-12" - [ set-test-struct-12-x ] keep ; - -FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; - -[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test - -! Test callbacks - -: callback-1 "void" { } "cdecl" [ ] alien-callback ; - -[ 0 1 ] [ [ callback-1 ] infer dup effect-in swap effect-out ] unit-test - -[ t ] [ callback-1 alien? ] unit-test - -: callback_test_1 "void" { } "cdecl" alien-indirect ; - -[ ] [ callback-1 callback_test_1 ] unit-test - -: callback-2 "void" { } "cdecl" [ [ 5 throw ] ignore-errors ] alien-callback ; - -[ ] [ callback-2 callback_test_1 ] unit-test - -: callback-3 "void" { } "cdecl" [ 5 "x" set ] alien-callback ; - -[ t ] [ - namestack* - 3 "x" set callback-3 callback_test_1 - namestack* eq? -] unit-test - -[ 5 ] [ - [ - 3 "x" set callback-3 callback_test_1 "x" get - ] with-scope -] unit-test - -: callback-4 - "void" { } "cdecl" [ "Hello world" write ] alien-callback - data-gc ; - -[ "Hello world" ] [ - [ callback-4 callback_test_1 ] string-out -] unit-test - -: callback-5 - "void" { } "cdecl" [ data-gc ] alien-callback ; - -[ "testing" ] [ - "testing" callback-5 callback_test_1 -] unit-test - -: callback-5a - "void" { } "cdecl" [ 8000000 f drop ] alien-callback ; - -! Hack; if we're on ARM, we probably don't have much RAM, so -! skip this test. -cpu "arm" = [ - [ "testing" ] [ - "testing" callback-5a callback_test_1 - ] unit-test -] unless - -: callback-6 - "void" { } "cdecl" [ [ continue ] callcc0 ] alien-callback ; - -[ 1 2 3 ] [ callback-6 callback_test_1 1 2 3 ] unit-test - -: callback-7 - "void" { } "cdecl" [ 1000 sleep ] alien-callback ; - -[ 1 2 3 ] [ callback-7 callback_test_1 1 2 3 ] unit-test - -[ f ] [ namespace global eq? ] unit-test - -: callback-8 - "void" { } "cdecl" [ - [ continue ] callcc0 - ] alien-callback ; - -[ ] [ callback-8 callback_test_1 ] unit-test diff --git a/core/compiler/test/optimizer.factor b/core/compiler/test/optimizer.factor deleted file mode 100755 index 987aace00a..0000000000 --- a/core/compiler/test/optimizer.factor +++ /dev/null @@ -1,303 +0,0 @@ -USING: arrays compiler generic hashtables inference kernel -kernel.private math optimizer prettyprint sequences sbufs -strings tools.test vectors words sequences.private quotations -optimizer.backend classes inference.dataflow tuples.private -continuations growable ; -IN: temporary - -[ H{ { 1 5 } { 3 4 } { 2 5 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 5 } } union* -] unit-test - -[ H{ { 1 4 } { 2 4 } { 3 4 } } ] [ - H{ { 1 2 } { 3 4 } } H{ { 2 3 } } union* -] unit-test - -! Test method inlining -[ f ] [ fixnum { } min-class ] unit-test - -[ string ] [ - \ string - [ integer string array reversed sbuf - slice vector quotation ] - sort-classes min-class -] unit-test - -[ fixnum ] [ - \ fixnum - [ fixnum integer object ] - sort-classes min-class -] unit-test - -[ integer ] [ - \ fixnum - [ integer float object ] - sort-classes min-class -] unit-test - -[ object ] [ - \ word - [ integer float object ] - sort-classes min-class -] unit-test - -[ reversed ] [ - \ reversed - [ integer reversed slice ] - sort-classes min-class -] unit-test - -GENERIC: xyz ( obj -- obj ) -M: array xyz xyz ; - -[ t ] [ \ xyz compiled? ] unit-test - -! Test predicate inlining -: pred-test-1 - dup fixnum? [ - dup integer? [ "integer" ] [ "nope" ] if - ] [ - "not a fixnum" - ] if ; - -[ 1 "integer" ] [ 1 pred-test-1 ] unit-test - -TUPLE: pred-test ; - -: pred-test-2 - dup tuple? [ - dup pred-test? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-2 ] unit-test - -: pred-test-3 - dup pred-test? [ - dup tuple? [ "pred-test" ] [ "nope" ] if - ] [ - "not a tuple" - ] if ; - -[ T{ pred-test } "pred-test" ] [ T{ pred-test } pred-test-3 ] unit-test - -: inline-test - "nom" = ; - -[ t ] [ "nom" inline-test ] unit-test -[ f ] [ "shayin" inline-test ] unit-test -[ f ] [ 3 inline-test ] unit-test - -: fixnum-declarations >fixnum 24 shift 1234 bitxor ; - -[ ] [ 1000000 fixnum-declarations . ] unit-test - -! regression - -: literal-not-branch 0 not [ ] [ ] if ; - -[ ] [ literal-not-branch ] unit-test - -! regression - -: bad-kill-1 ( a b -- c d e ) [ 3 f ] [ dup bad-kill-1 ] if ; inline -: bad-kill-2 bad-kill-1 drop ; - -[ 3 ] [ t bad-kill-2 ] unit-test - -! regression -: (the-test) ( x -- y ) dup 0 > [ 1- (the-test) ] when ; inline -: the-test ( -- x y ) 2 dup (the-test) ; - -[ 2 0 ] [ the-test ] unit-test - -! regression -: (double-recursion) ( start end -- ) - < [ - 6 1 (double-recursion) - 3 2 (double-recursion) - ] when ; inline - -: double-recursion 0 2 (double-recursion) ; - -[ ] [ double-recursion ] unit-test - -! regression -: double-label-1 ( a b c -- d ) - [ f double-label-1 ] [ swap nth-unsafe ] if ; inline - -: double-label-2 ( a -- b ) - dup array? [ ] [ ] if 0 t double-label-1 ; - -[ 0 ] [ 10 double-label-2 ] unit-test - -! regression -GENERIC: void-generic ( obj -- * ) -: breakage "hi" void-generic ; -[ t ] [ \ breakage compiled? ] unit-test -[ breakage ] must-fail - -! regression -: test-0 ( n -- ) dup 0 = [ drop ] [ 1- test-0 ] if ; inline -: test-1 ( n -- ) t [ test-0 ] [ delegate dup [ test-1 ] [ drop ] if ] if ; inline -: test-2 ( -- ) 5 test-1 ; - -[ f ] [ f test-2 ] unit-test - -: branch-fold-regression-0 ( m -- n ) - t [ ] [ 1+ branch-fold-regression-0 ] if ; inline - -: branch-fold-regression-1 ( -- m ) - 10 branch-fold-regression-0 ; - -[ 10 ] [ branch-fold-regression-1 ] unit-test - -! another regression -: constant-branch-fold-0 "hey" ; foldable -: constant-branch-fold-1 constant-branch-fold-0 "hey" = ; inline -[ 1 ] [ [ constant-branch-fold-1 [ 1 ] [ 2 ] if ] compile-call ] unit-test - -! another regression -: foo f ; -: bar foo 4 4 = and ; -[ f ] [ bar ] unit-test - -! ensure identities are working in some form -[ t ] [ - [ { number } declare 0 + ] dataflow optimize - [ #push? ] node-exists? not -] unit-test - -! compiling with a non-literal class failed -: -regression ; - -[ t ] [ \ -regression compiled? ] unit-test - -GENERIC: foozul ( a -- b ) -M: reversed foozul ; -M: integer foozul ; -M: slice foozul ; - -[ reversed ] [ reversed \ foozul specific-method ] unit-test - -! regression -: constant-fold-2 f ; foldable -: constant-fold-3 4 ; foldable - -[ f t ] [ - [ constant-fold-2 constant-fold-3 4 = ] compile-call -] unit-test - -: constant-fold-4 f ; foldable -: constant-fold-5 f ; foldable - -[ f ] [ - [ constant-fold-4 constant-fold-5 or ] compile-call -] unit-test - -[ 5 ] [ 5 [ 0 + ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap + ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 - ] compile-call ] unit-test -[ -5 ] [ 5 [ 0 swap - ] compile-call ] unit-test -[ 0 ] [ 5 [ dup - ] compile-call ] unit-test - -[ 5 ] [ 5 [ 1 * ] compile-call ] unit-test -[ 5 ] [ 5 [ 1 swap * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 * ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 * ] compile-call ] unit-test -[ -5 ] [ 5 [ -1 swap * ] compile-call ] unit-test - -[ 0 ] [ 5 [ 1 mod ] compile-call ] unit-test -[ 0 ] [ 5 [ 1 rem ] compile-call ] unit-test - -[ 5 ] [ 5 [ -1 bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ -1 swap bitand ] compile-call ] unit-test -[ 0 ] [ 5 [ 0 swap bitand ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitand ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitor ] compile-call ] unit-test -[ -1 ] [ 5 [ -1 swap bitor ] compile-call ] unit-test -[ 5 ] [ 5 [ dup bitor ] compile-call ] unit-test - -[ 5 ] [ 5 [ 0 bitxor ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 swap bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 bitxor ] compile-call ] unit-test -[ -6 ] [ 5 [ -1 swap bitxor ] compile-call ] unit-test -[ 0 ] [ 5 [ dup bitxor ] compile-call ] unit-test - -[ 0 ] [ 5 [ 0 swap shift ] compile-call ] unit-test -[ 5 ] [ 5 [ 0 shift ] compile-call ] unit-test - -[ f ] [ 5 [ dup < ] compile-call ] unit-test -[ t ] [ 5 [ dup <= ] compile-call ] unit-test -[ f ] [ 5 [ dup > ] compile-call ] unit-test -[ t ] [ 5 [ dup >= ] compile-call ] unit-test - -[ t ] [ 5 [ dup eq? ] compile-call ] unit-test -[ t ] [ 5 [ dup = ] compile-call ] unit-test -[ t ] [ 5 [ dup number= ] compile-call ] unit-test -[ t ] [ \ vector [ \ vector = ] compile-call ] unit-test - -GENERIC: detect-number ( obj -- obj ) -M: number detect-number ; - -[ 10 f [ 0 + detect-number ] compile-call ] must-fail - -! Regression -[ 4 [ + ] ] [ 2 2 [ [ + ] [ call ] keep ] compile-call ] unit-test - -! Regression -USE: sorting -USE: sorting.private - -: old-binsearch ( elt quot seq -- elt quot i ) - dup length 1 <= [ - slice-from - ] [ - [ midpoint swap call ] 3keep roll dup zero? - [ drop dup slice-from swap midpoint@ + ] - [ partition old-binsearch ] if - ] if ; inline - -[ 10 ] [ - 10 20 >vector - [ [ - ] swap old-binsearch ] compile-call 2nip -] unit-test - -! Regression -TUPLE: silly-tuple a b ; - -[ 1 2 { silly-tuple-a silly-tuple-b } ] [ - T{ silly-tuple f 1 2 } - [ - { silly-tuple-a silly-tuple-b } [ get-slots ] keep - ] compile-call -] unit-test - -! Regression -: empty-compound ; - -: node-successor-f-bug ( x -- * ) - [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ; - -[ t ] [ \ node-successor-f-bug compiled? ] unit-test - -: construct-empty-bug construct-empty ; - -[ ] [ [ construct-empty ] dataflow optimize drop ] unit-test - -! Make sure we have sane heuristics -: should-inline? method method-word flat-length 10 <= ; - -[ t ] [ \ fixnum \ shift should-inline? ] unit-test -[ f ] [ \ array \ equal? should-inline? ] unit-test -[ f ] [ \ sequence \ hashcode* should-inline? ] unit-test -[ t ] [ \ array \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ growable \ nth-unsafe should-inline? ] unit-test -[ t ] [ \ sbuf \ set-nth-unsafe should-inline? ] unit-test From 7adb07bcc4354c8f32befc3cfce5242c6b11687e Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 03:11:47 -0600 Subject: [PATCH 107/194] concurrency docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index f04811b72a..538ed847f0 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; From 3f38bf18ec98e02af5a42422d167bc8122053b89 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 03:14:08 -0600 Subject: [PATCH 108/194] concurrency docs fix --- extra/concurrency/concurrency-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/concurrency/concurrency-docs.factor b/extra/concurrency/concurrency-docs.factor index 538ed847f0..16a2e65a90 100644 --- a/extra/concurrency/concurrency-docs.factor +++ b/extra/concurrency/concurrency-docs.factor @@ -138,7 +138,7 @@ ARTICLE: { "concurrency" "servers" } "Servers" ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous Sends" { $link send } " sends a message asynchronously, and the sending process continues immediately. The 'pong server' example shown previously all sent messages to the server and waited for a reply back from the server. This pattern of synchronous sending is made easier with " { $link send-synchronous } ".\n\nThis word will send a message to the given process and immediately block until a reply is received for this particular message send. It leaves the reply on the stack. Note that it doesn't wait for just any reply, it waits for a reply specifically to this send.\n\nTo do this it wraps the requested message inside a tagged message format using " { $link tag-message } ":" { $code "\"My Message\" tag-message .\n => { ...from... ...tag... \"My Message\" }" } -"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag can used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" +"The message is wrapped in array where the first item is the sending process object, the second is a unique tag, and the third is the original message. Server processes can use the 'from' to reply to the process that originally sent the message. The tag is used in the receiving server to include the value in the reply. After the send-synchronous call the current process will block waiting for a reply that has the exact same tag. In this way you can be sure that the reply you got was for the specific message sent. Here is the pong-server recoded to use 'send-synchronous':" { $code ": pong-server ( -- )\n receive {\n { { ?from ?tag \"ping\" } [ ?tag \"pong\" 2array ?from send pong-server ] }\n { { ?from _ } [ ?tag \"server shutdown\" 2array ?from send ] }\n } match-cond ;\n\n[ pong-server ] spawn \"ping\" swap send-synchronous .\n => \"pong\"" } "Notice that the code to send the reply back to the original caller wraps the reply in an array where the first item is the tag originally sent. 'send-synchronous' only returns if it receives a reply containing that specific tag." ; From d41bfc64f1686af2a53fb9be984b8324763aee28 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 17:00:42 -0600 Subject: [PATCH 109/194] Minor tests fix --- extra/tools/test/test.factor | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/extra/tools/test/test.factor b/extra/tools/test/test.factor index 2cbdc3d7c7..0b5e436e44 100755 --- a/extra/tools/test/test.factor +++ b/extra/tools/test/test.factor @@ -61,9 +61,14 @@ M: expected-error summary dup vocab-source-loaded? [ vocab-tests-path dup [ dup ?resource-path exists? [ - [ "temporary" forget-vocab ] with-compilation-unit + [ + "temporary" forget-vocab + ] with-compilation-unit dup run-file - [ dup forget-source ] with-compilation-unit + [ + dup forget-source + "temporary" forget-vocab + ] with-compilation-unit ] when ] when ] when drop ; From 5570f367a631dddd2e0f42078baa15641ed12567 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 20:09:59 -0600 Subject: [PATCH 110/194] builder: build-status variable --- extra/builder/builder.factor | 12 ++++++++++++ 1 file changed, 12 insertions(+) mode change 100755 => 100644 extra/builder/builder.factor diff --git a/extra/builder/builder.factor b/extra/builder/builder.factor old mode 100755 new mode 100644 index 9af79efb29..1c5f5ff3fd --- a/extra/builder/builder.factor +++ b/extra/builder/builder.factor @@ -59,8 +59,12 @@ VAR: stamp ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +SYMBOL: build-status + : build ( -- ) + "running" build-status set-global + datestamp >stamp "/builds/factor" cd @@ -98,6 +102,8 @@ VAR: stamp { "make" "clean" } run-process drop + ! "vm" build-status set-global + `{ { +arguments+ { "make" ,[ target ] } } { +stdout+ "../compile-log" } @@ -116,6 +122,8 @@ VAR: stamp [ "builder: image download" email-string ] cleanup + ! "bootstrap" build-status set-global + `{ { +arguments+ { ,[ factor-binary ] @@ -133,6 +141,8 @@ VAR: stamp "builder: bootstrap" throw ] if + ! "test" build-status set-global + `{ ,[ factor-binary ] "-run=builder.test" } run-process drop "../load-everything-log" exists? @@ -143,6 +153,8 @@ VAR: stamp [ "builder: failing tests" "../failing-tests" email-file ] when + ! "ready" build-status set-global + ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 7b07ababba5a9f95d17fa9c67fbfe006d97916cd Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 20:16:12 -0600 Subject: [PATCH 111/194] add builder.server --- extra/builder/server/server.factor | 68 ++++++++++++++++++++++++++++++ 1 file changed, 68 insertions(+) create mode 100644 extra/builder/server/server.factor diff --git a/extra/builder/server/server.factor b/extra/builder/server/server.factor new file mode 100644 index 0000000000..672de1e47d --- /dev/null +++ b/extra/builder/server/server.factor @@ -0,0 +1,68 @@ + +USING: kernel continuations namespaces threads match bake concurrency builder ; + +IN: builder.server + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ [ build ] in-thread ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! : build-server ( -- ) +! receive +! { +! { +! "start" +! [ +! [ [ build ] [ drop ] recover "idle" build-status set-global ] in-thread +! ] +! } + +! { +! { ?from ?tag "status" } +! [ `{ ?tag ,[ build-status get ] } ?from send ] +! } +! } +! match-cond +! build-server ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: build-server ( -- ) + receive + { + { + "start" + [ + build-status get "idle" = + build-status get f = + or + [ + [ [ build ] [ drop ] recover "idle" build-status set-global ] + in-thread + ] + when + ] + } + + { + { ?from ?tag "status" } + [ `{ ?tag ,[ build-status get ] } ?from send ] + } + } + match-cond + build-server ; + From d7af06c75ae454e15097108af22f9544a7e6a7ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:13:05 -0600 Subject: [PATCH 112/194] Remove obsolete scripts --- misc/integration/deploy-size-test.factor | 28 ------- misc/integration/macosx-deploy.factor | 24 ------ misc/integration/macosx.sh | 43 ----------- misc/integration/test.sh | 93 ------------------------ misc/integration/unix-arm.sh | 10 --- misc/integration/unix-ppc.sh | 10 --- misc/integration/unix-x86.32.sh | 21 ------ misc/integration/unix-x86.64.sh | 10 --- misc/integration/x11-deploy.factor | 8 -- 9 files changed, 247 deletions(-) delete mode 100644 misc/integration/deploy-size-test.factor delete mode 100644 misc/integration/macosx-deploy.factor delete mode 100644 misc/integration/macosx.sh delete mode 100644 misc/integration/test.sh delete mode 100644 misc/integration/unix-arm.sh delete mode 100644 misc/integration/unix-ppc.sh delete mode 100644 misc/integration/unix-x86.32.sh delete mode 100644 misc/integration/unix-x86.64.sh delete mode 100644 misc/integration/x11-deploy.factor diff --git a/misc/integration/deploy-size-test.factor b/misc/integration/deploy-size-test.factor deleted file mode 100644 index 91cdaba293..0000000000 --- a/misc/integration/deploy-size-test.factor +++ /dev/null @@ -1,28 +0,0 @@ -USING: tools.deploy sequences io.files io.launcher io -kernel concurrency prettyprint ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-world" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - dup - "deploy-log/" over append - [ deploy ] with-stream - dup file-length 1024 /f - 2array -] parallel-map . diff --git a/misc/integration/macosx-deploy.factor b/misc/integration/macosx-deploy.factor deleted file mode 100644 index f1e6e7fe06..0000000000 --- a/misc/integration/macosx-deploy.factor +++ /dev/null @@ -1,24 +0,0 @@ -USING: tools.deploy.app sequences io.files io.launcher io -kernel concurrency ; - -"." resource-path cd - -"deploy-log" make-directory - -{ - "automata.ui" - "boids.ui" - "bunny" - "color-picker" - "gesture-logger" - "golden-section" - "hello-ui" - "lsys.ui" - "maze" - "nehe" - "tetris" - "catalyst-talk" -} [ - "deploy-log/" over append - [ deploy.app ] with-stream -] parallel-each diff --git a/misc/integration/macosx.sh b/misc/integration/macosx.sh deleted file mode 100644 index dafe9524c6..0000000000 --- a/misc/integration/macosx.sh +++ /dev/null @@ -1,43 +0,0 @@ -CPU=$1 - -if [ "$CPU" = "x86.32" ]; then - TARGET="macosx-x86" -elif [ "$CPU" = "ppc" ]; then - TARGET="macosx-ppc" - CPU = "macosx-ppc" -else - echo "Specify a CPU" - exit 1 -fi - -EXE=factor - -bash misc/integration/test.sh \ - $EXE \ - $CPU \ - $TARGET \ - no \ - no \ - no \ - "X11=1" \ - "-ui-backend=x11" \ - "-x11" || exit 1 - -echo "Testing deployment" -$EXE "misc/integration/x11-deploy.factor" -run=none $VM_LOG $BOOT_LOG /tmp/factor-$$ - - $EXE -i=$IMAGE \ - /tmp/factor-$$ \ - -run=none \ - >$LOAD_LOG $TEST_LOG $BENCHMARK_LOG [ deploy ] with-stream From 52d91bf0bc0a568ae4d561890cd0082b3410b387 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:15:29 -0600 Subject: [PATCH 113/194] Add try-process word --- extra/benchmark/bootstrap2/bootstrap2.factor | 2 +- extra/bootstrap/image/upload/upload.factor | 3 +-- extra/editors/emacs/emacs.factor | 2 +- extra/editors/textmate/textmate.factor | 2 +- extra/io/launcher/launcher-docs.factor | 10 ++++++++++ extra/io/launcher/launcher.factor | 9 +++++++++ extra/logging/parser/parser.factor | 10 +++++++--- extra/tools/deploy/backend/backend.factor | 5 ++++- extra/tools/deploy/macosx/macosx.factor | 4 ++-- 9 files changed, 36 insertions(+), 11 deletions(-) mode change 100644 => 100755 extra/bootstrap/image/upload/upload.factor diff --git a/extra/benchmark/bootstrap2/bootstrap2.factor b/extra/benchmark/bootstrap2/bootstrap2.factor index 54bc73f4a1..f57e92e5e0 100755 --- a/extra/benchmark/bootstrap2/bootstrap2.factor +++ b/extra/benchmark/bootstrap2/bootstrap2.factor @@ -9,6 +9,6 @@ IN: benchmark.bootstrap2 "-i=" my-boot-image-name append , "-output-image=foo.image" , "-no-user-init" , - ] { } make run-process drop ; + ] { } make try-process ; MAIN: bootstrap-benchmark diff --git a/extra/bootstrap/image/upload/upload.factor b/extra/bootstrap/image/upload/upload.factor old mode 100644 new mode 100755 index a9f5d1dcd4..3b5ab4cb77 --- a/extra/bootstrap/image/upload/upload.factor +++ b/extra/bootstrap/image/upload/upload.factor @@ -16,8 +16,7 @@ bootstrap.image sequences io namespaces io.launcher math ; : upload-images ( -- ) [ "scp" , boot-image-names % "checksums.txt" , destination , - ] { } make run-process - wait-for-process zero? [ "Upload failed" throw ] unless ; + ] { } make try-process ; : new-images ( -- ) make-images compute-checksums upload-images ; diff --git a/extra/editors/emacs/emacs.factor b/extra/editors/emacs/emacs.factor index 31e0761043..966c4f368e 100755 --- a/extra/editors/emacs/emacs.factor +++ b/extra/editors/emacs/emacs.factor @@ -8,7 +8,7 @@ IN: editors.emacs "--no-wait" , "+" swap number>string append , , - ] { } make run-process drop ; + ] { } make try-process ; : emacs ( word -- ) where first2 emacsclient ; diff --git a/extra/editors/textmate/textmate.factor b/extra/editors/textmate/textmate.factor index 0145ccae81..12d45aa192 100755 --- a/extra/editors/textmate/textmate.factor +++ b/extra/editors/textmate/textmate.factor @@ -5,6 +5,6 @@ IN: editors.textmate : textmate-location ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - run-process drop ; + try-process ; [ textmate-location ] edit-hook set-global diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 4979f135ac..e414d98d65 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: process-failed +{ $values { "code" "an exit status" } } +{ $description "Throws a " { $link process-failed } " error." } +{ $error-description "Thrown by " { $link try-process } " if the process exited with a non-zero status code." } ; + +HELP: try-process +{ $values { "desc" "a launch descriptor" } } +{ $description "Launches a process and waits for it to complete. If it exits with a non-zero status code, throws a " { $link process-failed } " error." } ; + HELP: kill-process { $values { "process" process } } { $description "Kills a running process. Does nothing if the process has already exited." } ; @@ -175,6 +184,7 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +{ $subsection try-process } "Stopping processes:" { $subsection kill-process } "Redirecting standard input and output to a pipe:" diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index f2ed59a591..7044004218 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,15 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +TUPLE: process-failed code ; + +: process-failed ( code -- * ) + process-failed construct-boa throw ; + +: try-process ( desc -- ) + run-process wait-for-process dup zero? + [ drop ] [ process-failed ] if ; + HOOK: kill-process* io-backend ( handle -- ) : kill-process ( process -- ) diff --git a/extra/logging/parser/parser.factor b/extra/logging/parser/parser.factor index f1cb7aa17e..f9bf97a442 100755 --- a/extra/logging/parser/parser.factor +++ b/extra/logging/parser/parser.factor @@ -2,13 +2,17 @@ ! See http://factorcode.org/license.txt for BSD license. USING: parser-combinators memoize kernel sequences logging arrays words strings vectors io io.files -namespaces combinators combinators.lib logging.server ; +namespaces combinators combinators.lib logging.server +calendar ; IN: logging.parser : string-of satisfy [ >string ] <@ ; +SYMBOL: multiline + : 'date' - [ CHAR: ] eq? not ] string-of + multiline-header token [ drop multiline ] <@ + [ CHAR: ] eq? not ] string-of [ rfc3339>timestamp ] <@ <|> "[" "]" surrounded-by ; : 'log-level' @@ -41,7 +45,7 @@ MEMO: 'log-line' ( -- parser ) first malformed eq? ; : multiline? ( line -- ? ) - first first CHAR: - = ; + first multiline eq? ; : malformed-line "Warning: malformed log line:" print diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index c295f6369d..2439ef8636 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -22,7 +22,10 @@ IN: tools.deploy.backend +stdout+ +stderr+ set ] H{ } make-assoc dup duplex-stream-out dispose - copy-lines ; + dup copy-lines + process-stream-process wait-for-process zero? [ + "Deployment failed" throw + ] unless ; : make-boot-image ( -- ) #! If stage1 image doesn't exist, create one. diff --git a/extra/tools/deploy/macosx/macosx.factor b/extra/tools/deploy/macosx/macosx.factor index 1bbf198ea0..eb1a4af4a7 100755 --- a/extra/tools/deploy/macosx/macosx.factor +++ b/extra/tools/deploy/macosx/macosx.factor @@ -8,10 +8,10 @@ QUALIFIED: unix IN: tools.deploy.macosx : touch ( path -- ) - { "touch" } swap add run-process drop ; + { "touch" } swap add try-process ; : rm ( path -- ) - { "rm" "-rf" } swap add run-process drop ; + { "rm" "-rf" } swap add try-process ; : bundle-dir ( -- dir ) vm parent-directory parent-directory ; From 20649302fa59634b8bf3fc5aa99f72b94f2d2c10 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:47:35 -0600 Subject: [PATCH 114/194] Fix a couple of issues with futures --- extra/concurrency/concurrency-tests.factor | 14 +++++++--- extra/concurrency/concurrency.factor | 30 +++++++++++++--------- 2 files changed, 28 insertions(+), 16 deletions(-) diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index b6f62d1779..1a19ce7096 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -112,9 +112,9 @@ SYMBOL: value ! The following unit test blocks forever if the ! exception does not propogate. Uncomment when ! this is fixed (via a timeout). -! [ -! [ "this should propogate" throw ] future ?future -! ] must-fail +[ + [ "this should propogate" throw ] future ?future +] must-fail [ ] [ [ "this should not propogate" throw ] future drop @@ -127,4 +127,10 @@ SYMBOL: value [ f ] [ [ "testing unregistering on error" throw ] spawn 100 sleep process-pid get-process -] unit-test \ No newline at end of file +] unit-test + +! Race condition with futures +[ 3 3 ] [ + [ 3 ] future + dup ?future swap ?future +] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index cf44ab125c..e4972c9030 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,29 +264,35 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; +TUPLE: future value processes ; + +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return #! a 'future' on the stack. The future can later be queried with #! ?future. If the quotation has completed the result will be returned. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - [ self send ] compose spawn ; + \ future construct-empty [ + [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - process-mailbox mailbox-get ; - -: parallel-map ( seq quot -- newseq ) - #! Spawn a process to apply quot to each element of seq, - #! joining the results into a sequence at the end. - [ curry future ] curry map [ ?future ] map ; - -: parallel-each ( seq quot -- ) - #! Spawn a process to apply quot to each element of seq, - #! and waits for all processes to complete. - [ f ] compose parallel-map drop ; + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; TUPLE: promise fulfilled? value processes ; From f05cf861eb032f3215690557f16cda2bf4f57394 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 8 Feb 2008 21:47:47 -0600 Subject: [PATCH 115/194] Fix USING: in io.launcher --- extra/io/launcher/launcher.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 7044004218..4a6bbf46fb 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.backend system kernel namespaces strings hashtables sequences assocs combinators vocabs.loader init threads -continuations ; +continuations math ; IN: io.launcher ! Non-blocking process exit notification facility From f45f6879ab04d4d115ee91b21493471592971fb9 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Fri, 8 Feb 2008 23:28:06 -0600 Subject: [PATCH 116/194] Makefile: winnt target downloads dlls --- Makefile | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 05a185f643..9776027a59 100755 --- a/Makefile +++ b/Makefile @@ -123,7 +123,15 @@ solaris-x86-32: solaris-x86-64: $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.solaris.x86.64 -winnt-x86-32: +freetype6.dll: + wget http://factorcode.org/dlls/freetype6.dll + chmod 755 freetype6.dll + +zlib1.dll: + wget http://factorcode.org/dlls/zlib1.dll + chmod 755 zlib1.dll + +winnt-x86-32: freetype6.dll zlib1.dll $(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32 winnt-x86-64: From d65bde09d1a0f6eca0511826eb60d7b493232e25 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:14 -0600 Subject: [PATCH 117/194] Fix bootstrap --- core/alien/c-types/c-types.factor | 3 +++ 1 file changed, 3 insertions(+) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index ed0721a7ff..fbd49cedbb 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -7,6 +7,9 @@ math.parser cpu.architecture alien alien.accessors quotations system compiler.units ; IN: alien.c-types +DEFER: +DEFER: *char + : little-endian? ( -- ? ) 1 *char 1 = ; foldable TUPLE: c-type From cb2dc00762edf5101c3a5689f541cfec39a72252 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:24 -0600 Subject: [PATCH 118/194] Add MAIN: to bootstrap.image.download --- extra/bootstrap/image/download/download.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/extra/bootstrap/image/download/download.factor b/extra/bootstrap/image/download/download.factor index deed045221..df559f49da 100644 --- a/extra/bootstrap/image/download/download.factor +++ b/extra/bootstrap/image/download/download.factor @@ -23,3 +23,7 @@ bootstrap.image sequences io ; "Boot image up to date" print drop ] if ; + +: download-my-image ( -- ) my-arch download-image ; + +MAIN: download-my-image From 6f0e64bb4cb5843174c67df58bdd6c5bb5639a76 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 00:16:30 -0600 Subject: [PATCH 119/194] Add some tags --- extra/concurrency/distributed/tags.txt | 1 + extra/cpu/8080/emulator/tags.txt | 2 +- extra/cpu/8080/tags.txt | 2 +- extra/cryptlib/tags.txt | 1 + extra/http/server/tags.txt | 1 + extra/ldap/tags.txt | 1 + extra/openssl/tags.txt | 1 + extra/smtp/tags.txt | 1 + extra/xml-rpc/tags.txt | 1 + extra/xml/tags.txt | 1 + 10 files changed, 10 insertions(+), 2 deletions(-) diff --git a/extra/concurrency/distributed/tags.txt b/extra/concurrency/distributed/tags.txt index f4274299b1..50cfa263f6 100644 --- a/extra/concurrency/distributed/tags.txt +++ b/extra/concurrency/distributed/tags.txt @@ -1 +1,2 @@ +enterprise extensions diff --git a/extra/cpu/8080/emulator/tags.txt b/extra/cpu/8080/emulator/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/emulator/tags.txt +++ b/extra/cpu/8080/emulator/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cpu/8080/tags.txt b/extra/cpu/8080/tags.txt index 86069f7680..ff94650b8e 100644 --- a/extra/cpu/8080/tags.txt +++ b/extra/cpu/8080/tags.txt @@ -1 +1 @@ -emulator +emulators diff --git a/extra/cryptlib/tags.txt b/extra/cryptlib/tags.txt index bb863cf9a0..b88f9848cd 100644 --- a/extra/cryptlib/tags.txt +++ b/extra/cryptlib/tags.txt @@ -1 +1,2 @@ +enterprise bindings diff --git a/extra/http/server/tags.txt b/extra/http/server/tags.txt index ebb39bcce3..b0881a9ec0 100644 --- a/extra/http/server/tags.txt +++ b/extra/http/server/tags.txt @@ -1,2 +1,3 @@ +enterprise network web diff --git a/extra/ldap/tags.txt b/extra/ldap/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/ldap/tags.txt +++ b/extra/ldap/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/openssl/tags.txt b/extra/openssl/tags.txt index 59ccdd65e6..93e252c19e 100644 --- a/extra/openssl/tags.txt +++ b/extra/openssl/tags.txt @@ -1,2 +1,3 @@ +enterprise network bindings diff --git a/extra/smtp/tags.txt b/extra/smtp/tags.txt index 992ae12982..80d57bb287 100644 --- a/extra/smtp/tags.txt +++ b/extra/smtp/tags.txt @@ -1 +1,2 @@ +enterprise network diff --git a/extra/xml-rpc/tags.txt b/extra/xml-rpc/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml-rpc/tags.txt +++ b/extra/xml-rpc/tags.txt @@ -1 +1,2 @@ +enterprise web diff --git a/extra/xml/tags.txt b/extra/xml/tags.txt index c0772185a0..7698983a7f 100644 --- a/extra/xml/tags.txt +++ b/extra/xml/tags.txt @@ -1 +1,2 @@ +enterprise web From fdac73a4d74a05306293fddebcd39142313b3887 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 02:15:29 -0600 Subject: [PATCH 120/194] Oops --- extra/concurrency/concurrency.factor | 33 ++++++++++++++-------------- 1 file changed, 17 insertions(+), 16 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index e4972c9030..b46439b583 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,12 +264,7 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -TUPLE: future value processes ; - -: notify-future ( value future -- ) - tuck set-future-value - dup future-processes [ schedule-thread ] each - f swap set-future-processes ; +TUPLE: future status value processes ; : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return @@ -277,22 +272,28 @@ TUPLE: future value processes ; #! ?future. If the quotation has completed the result will be returned. #! If not, the process will block until the quotation completes. #! 'quot' must have stack effect ( -- X ). - \ future construct-empty [ + [ [ - >r [ t 2array ] compose [ f 2array ] recover r> - notify-future - ] 2curry spawn drop - ] keep ; + t + ] compose + ] spawn drop + [ self send ] compose spawn ; : ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. - dup future-value [ - first2 [ throw ] unless - ] [ - dup [ future-processes push stop ] curry callcc0 ?future - ] ?if ; + process-mailbox mailbox-get ; + +: parallel-map ( seq quot -- newseq ) + #! Spawn a process to apply quot to each element of seq, + #! joining the results into a sequence at the end. + [ curry future ] curry map [ ?future ] map ; + +: parallel-each ( seq quot -- ) + #! Spawn a process to apply quot to each element of seq, + #! and waits for all processes to complete. + [ f ] compose parallel-map drop ; TUPLE: promise fulfilled? value processes ; From 122be5b48ec22a69dd1afd0d2f441aacb9e4ed97 Mon Sep 17 00:00:00 2001 From: Matthew Willis Date: Sat, 9 Feb 2008 00:17:24 -0800 Subject: [PATCH 121/194] Added set-fullscreen? and fullscreen? hooks along with their cocoa implementations. --- extra/cocoa/cocoa.factor | 1 + extra/ui/backend/backend.factor | 4 ++++ extra/ui/cocoa/cocoa.factor | 14 +++++++++++++- extra/ui/gadgets/worlds/worlds-docs.factor | 9 +++++++++ 4 files changed, 27 insertions(+), 1 deletion(-) diff --git a/extra/cocoa/cocoa.factor b/extra/cocoa/cocoa.factor index cbc6c9d762..c94984f00b 100755 --- a/extra/cocoa/cocoa.factor +++ b/extra/cocoa/cocoa.factor @@ -58,6 +58,7 @@ SYMBOL: super-sent-messages "NSPasteboard" "NSResponder" "NSSavePanel" + "NSScreen" "NSView" "NSWindow" "NSWorkspace" diff --git a/extra/ui/backend/backend.factor b/extra/ui/backend/backend.factor index a0646f35b0..cc1f5f7d05 100755 --- a/extra/ui/backend/backend.factor +++ b/extra/ui/backend/backend.factor @@ -7,6 +7,10 @@ SYMBOL: ui-backend HOOK: set-title ui-backend ( string world -- ) +HOOK: set-fullscreen? ui-backend ( ? world -- ) + +HOOK: fullscreen? ui-backend ( world -- ? ) + HOOK: (open-window) ui-backend ( world -- ) HOOK: (close-window) ui-backend ( handle -- ) diff --git a/extra/ui/cocoa/cocoa.factor b/extra/ui/cocoa/cocoa.factor index 1e46544180..184e6fd856 100755 --- a/extra/ui/cocoa/cocoa.factor +++ b/extra/ui/cocoa/cocoa.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays cocoa cocoa.application command-line +USING: math arrays cocoa cocoa.application command-line kernel memory namespaces cocoa.messages cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types cocoa.windows cocoa.classes cocoa.application sequences system ui ui.backend @@ -53,6 +53,18 @@ M: pasteboard set-clipboard-contents M: cocoa-ui-backend set-title ( string world -- ) world-handle second swap -> setTitle: ; +: enter-fullscreen ( world -- ) + world-handle first NSScreen -> mainScreen f -> enterFullScreenMode:withOptions: drop ; + +: exit-fullscreen ( world -- ) + world-handle first f -> exitFullScreenModeWithOptions: ; + +M: cocoa-ui-backend set-fullscreen? ( ? world -- ) + swap [ enter-fullscreen ] [ exit-fullscreen ] if ; + +M: cocoa-ui-backend fullscreen? ( world -- ? ) + world-handle first -> isInFullScreenMode zero? not ; + : auto-position ( world -- ) dup world-loc { 0 0 } = [ world-handle second -> center diff --git a/extra/ui/gadgets/worlds/worlds-docs.factor b/extra/ui/gadgets/worlds/worlds-docs.factor index a47717329d..8a64750751 100755 --- a/extra/ui/gadgets/worlds/worlds-docs.factor +++ b/extra/ui/gadgets/worlds/worlds-docs.factor @@ -13,6 +13,15 @@ HELP: set-title { $description "Sets the title bar of the native window containing the world." } { $notes "This word should not be called directly by user code. Instead, change the " { $link world-title } " model; see " { $link "models" } "." } ; +HELP: set-fullscreen? +{ $values { "?" "a boolean" } { "world" world } } +{ $description "Sets and unsets fullscreen mode for the world." } +{ $notes "Find a world using " { $link find-world } "." } ; + +HELP: fullscreen? +{ $values { "world" world } { "?" "a boolean" } } +{ $description "Queries the world to see if it is running in fullscreen mode." } ; + HELP: raise-window { $values { "world" world } } { $description "Makes the native window containing the given world the front-most window." } From 7fbbe94d80c473c94f5b11f558cda2f5977d78d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 02:19:26 -0600 Subject: [PATCH 122/194] FEP work in progress --- vm/debug.c | 35 ++++++++++++++++++++++++++++++++++- 1 file changed, 34 insertions(+), 1 deletion(-) diff --git a/vm/debug.c b/vm/debug.c index 5b4320b5e9..01e1ab0f43 100755 --- a/vm/debug.c +++ b/vm/debug.c @@ -38,6 +38,9 @@ void print_array(F_ARRAY* array, CELL nesting) CELL length = array_capacity(array); CELL i; + if(length > 10) + length = 10; + for(i = 0; i < length; i++) { printf(" "); @@ -201,7 +204,7 @@ void dump_objects(F_FIXNUM type) if(type == -1 || type_of(obj) == type) { printf("%lx ",obj); - print_nested_obj(obj,3); + print_nested_obj(obj,1); printf("\n"); } } @@ -210,6 +213,36 @@ void dump_objects(F_FIXNUM type) gc_off = false; } +CELL obj; +CELL look_for; + +void find_references_step(CELL *scan) +{ + if(look_for == *scan) + { + printf("%lx ",obj); + print_nested_obj(obj,1); + printf("\n"); + } +} + +void find_references(CELL look_for_) +{ + look_for = look_for_; + + begin_scan(); + + CELL obj_; + while((obj_ = next_object()) != F) + { + obj = obj_; + do_slots(obj_,find_references_step); + } + + /* end scan */ + gc_off = false; +} + void factorbug(void) { reset_stdio(); From e9a63d7a2c2d080e778a3f3e8bd4b99d2867588f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:10:52 -0600 Subject: [PATCH 123/194] Arrggh --- extra/concurrency/concurrency.factor | 34 ++++++++++++++++++---------- 1 file changed, 22 insertions(+), 12 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index b46439b583..3c8011cc6b 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -264,26 +264,36 @@ PRIVATE> #! so the server continuation gets its new self updated. self swap call ; -TUPLE: future status value processes ; +TUPLE: future value processes ; +: notify-future ( value future -- ) + tuck set-future-value + dup future-processes [ schedule-thread ] each + f swap set-future-processes ; + : future ( quot -- future ) - #! Spawn a process to call the quotation and immediately return - #! a 'future' on the stack. The future can later be queried with - #! ?future. If the quotation has completed the result will be returned. - #! If not, the process will block until the quotation completes. - #! 'quot' must have stack effect ( -- X ). + #! Spawn a process to call the quotation and immediately return. + \ future construct-empty [ [ [ + >r [ t 2array ] compose [ f 2array ] recover r> + notify-future + ] 2curry spawn drop + ] keep ; t ] compose ] spawn drop [ self send ] compose spawn ; - -: ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. - process-mailbox mailbox-get ; + + : ?future ( future -- result ) + #! Block the process until the future has completed and then + #! place the result on the stack. Return the result + #! immediately if the future has completed. + dup future-value [ + first2 [ throw ] unless + ] [ + dup [ future-processes push stop ] curry callcc0 ?future + ] ?if ; : parallel-map ( seq quot -- newseq ) #! Spawn a process to apply quot to each element of seq, From 3121e740f2838d6d29ef0e1291fd8da670bb2416 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:12:14 -0600 Subject: [PATCH 124/194] Fix typo --- core/continuations/continuations-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/continuations/continuations-docs.factor b/core/continuations/continuations-docs.factor index 2977d02c6f..7cf15394ef 100755 --- a/core/continuations/continuations-docs.factor +++ b/core/continuations/continuations-docs.factor @@ -169,7 +169,7 @@ HELP: rethrow HELP: throw-restarts { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } -{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link condition } " with the object associated to the chosen restart on the stack." } +{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } { $examples "Try invoking one of the two restarts which are offered after the below code throws an error:" { $code From 25c64c8ac713cc94bf706124900f3658e3e34167 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:13:06 -0600 Subject: [PATCH 125/194] Arrghh!!! --- extra/concurrency/concurrency.factor | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 3c8011cc6b..50abee8418 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -280,15 +280,11 @@ TUPLE: future value processes ; notify-future ] 2curry spawn drop ] keep ; - t - ] compose - ] spawn drop - [ self send ] compose spawn ; : ?future ( future -- result ) - #! Block the process until the future has completed and then - #! place the result on the stack. Return the result - #! immediately if the future has completed. + #! Block the process until the future has completed and then + #! place the result on the stack. Return the result + #! immediately if the future has completed. dup future-value [ first2 [ throw ] unless ] [ From a21781e3807d1c89cba88989cb694e65d81d0ee3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:14:37 -0600 Subject: [PATCH 126/194] Concurrency fix --- extra/concurrency/concurrency.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index 50abee8418..a8e0bc6eeb 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -270,11 +270,10 @@ TUPLE: future value processes ; tuck set-future-value dup future-processes [ schedule-thread ] each f swap set-future-processes ; - + : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return. \ future construct-empty [ - [ [ >r [ t 2array ] compose [ f 2array ] recover r> notify-future From 5ca99b0105c82b881ccb023fee8b502e5a2651ba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:17:15 -0600 Subject: [PATCH 127/194] Fix 'class' in early bootstrap --- core/classes/classes.factor | 4 +++- core/generic/math/math.factor | 2 +- core/generic/standard/standard.factor | 2 +- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 151429bf69..345676e106 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -20,7 +20,9 @@ PREDICATE: class tuple-class : classes ( -- seq ) classclass ( n -- class ) builtins get nth ; +: type>class ( n -- class ) builtins get-global nth ; + +: bootstrap-type>class ( n -- class ) builtins get nth ; : predicate-word ( word -- predicate ) [ word-name "?" append ] keep word-vocabulary create ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 8cf83b0ba7..21a7857646 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -61,7 +61,7 @@ TUPLE: no-math-method left right generic ; : math-vtable* ( picker max quot -- quot ) [ rot , \ tag , - [ >r [ type>class ] map r> map % ] { } make , + [ >r [ bootstrap-type>class ] map r> map % ] { } make , \ dispatch , ] [ ] make ; inline diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 88f6a05bc2..7f4f423d8b 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -97,7 +97,7 @@ TUPLE: no-method object generic ; [ small-generic ] picker class-hash-dispatch-quot ; : vtable-class ( n -- class ) - type>class [ hi-tag bootstrap-word ] unless* ; + bootstrap-type>class [ hi-tag bootstrap-word ] unless* ; : group-methods ( assoc -- vtable ) #! Input is a predicate -> method association. From ee912c5996e9342d921c51051cd71001d94b2048 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 14:17:40 -0600 Subject: [PATCH 128/194] Walker cleanup --- extra/ui/tools/walker/walker.factor | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 4740ff86d4..a23345d214 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -21,21 +21,21 @@ TUPLE: walker model interpreter history ; : walker-active? ( walker -- ? ) walker-interpreter interpreter-continuation >boolean ; -: walker-command ( gadget quot -- ) - over walker-active? [ with-walker ] [ 2drop ] if ; inline - : save-interpreter ( walker -- ) dup walker-interpreter interpreter-continuation clone swap walker-history push ; -: com-step ( walker -- ) - dup save-interpreter [ step ] walker-command ; +: walker-command ( gadget quot -- ) + over walker-active? [ + over save-interpreter + with-walker + ] [ 2drop ] if ; inline -: com-into ( walker -- ) - dup save-interpreter [ step-into ] walker-command ; +: com-step ( walker -- ) [ step ] walker-command ; -: com-out ( walker -- ) - dup save-interpreter [ step-out ] walker-command ; +: com-into ( walker -- ) [ step-into ] walker-command ; + +: com-out ( walker -- ) [ step-out ] walker-command ; : com-back ( walker -- ) dup walker-history From ef63333980d03f963bb50b076ec52c10923cbcff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 18:12:07 -0600 Subject: [PATCH 129/194] Fix another bug with futures --- extra/concurrency/concurrency-tests.factor | 5 +++++ extra/concurrency/concurrency.factor | 6 +++--- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/extra/concurrency/concurrency-tests.factor b/extra/concurrency/concurrency-tests.factor index 1a19ce7096..8908506d51 100755 --- a/extra/concurrency/concurrency-tests.factor +++ b/extra/concurrency/concurrency-tests.factor @@ -133,4 +133,9 @@ SYMBOL: value [ 3 3 ] [ [ 3 ] future dup ?future swap ?future +] unit-test + +! Another race +[ 3 ] [ + [ 3 yield ] future ?future ] unit-test \ No newline at end of file diff --git a/extra/concurrency/concurrency.factor b/extra/concurrency/concurrency.factor index a8e0bc6eeb..1c5f6322a8 100755 --- a/extra/concurrency/concurrency.factor +++ b/extra/concurrency/concurrency.factor @@ -273,14 +273,14 @@ TUPLE: future value processes ; : future ( quot -- future ) #! Spawn a process to call the quotation and immediately return. - \ future construct-empty [ + f V{ } clone \ future construct-boa [ [ >r [ t 2array ] compose [ f 2array ] recover r> notify-future ] 2curry spawn drop ] keep ; - - : ?future ( future -- result ) + +: ?future ( future -- result ) #! Block the process until the future has completed and then #! place the result on the stack. Return the result #! immediately if the future has completed. From f655a25762173982ee894d61f7ca755524127aa1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:08:47 -0600 Subject: [PATCH 130/194] Fixing compiler test --- core/bootstrap/compiler/compiler.factor | 11 +++++++++++ core/compiler/test/simple/simple-tests.factor | 4 +++- 2 files changed, 14 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index ff9d5c5e1e..2b278ac458 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -77,3 +77,14 @@ nl [ compiled-usages recompile ] recompile-hook set-global " done" print flush + +! Load empty test vocabs +USE: compiler.test.curry +USE: compiler.test.float +USE: compiler.test.intrinsics +USE: compiler.test.redefine +USE: compiler.test.simple +USE: compiler.test.stack-trace +USE: compiler.test.templates +USE: compiler.test.templates-early +USE: compiler.test.tuples diff --git a/core/compiler/test/simple/simple-tests.factor b/core/compiler/test/simple/simple-tests.factor index 3f4f6451a3..743fb713d9 100755 --- a/core/compiler/test/simple/simple-tests.factor +++ b/core/compiler/test/simple/simple-tests.factor @@ -1,6 +1,6 @@ USING: compiler tools.test kernel kernel.private combinators.private math.private math combinators strings -alien arrays ; +alien arrays memory ; IN: temporary ! Test empty word @@ -48,6 +48,8 @@ IN: temporary [ 4 1 3 ] [ 0 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test [ 3 1 3 ] [ 1 [ { [ bar 1 ] [ 3 1 ] } dispatch 3 ] compile-call ] unit-test +[ 2 3 ] [ 1 [ { [ code-gc 1 ] [ code-gc 2 ] } dispatch 3 ] compile-call ] unit-test + ! Labels : recursive ( ? -- ) [ f recursive ] when ; inline From 93e10566bef56950add23087e64af1e3da3f2575 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 9 Feb 2008 21:12:00 -0600 Subject: [PATCH 131/194] Simpler compilation of dispatch --- core/cpu/architecture/architecture.factor | 4 +- core/cpu/ppc/architecture/architecture.factor | 23 +++++------ core/cpu/x86/architecture/architecture.factor | 39 ++++++++++--------- core/generator/generator.factor | 29 +++++++++----- 4 files changed, 50 insertions(+), 45 deletions(-) diff --git a/core/cpu/architecture/architecture.factor b/core/cpu/architecture/architecture.factor index 4da22ff38a..4bb10b23a2 100755 --- a/core/cpu/architecture/architecture.factor +++ b/core/cpu/architecture/architecture.factor @@ -60,9 +60,7 @@ HOOK: %jump-label compiler-backend ( label -- ) ! Test if vreg is 'f' or not HOOK: %jump-t compiler-backend ( label -- ) -HOOK: %call-dispatch compiler-backend ( -- label ) - -HOOK: %jump-dispatch compiler-backend ( -- ) +HOOK: %dispatch compiler-backend ( -- ) HOOK: %dispatch-label compiler-backend ( word -- ) diff --git a/core/cpu/ppc/architecture/architecture.factor b/core/cpu/ppc/architecture/architecture.factor index 7444c21a8c..1daf3ac622 100755 --- a/core/cpu/ppc/architecture/architecture.factor +++ b/core/cpu/ppc/architecture/architecture.factor @@ -111,20 +111,15 @@ M: ppc-backend %jump-label ( label -- ) B ; M: ppc-backend %jump-t ( label -- ) 0 "flag" operand f v>operand CMPI BNE ; -: (%dispatch) ( len -- ) - 0 11 LOAD32 rc-absolute-ppc-2/2 rel-here - "offset" operand "n" operand 1 SRAWI - 11 11 "offset" operand ADD - 11 dup rot cells LWZ ; - -M: ppc-backend %call-dispatch ( word-table# -- ) - [ 7 (%dispatch) (%call)